module_mosaic_driver.F
References to this file elsewhere.
1 !**********************************************************************************
2 ! This computer software was prepared by Battelle Memorial Institute, hereinafter
3 ! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of
4 ! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY,
5 ! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
6 !
7 ! Aerosol Option: MOSAIC (Model for Simulating Aerosol Interactions & Chemistry)
8 ! * Primary investigator: Rahul A. Zaveri
9 ! * Co-investigator: Richard C. Easter, William I. Gustafson Jr.
10 ! Last update: September 2005
11 !
12 ! Contains:
13 ! ASTEEM (Adaptive Step Time-split Explicit Euler Method): Solves the dynamic
14 ! dynamic partitioning of semi-volatile species between gas and particle phases.
15 ! MESA (Multicomponent Equilibrium Solver for Aerosols): Solves the multi-
16 ! component solid-liquid equilibria within the aerosol phase.
17 ! MTEM (Multicomponent Taylor Expansion Method): Computes the multicomponent
18 ! activity coefficients of electrolytes in aqueous atmospheric aerosols.
19 !
20 ! Contacts:
21 ! Rahul A. Zaveri, PhD Jerome D. Fast, PhD
22 ! Senior Research Scientist Staff Scientist
23 ! Pacific Northwest National Laboratory Pacific Northwest National Laboratory
24 ! P.O. Box 999, MSIN K9-30 P.O. Box 999, MSIN K9-30
25 ! Richland, WA 99352 Richland, WA, 99352
26 ! Phone: (509) 372-6159 Phone: (509) 372-6116
27 ! Email: Rahul.Zaveri@pnl.gov Email: Jerome.Fast@pnl.gov
28 !
29 ! Please report any bugs or problems to Rahul Zaveri, the primary author of the
30 ! code, or Jerome Fast, the WRF-chem implementation team leader for PNNL
31 !
32 ! Terms of Use:
33 ! 1) MOSAIC and its sub-modules ASTEEM, MESA, and MTEM may not be included in
34 ! any commercial package or used for any commercial applications without the
35 ! primary author's prior consent.
36 ! 2) The MOSAIC source code is provided to the WRF modeling community; however,
37 ! no portion of MOSAIC can be used separately or in another code without the
38 ! primary author's prior consent.
39 ! 3) The MOSAIC source code may be used for research, educational, and non-profit
40 ! purposes only. Any other usage must be first approved by the primary author.
41 ! 4) Publications resulting from the usage of MOSAIC must use one or more of the
42 ! references below (depending on the application) for proper acknowledgment.
43 !
44 ! References:
45 ! * Zaveri R.A., R.C. Easter, and A.S. Wexler (2005), A new method for multi-
46 ! component activity coefficients of electrolytes in aqueous atmospheric
47 ! aerosols, J. Geophys. Res., 110, D02201, doi:10.1029/2004JD004681.
48 ! * Zaveri R.A., R.C. Easter, and L.K. Peters (2005), A computationally efficient
49 ! multicomponent equilibrium solver for aerosols (MESA), In review,
50 ! J. Geophys. Res.
51 ! * Zaveri R.A., R.C. Easter, J.D. Fast, and L.K. Peters (2005), A new model
52 ! for simulating aerosol interactions and chemistry (MOSAIC), Manuscript in
53 ! preparation. To be submitted to J. Geophys. Res.
54 ! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. Barnard, E.G.
55 ! Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution of ozone, particulates,
56 ! and aerosol direct radiative forcing in the vicinity of Houston using a fully-
57 ! coupled meteorology-chemistry-aerosol model, Submitted to J. Geophys. Res.
58 !
59 ! Contact Jerome Fast for updates on the status of manuscripts under review. The
60 ! third paper will be the main reference for MOSAIC when published.
61 !
62 ! Note that the version of MESA currently in WRF-chem does not contain some of
63 ! the code associated with the numerical speed described in the second paper -
64 ! a revised version of MESA will be included in the next release of MOSAIC.
65 !
66 ! Additional information:
67 ! * www.pnl.gov/atmos_sciences/raz
68 ! * www.pnl.gov/atmos_sciences/Jdf/wrfchem.html
69 !
70 ! Support:
71 ! Funding for developing and evaluating MOSAIC was provided by the U.S. Department
72 ! of Energy under the auspices of Atmospheric Science Program of the Office of
73 ! Biological and Environmental Research, the NASA Earth Sciences Enterprise under
74 ! grant NAGW 3367, and PNNL Laboratory Directed Research and Development program.
75 !**********************************************************************************
76 module module_mosaic_driver
77
78
79 !
80 ! *** NOTE - when the cw species are NOT in the registry, then
81 ! then the p_xxx_cwnn variables are not in module_state_description,
82 ! and the following cpp directive should be commented out
83 !
84 #define cw_species_are_in_registry
85
86
87 contains
88
89 !-----------------------------------------------------------------------
90 !
91 ! rce 2005-feb-18 - one fix involving dcen_sect indices [now (isize,itype)]
92 !
93 ! rce 2004-dec-03 - many changes associated with the new aerosol "pointer"
94 ! variables in module_data_mosaic_asect
95 ! nov-04 sg ! replaced amode with aer and expanded aerosol dimension
96 ! to include type and phase
97 !
98 ! rce 11-sep-2004 - numerous changes
99 ! eliminated use of the _wrfch pointers (lptr_xxx_a_wrfch,
100 ! lwaterptr_wrfch, numptr_wrfch); use only the _aer pointers now
101 ! aboxtest_... variables are now in module_data_mosaic_other
102 !
103 !-----------------------------------------------------------------------
104
105 subroutine mosaic_aerchem_driver( &
106 id, ktau, dtstep, ktauc, dtstepc, config_flags, &
107 t_phy, rho_phy, p_phy, &
108 moist, chem, &
109 ids,ide, jds,jde, kds,kde, &
110 ims,ime, jms,jme, kms,kme, &
111 its,ite, jts,jte, kts,kte )
112
113
114 use module_configure, only: grid_config_rec_type, &
115 p_qv, &
116 p_so2, p_ho2, p_so4aj, p_corn, p_hcl, p_mtf, &
117 p_so4_a01, p_water_a01, p_num_a01, &
118 p_so4_a04, p_water_a04, p_num_a04
119
120 use module_state_description, only: num_moist, num_chem
121
122 use module_data_mosaic_asect
123 use module_data_mosaic_other
124 use module_mosaic_therm, only: aerchemistry, print_mosaic_stats, &
125 iprint_mosaic_fe1, iprint_mosaic_perform_stats, &
126 iprint_mosaic_diag1, iprint_mosaic_input_ok
127 use module_mosaic_newnuc, only: mosaic_newnuc_1clm
128 use module_mosaic_coag, only: mosaic_coag_1clm
129 use module_peg_util, only: peg_error_fatal, peg_message
130
131 implicit none
132
133 !-----------------------------------------------------------------------
134 ! DESCRIPTION
135 !
136 ! mosaic_aerchem_driver is the interface between wrf-chem and the
137 ! mosaic aerosol-chemistry routine cat computes condensation/evaporation
138 ! of trace gases to/from aerosol particles (AP). It currently treats
139 ! water vapor and the 4 inorganic trace gases (nh3, h2so4, hno3, and hcl).
140 ! The aerosol-chemistry routine can work with either a sectional
141 ! (multiple size bins) or modal (multiple modes) representation.
142 !
143 ! In both cases, condensation/evaporation to/from each bins/mode is
144 ! first computed. For sectional representation, AP mass and number
145 ! are then transferred between size bins as a result of AP
146 ! positive/negative growth. Either a moving-center or two-moment
147 ! algorithm can be used to compute this transfer.
148 !
149 ! mosaic_aerchem_driver is organized as follows
150 ! loop over j and i
151 ! call mapaer_tofrom_host to map 1 column of gas and aerosol mixing
152 ! ratios from the chem array to the rsub array (and convert units)
153 ! call aerchemistry to do the aerosol chemistry calculations
154 ! for timestep = dtstepc
155 ! call mapaer_tofrom_host to map 1 column of gas and aerosol mixing
156 ! ratios from the rsub array back to the chem array
157 !
158 !-----------------------------------------------------------------------
159
160 ! subr arguments
161 integer, intent(in) :: &
162 id, ktau, ktauc, &
163 ids, ide, jds, jde, kds, kde, &
164 ims, ime, jms, jme, kms, kme, &
165 its, ite, jts, jte, kts, kte
166 ! id - domain index
167 ! ktau - time step number
168 ! ktauc - gas and aerosol chemistry time step number
169
170 ! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for "domain"
171 ! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for "memory"
172 ! Most arrays that are arguments to chem_driver
173 ! are dimensioned with these spatial indices.
174 ! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile"
175 ! chem_driver and routines under it do calculations
176 ! over these spatial indices.
177
178 real, intent(in) :: dtstep, dtstepc
179 ! dtstep - main model time step (s)
180 ! dtstepc - time step for gas and aerosol chemistry(s)
181
182 real, intent(in), &
183 dimension( ims:ime, kms:kme, jms:jme ) :: &
184 t_phy, rho_phy, p_phy
185 ! t_phy - temperature (K)
186 ! rho_phy - air density (kg/m^3)
187 ! p_phy - air pressure (Pa)
188
189 real, intent(in), &
190 dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: &
191 moist
192 ! moist - mixing ratios of moisture species (water vapor,
193 ! cloud water, ...) (kg/kg for mass species, #/kg for number species)
194
195 real, intent(inout), &
196 dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: &
197 chem
198 ! chem - mixing ratios of trace gase (ppm) and aerosol species
199 ! (ug/kg for mass species, #/kg for number species)
200
201 type(grid_config_rec_type), intent(in) :: config_flags
202 ! config_flags - configuration and control parameters
203
204 !-----------------------------------------------------------------------
205 ! local variables
206 integer :: i, idum, istat, it, j, jt, k, l, n
207 integer :: k_pegshift, kclm_calcbgn, kclm_calcend
208 integer :: ktmaps, ktmape
209 integer :: levdbg_err, levdbg_info
210 integer :: i_force_dump, mode_force_dump
211 integer :: idiagaa_dum, idiagbb_dum, ijcount_dum
212 integer, parameter :: debug_level=0
213 integer, parameter :: aercoag_onoff = 1
214 integer, parameter :: aernewnuc_onoff = 1
215
216 real :: dtchem, dtcoag, dtnuc
217 real :: dum
218 real :: rsub0(l2maxd,kmaxd,nsubareamaxd)
219
220 character*100 msg
221
222
223 if (debug_level .ge. 15) then
224 !rcetestc diagnostics --------------------------------------------------
225 ! if (kte .eq. -99887766) then
226 if (ktauc .le. 2) then
227 print 93010, ' '
228 print 93010, 'rcetestc diagnostics from mosaic_aerchem_driver'
229 print 93010, 'id, chem_opt, ktau, ktauc ', &
230 id, config_flags%chem_opt, ktau, ktauc
231 print 93020, 'dtstep, dtstepc ', &
232 dtstep, dtstepc
233 print 93010, 'ims/e, j, k', ims, ime, jms, jme, kms, kme
234 print 93010, 'its/e, j, k', its, ite, jts, jte, kts, kte
235 print 93010, 'num_chem, p_so2, p_ho2 ', num_chem, p_so2, p_ho2
236 print 93010, 'p_so4aj, p_corn, p_hcl, p_mtf', p_so4aj, p_corn, p_hcl, p_mtf
237 print 93010, 'p_so4_a01, p_water, p_num_a01', p_so4_a01, p_water_a01, p_num_a01
238 print 93010, 'p_so4_a04, p_water, p_num_a04', p_so4_a04, p_water_a04, p_num_a04
239
240 k = kts
241 print 93020, 't, p, rho, qv at its/kts /jts', t_phy(its,k,jts), &
242 p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv)
243 k = (kts + kte)/2
244 print 93020, 't, p, rho, qv at its/ktmi/jts', t_phy(its,k,jts), &
245 p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv)
246 k = kte
247 print 93020, 't, p, rho, qv at its/kte /jts', t_phy(its,k,jts), &
248 p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv)
249 93010 format( a, 8(1x,i6) )
250 93020 format( a, 8(1p,e14.6) )
251 end if
252 ! end if
253 !rcetestc diagnostics --------------------------------------------------
254 end if
255
256 ! The default values for these informational printout settings are set
257 ! in module_data_mosaic_therm.F.
258 if (debug_level .lt. 15) then
259 iprint_mosaic_fe1 = 1
260 iprint_mosaic_perform_stats = 0
261 iprint_mosaic_diag1 = 0
262 iprint_mosaic_input_ok = 0
263 end if
264
265
266 ! ktmaps,ktmape = first/last wrf kt for which aer chem is done
267 ktmaps = kts
268 ktmape = kte
269
270 ! rce 2005-mar-09 - added kclm_calcbgn/end
271 ! kclm_calcbgn,kclm_calcend = first/last pegasus array k
272 ! for which aer chem is done
273 k_pegshift = k_pegbegin - kts
274 kclm_calcbgn = kts + k_pegshift
275 kclm_calcend = kte + k_pegshift
276
277 ! set some variables to their wrf-chem "standard" values
278 mode_force_dump = 0
279 levdbg_err = 0
280 levdbg_info = 15
281
282 ! eventually iymdcur & ihmscur should be set to the correct date/time
283 ! using wrf timing routines
284 dum = dtstep*(ktau-1)
285 iymdcur = 1 + ifix( dum/86400.0 )
286 dum = mod( dum, 86400.0 )
287 ihmscur = nint( dum )
288
289 t = dtstep*(ktau-1)
290 ncorecnt = ktau - 1
291
292 #if defined ( aboxtest_box_testing_active )
293 ! *** start of "box testing" code section ***
294 ! these code lines should be inactive when running wrf-chem
295 !
296 ! get values for some "box test" variables
297 call aboxtest_get_extra_args( 20, &
298 iymdcur, ihmscur, &
299 idum, idum, idum, idum, idum, idum, idum, &
300 t, dum )
301 ! *** end of "box testing" code section ***
302 #endif
303
304
305 ! set "pegasus" grid size variables
306 itot = ite
307 jtot = jte
308 nsubareas = 1
309
310 ijcount_dum = 0
311
312 call print_mosaic_stats( 0 )
313
314
315 do 2920 jt = jts, jte
316 do 2910 it = its, ite
317
318 ijcount_dum = ijcount_dum + 1
319 dtchem = dtstepc
320
321
322 ! mode_force_dump selects a detailed dump of gaschem at either
323 ! first ijk grid, first ij column, all ijk, or no ijk
324 i_force_dump = 0
325 ! if (mode_force_dump .eq. 10) then
326 ! if ((it.eq.its) .and. (jt.eq.jts)) i_force_dump = 1
327 ! else if (mode_force_dump .eq. 100) then
328 ! i_force_dump = 1
329 ! else if (mode_force_dump .eq. 77) then
330 ! if ( (it .eq. (its+ite)/2) .and. &
331 ! (jt .eq. (jts+jte)/2) ) i_force_dump = 1
332 ! end if
333
334
335 ! print 93010, 'calling mapaeraa - it, jt =', it, jt
336 call mapaer_tofrom_host( 0, &
337 ims,ime, jms,jme, kms,kme, &
338 its,ite, jts,jte, kts,kte, &
339 it, jt, ktmaps,ktmape, &
340 num_moist, num_chem, moist, chem, &
341 t_phy, p_phy, rho_phy )
342
343 !rce 22-jul-2006 - save initial mixrats
344 rsub0(:,:,:) = rsub(:,:,:)
345
346 idiagaa_dum = 0
347 idiagbb_dum = 110
348 !rce 29-apr-2004 - following is for debugging texas 16 km run
349 ! if ((its.eq.38) .and. (jts.eq.38) &
350 ! .and. (ktau.eq.240)) idiagaa_dum = 1
351 ! if ((it .eq.45) .and. (jt .eq.71) &
352 ! .and. (ktau.eq.240)) idiagaa_dum = 1
353 ! if ( ijcount_dum > 169 .and. ktau > 2579 ) then !fastj crash
354 ! if ( ijcount_dum > 300 .and. ktau > 2969 ) then !madronovich crash
355 ! idiagaa_dum = 111
356 ! i_force_dump = 1
357 ! end if
358
359 ! if (ijcount_dum .le. 1) i_force_dump = 1
360 ! i_force_dump = 0
361
362 if (i_force_dump > 0) call aerchem_debug_dump( 1, it, jt, dtchem )
363
364 ! if ((it .eq.45) .and. (jt .eq.71) &
365 ! .and. (ktau.eq.240)) then
366 ! call aerchem_debug_dump( 1, it, jt, dtchem )
367 ! call aerchem_debug_dump( 3, it, jt, dtchem )
368 ! end if
369
370 if (idiagaa_dum > 0) &
371 print 93010, 'calling aerchem - it,jt,maerchem =', it, jt, maerchem
372 ! print 93010, 'calling aerchem - it,jt,maerchem =', it, jt, maerchem
373 call aerchemistry( it, jt, kclm_calcbgn, kclm_calcend, &
374 dtchem, idiagaa_dum )
375
376 ! note units for aerosol is now ug/m3
377
378 call wrf_debug(300,"mosaic_aerchem_driver: back from aerchemistry")
379 if ((it .eq.45) .and. (jt .eq.71) &
380 .and. (ktau.eq.240)) then
381 call aerchem_debug_dump( 3, it, jt, dtchem )
382 end if
383
384 if (i_force_dump > 0) call aerchem_debug_dump( 3, it, jt, dtchem )
385
386
387 if (aernewnuc_onoff > 0) then
388 if (idiagaa_dum > 0) print 93010, 'calling mosaic_newnuc_1clm'
389 dtnuc = dtchem
390 call mosaic_newnuc_1clm( istat, &
391 it, jt, kclm_calcbgn, kclm_calcend, &
392 idiagbb_dum, dtchem, dtnuc, rsub0, &
393 id, ktau, ktauc, its, ite, jts, jte, kts, kte )
394 end if
395
396
397 if (aercoag_onoff > 0) then
398 if (idiagaa_dum > 0) print 93010, 'calling mosaic_coag_1clm'
399 dtcoag = dtchem
400 call mosaic_coag_1clm( istat, &
401 it, jt, kclm_calcbgn, kclm_calcend, &
402 idiagbb_dum, dtchem, dtcoag, &
403 id, ktau, ktauc, its, ite, jts, jte, kts, kte )
404 end if
405
406
407 if (idiagaa_dum > 0) &
408 print 93010, 'calling mapaerbb'
409 call mapaer_tofrom_host( 1, &
410 ims,ime, jms,jme, kms,kme, &
411 its,ite, jts,jte, kts,kte, &
412 it, jt, ktmaps,ktmape, &
413 num_moist, num_chem, moist, chem, &
414 t_phy, p_phy, rho_phy )
415
416 ! print 93010, 'backfrm mapaerbb', it, jt
417 2910 continue
418 2920 continue
419
420
421 ! rce 2005-apr-30 - added 2 calls to print_mosaic_stats
422 call print_mosaic_stats( 1 )
423 print 93010, 'leaving mosaic_aerchem_driver - ktau =', ktau
424
425 return
426 end subroutine mosaic_aerchem_driver
427
428
429 !-----------------------------------------------------------------------
430 subroutine sum_pm_mosaic ( &
431 alt, chem, &
432 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, &
433 ids,ide, jds,jde, kds,kde, &
434 ims,ime, jms,jme, kms,kme, &
435 its,ite, jts,jte, kts,kte )
436
437 USE module_state_description, only: num_chem
438 USE module_data_mosaic_asect
439 IMPLICIT NONE
440
441 INTEGER, INTENT(IN ) :: &
442 ids,ide, jds,jde, kds,kde, &
443 ims,ime, jms,jme, kms,kme, &
444 its,ite, jts,jte, kts,kte
445
446 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
447 INTENT(IN) :: alt
448
449 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
450 INTENT(IN ) :: chem
451
452 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
453 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
454
455 REAL :: mass
456
457 INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase
458
459 imax = min(ite,ide-1)
460 jmax = min(jte,jde-1)
461 kmax = kte
462 !
463 ! Sum over bins with center diameter < 2.5e-4 cm for pm2_5_dry,
464 ! pm2_5_dry_ec, and pm2_5_water. All bins go into pm10
465 !
466 pm2_5_dry(its:imax,kts:kmax,jts:jmax) = 0.
467 pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = 0.
468 pm2_5_water(its:imax,kts:kmax,jts:jmax) = 0.
469 pm10(its:imax,kts:kmax,jts:jmax) = 0.
470
471 do iphase=1,nphase_aer
472 do itype=1,ntype_aer
473 do n = 1, nsize_aer(itype)
474 if (dcen_sect(n,itype) .le. 2.5e-4) then
475 do j=jts,jmax
476 do k=kts,kmax
477 do i=its,imax
478 mass = chem(i,k,j,lptr_so4_aer(n,itype,iphase)) &
479 + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) &
480 + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) &
481 + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) &
482 + chem(i,k,j,lptr_na_aer(n,itype,iphase)) &
483 + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) &
484 + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) &
485 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
486
487 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) + mass
488
489 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) &
490 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
491
492 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) &
493 + chem(i,k,j,waterptr_aer(n,itype))
494
495 pm10(i,k,j) = pm10(i,k,j) + mass
496 enddo
497 enddo
498 enddo
499 else
500 do j=jts,jmax
501 do k=kts,kmax
502 do i=its,imax
503 pm10(i,k,j) = pm10(i,k,j) &
504 + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) &
505 + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) &
506 + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) &
507 + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) &
508 + chem(i,k,j,lptr_na_aer(n,itype,iphase)) &
509 + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) &
510 + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) &
511 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
512 enddo
513 enddo
514 enddo
515 endif
516 enddo ! size
517 enddo ! type
518 enddo ! phase
519
520 !Convert the units from mixing ratio to concentration (ug m^-3)
521 pm2_5_dry(its:imax,kts:kmax,jts:jmax) = pm2_5_dry(its:imax,kts:kmax,jts:jmax) &
522 / alt(its:imax,kts:kmax,jts:jmax)
523 pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) &
524 / alt(its:imax,kts:kmax,jts:jmax)
525 pm2_5_water(its:imax,kts:kmax,jts:jmax) = pm2_5_water(its:imax,kts:kmax,jts:jmax) &
526 / alt(its:imax,kts:kmax,jts:jmax)
527 pm10(its:imax,kts:kmax,jts:jmax) = pm10(its:imax,kts:kmax,jts:jmax) &
528 / alt(its:imax,kts:kmax,jts:jmax)
529
530 end subroutine sum_pm_mosaic
531
532 ! ----------------------------------------------------------------------
533 subroutine mapaer_tofrom_host( imap, &
534 ims,ime, jms,jme, kms,kme, &
535 its,ite, jts,jte, kts,kte, &
536 it, jt, ktmaps,ktmape, &
537 num_moist, num_chem, moist, chem, &
538 t_phy, p_phy, rho_phy )
539
540 use module_configure, only: &
541 p_qv, p_qc, p_sulf, p_hno3, p_hcl, p_nh3, p_o3, &
542 p_so2, p_h2o2, p_hcho, p_ora1, p_ho, p_ho2, p_no3, &
543 p_no, p_no2, p_hono, p_pan, p_ch3o2, p_ch3oh, p_op1
544 use module_state_description, only: param_first_scalar
545 use module_data_mosaic_asect
546 use module_data_mosaic_other
547 use module_mosaic_csuesat, only: esat_gchm
548 use module_peg_util, only: peg_error_fatal, peg_message
549
550 implicit none
551
552 ! subr arguments
553
554 ! imap determines mapping direction (chem-->rsub if <=0, rsub-->chem if >0)
555 integer, intent(in) :: imap
556 ! wrf array dimensions
557 integer, intent(in) :: num_moist, num_chem
558 integer, intent(in) :: ims, ime, jms, jme, kms, kme
559 integer, intent(in) :: its, ite, jts, jte, kts, kte
560 ! do mapping for wrf i,k,j grid points = [it,ktmaps:ktmape,jt]
561 integer, intent(in) :: it, jt, ktmaps, ktmape
562 !
563 real, intent(in), dimension( ims:ime, kms:kme, jms:jme ) :: &
564 t_phy, rho_phy, p_phy
565
566 real, intent(in), &
567 dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: &
568 moist
569
570 real, intent(inout), &
571 dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: &
572 chem
573
574
575 ! local variables
576 integer ido_l, idum, iphase, itype, &
577 k, k1, k2, kt, kt1, kt2, k_pegshift, l, n
578 integer p1st
579 real dum, dumesat, dumrsat, dumrelhum, onemeps
580 real factdens, factpres, factmoist, factgas, &
581 factaerso4, factaerno3, factaercl, factaermsa, &
582 factaerco3, factaernh4, factaerna, factaerca, &
583 factaeroin, factaeroc, factaerbc, &
584 factaerhysw, factaerwater, factaernum
585
586 real, parameter :: eps=0.622
587
588 character*80 msg
589
590
591 !
592 ! units conversion factors
593 ! wrf-chem value = pegasus value X factor
594 !
595 factdens = 28.966e3 ! moleair/cm3 --> kgair/m3
596 factpres = 0.1 ! dyne/cm2 --> pa
597 factmoist = eps ! moleh2o/moleair --> kgh2o/kgair
598 factgas = 1.0e6 ! mole/moleair --> ppm
599
600 !wig 9-Nov-2004: Change to converting from concentration to converting
601 ! from mixing ratio.
602 ! factaernum = 40.9 ! #/moleair --> #/m3 at STP
603 !! at 1 atm & 298 k, 1 m3 = 40.9 moleair, 1 liter = 0.0409 moleair
604 factaernum = 1000./28.966 ! 1 kg air = (1000/28.966) moleair
605
606 dum = factaernum*1.0e6 ! g/moleair --> ug/m3 at STP
607 factaerso4 = dum*mw_so4_aer
608 factaerno3 = dum*mw_no3_aer
609 factaercl = dum*mw_cl_aer
610 factaermsa = dum*mw_msa_aer
611 factaerco3 = dum*mw_co3_aer
612 factaernh4 = dum*mw_nh4_aer
613 factaerna = dum*mw_na_aer
614 factaerca = dum*mw_ca_aer
615 factaeroin = dum
616 factaeroc = dum
617 factaerbc = dum
618 factaerhysw = dum*mw_water_aer
619 factaerwater = dum*mw_water_aer
620
621 ! If aboxtest_units_convert=10, turn off units conversions both here
622 ! and in module_mosaic. This is for testing, to allow exact agreements.
623 if (aboxtest_units_convert .eq. 10) then
624 factdens = 1.0
625 factpres = 1.0
626 factmoist = 1.0
627 factgas = 1.0
628 factaernum = 1.0
629 factaerso4 = 1.0
630 factaerno3 = 1.0
631 factaercl = 1.0
632 factaermsa = 1.0
633 factaerco3 = 1.0
634 factaernh4 = 1.0
635 factaerna = 1.0
636 factaerca = 1.0
637 factaeroin = 1.0
638 factaeroc = 1.0
639 factaerbc = 1.0
640 factaerhysw = 1.0
641 factaerwater = 1.0
642 end if
643
644
645 ! rce 2005-mar-09 - set ktot in mapaer_tofrom_host;
646 ! use k_pegshift for calc of ktot and k (=k_peg)
647 ! k_pegshift = k index shift between wrf-chem and pegasus arrays
648 k_pegshift = k_pegbegin - kts
649
650 ! set ktot = highest k index for pegasus arrays
651 ! since kts=1 and k_pegbegin=1, get k_pegshift=0 and ktot=kte-1
652 ktot = (kte-1) + k_pegshift
653 ! *** check that ktot and kte <= kmaxd ***
654 if ((kte > kmaxd) .or. (ktot > kmaxd) .or. (ktot <= 0)) then
655 write( msg, '(a,4i5)' ) &
656 '*** subr mapaer_tofrom_host -- ' // &
657 'ktot, kmaxd, kts, kte', ktot, kmaxd, kts, kte
658 call peg_message( lunerr, msg )
659 msg = '*** subr mosaic_aerchem_driver -- ' // &
660 'kte>kmaxd OR ktot>kmaxd OR ktot<=0'
661 call peg_error_fatal( lunerr, msg )
662 end if
663
664 ! rce 2005-apr-28 - changed mapping loops to improve memory access
665 ! now do rsub(l,k1:k2,m) <--> chem(it,kt1:kt2,jt,l) for each species
666 kt1 = ktmaps
667 kt2 = ktmape
668 k1 = kt1 + k_pegshift
669 k2 = kt2 + k_pegshift
670
671 if (imap .gt. 0) goto 2000
672
673 !
674 ! imap==0 -- map species and state variables from host arrays
675 ! to rsub, cairclm, ptotclm
676
677 ! first zero everything (except relhumclm)
678 rsub(:,:,:) = 0.0
679 cairclm(:) = 0.0
680 ptotclm(:) = 0.0
681 afracsubarea(:,:) = 0.0
682 relhumclm(:) = aboxtest_min_relhum
683 rcldwtr_sub(:,:) = 0.0
684
685 adrydens_sub( :,:,:,:) = 0.0
686 aqmassdry_sub(:,:,:,:) = 0.0
687 aqvoldry_sub( :,:,:,:) = 0.0
688
689 ! map gas and aerosol mixing ratios based on aboxtest_map_method
690 ! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx
691 ! 2 - map 181 pegasus species using rsub(l) = chem(l+1)
692 ! 3 - do 2 followed by 1
693 ! other - same as 1
694 ! (2 and 3 are for box test purposes)
695 if ((aboxtest_map_method .eq. 2) .or. &
696 (aboxtest_map_method .eq. 3)) then
697 do l = 2, num_chem
698 rsub(l,k1:k2,1) = chem(it,kt1:kt2,jt,l)/factgas
699 end do
700 end if
701
702 p1st = param_first_scalar
703 if (aboxtest_map_method .ne. 2) then
704 if (p_sulf .ge. p1st) &
705 rsub(kh2so4,k1:k2,1) = chem(it,kt1:kt2,jt,p_sulf)/factgas
706 if (p_hno3 .ge. p1st) &
707 rsub(khno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_hno3)/factgas
708 if (p_hcl .ge. p1st) &
709 rsub(khcl,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcl)/factgas
710 if (p_nh3 .ge. p1st) &
711 rsub(knh3,k1:k2,1) = chem(it,kt1:kt2,jt,p_nh3)/factgas
712
713 ! rce 2005-apr-12 - added following species for cldchem, here and below:
714 ! ko3, kso2, kh2o2, khcho, khcooh, koh, kho2,
715 ! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh
716 if (p_o3 .ge. p1st) &
717 rsub(ko3,k1:k2,1) = chem(it,kt1:kt2,jt,p_o3)/factgas
718 if (p_so2 .ge. p1st) &
719 rsub(kso2,k1:k2,1) = chem(it,kt1:kt2,jt,p_so2)/factgas
720 if (p_h2o2 .ge. p1st) &
721 rsub(kh2o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_h2o2)/factgas
722 if (p_hcho .ge. p1st) &
723 rsub(khcho,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcho)/factgas
724 if (p_ora1 .ge. p1st) &
725 rsub(khcooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ora1)/factgas
726 if (p_ho .ge. p1st) &
727 rsub(koh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho)/factgas
728 if (p_ho2 .ge. p1st) &
729 rsub(kho2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho2)/factgas
730 if (p_no3 .ge. p1st) &
731 rsub(kno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_no3)/factgas
732 if (p_no .ge. p1st) &
733 rsub(kno,k1:k2,1) = chem(it,kt1:kt2,jt,p_no)/factgas
734 if (p_no2 .ge. p1st) &
735 rsub(kno2,k1:k2,1) = chem(it,kt1:kt2,jt,p_no2)/factgas
736 if (p_hono .ge. p1st) &
737 rsub(khono,k1:k2,1) = chem(it,kt1:kt2,jt,p_hono)/factgas
738 if (p_pan .ge. p1st) &
739 rsub(kpan,k1:k2,1) = chem(it,kt1:kt2,jt,p_pan)/factgas
740 if (p_ch3o2 .ge. p1st) &
741 rsub(kch3o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3o2)/factgas
742 if (p_ch3oh .ge. p1st) &
743 rsub(kch3oh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3oh)/factgas
744 if (p_op1 .ge. p1st) &
745 rsub(kch3ooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_op1)/factgas
746
747 do iphase=1,nphase_aer
748 do itype=1,ntype_aer
749 do n = 1, nsize_aer(itype)
750 rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1) = &
751 chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase))/factaerso4
752 rsub(numptr_aer(n,itype,iphase),k1:k2,1) = &
753 chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase))/factaernum
754
755 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) &
756 rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1) = &
757 chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase))/factaerno3
758 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) &
759 rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1) = &
760 chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase))/factaercl
761 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) &
762 rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1) = &
763 chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase))/factaermsa
764 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) &
765 rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1) = &
766 chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase))/factaerco3
767 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) &
768 rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1) = &
769 chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase))/factaernh4
770 if (lptr_na_aer(n,itype,iphase) .ge. p1st) &
771 rsub(lptr_na_aer(n,itype,iphase),k1:k2,1) = &
772 chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase))/factaerna
773 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) &
774 rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1) = &
775 chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase))/factaerca
776 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) &
777 rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1) = &
778 chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase))/factaeroin
779 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) &
780 rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1) = &
781 chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase))/factaeroc
782 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) &
783 rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1) = &
784 chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase))/factaerbc
785 if (hyswptr_aer(n,itype) .ge. p1st) &
786 rsub(hyswptr_aer(n,itype),k1:k2,1) = &
787 chem(it,kt1:kt2,jt,hyswptr_aer(n,itype))/factaerhysw
788 if (waterptr_aer(n,itype) .ge. p1st) &
789 rsub(waterptr_aer(n,itype),k1:k2,1) = &
790 chem(it,kt1:kt2,jt,waterptr_aer(n,itype))/factaerwater
791 end do ! size
792 end do ! type
793 end do ! phase
794 end if
795
796 ! map state variables
797 afracsubarea(k1:k2,1) = 1.0
798 rsub(ktemp,k1:k2,1) = t_phy(it,kt1:kt2,jt)
799 rsub(kh2o,k1:k2,1) = moist(it,kt1:kt2,jt,p_qv)/factmoist
800 cairclm(k1:k2) = rho_phy(it,kt1:kt2,jt)/factdens
801 ptotclm(k1:k2) = p_phy(it,kt1:kt2,jt)/factpres
802 if (p_qc .ge. p1st) &
803 rcldwtr_sub(k1:k2,1) = moist(it,kt1:kt2,jt,p_qc)/factmoist
804
805 ! compute or get relative humidity, based on aboxtest_rh_method
806 ! 1 - compute from water vapor, temperature, and pressure
807 ! 2 - get from test driver via aboxtest_get_extra_args with iflag=30
808 ! 3 - do both, and use the relhum from test driver
809 ! other positive - same as 1
810 ! 0 or negative - set to aboxtest_min_relhum
811
812 #if defined ( aboxtest_box_testing_active )
813 ! *** start of "box testing" code section ***
814 ! these code lines should be inactive when running wrf-chem
815 !
816 ! get relhumclm from box test driver
817 if ((aboxtest_rh_method .eq. 2) .or. &
818 (aboxtest_rh_method .eq. 3)) then
819 do kt = ktmaps, ktmape
820 k = kt + k_pegshift
821 call aboxtest_get_extra_args( 30, &
822 it, jt, k, idum, idum, idum, idum, idum, idum, &
823 relhumclm(k), dum )
824 end do
825 end if
826 ! *** end of "box testing" code section ***
827 #endif
828
829 ! compute relhumclm from water vapor, temperature, and pressure
830 ! *** force relhum to between aboxtest_min/max_relhum
831 if ((aboxtest_rh_method .gt. 0) .and. &
832 (aboxtest_rh_method .ne. 2)) then
833 do kt = ktmaps, ktmape
834 k = kt + k_pegshift
835 onemeps = 1.0 - 0.622
836 dumesat = esat_gchm( rsub(ktemp,k,1) )
837 dumrsat = dumesat / (ptotclm(k) - onemeps*dumesat)
838 dumrelhum = rsub(kh2o,k,1) / max( dumrsat, 1.e-20 )
839 dumrelhum = max( 0.0, min( 0.99, dumrelhum ) )
840
841 if (aboxtest_rh_method .eq. 3) then
842 ! write(msg,9720) k, relhumclm(k), dumrelhum, &
843 ! (dumrelhum-relhumclm(k))
844 !9720 format( 'k,rh1,rh2,2-1', i4, 3f14.10 )
845 ! call peg_message( lunerr, msg )
846 continue
847 else
848 relhumclm(k) = dumrelhum
849 end if
850 relhumclm(k) = max( relhumclm(k), aboxtest_min_relhum )
851 relhumclm(k) = min( relhumclm(k), aboxtest_max_relhum )
852 end do
853 end if
854
855 ! *** force temperature to be > aboxtest_min_temp
856 do kt = ktmaps, ktmape
857 k = kt + k_pegshift
858 rsub(ktemp,k,1) = &
859 max( rsub(ktemp,k,1), aboxtest_min_temp )
860 end do
861
862 return
863
864
865 !
866 ! imap==1 -- map species from rsub back to host arrays
867 ! (map gas and aerosol mixing ratios based on aboxtest_map_method as above)
868 !
869 ! when aboxtest_gases_fixed==10, leave gases (h2so4,hno3,...) unchanged
870 !
871 2000 continue
872 ! map gas and aerosol mixing ratios based on aboxtest_map_method
873 ! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx
874 ! 2 - map 181 pegasus species using rsub(l) = chem(l+1)
875 ! 3 - do 2 followed by 1
876 ! other - same as 1
877 ! (2 and 3 are for box test purposes)
878 if ((aboxtest_map_method .eq. 2) .or. &
879 (aboxtest_map_method .eq. 3)) then
880 do l = 2, num_chem
881 ido_l = 1
882 if (aboxtest_gases_fixed .eq. 10) then
883 if ((l .eq. kh2so4 ) .or. (l .eq. khno3 ) .or. &
884 (l .eq. khcl ) .or. (l .eq. knh3 ) .or. &
885 (l .eq. ko3 ) .or. &
886 (l .eq. kso2 ) .or. (l .eq. kh2o2 ) .or. &
887 (l .eq. khcho ) .or. (l .eq. khcooh ) .or. &
888 (l .eq. koh ) .or. (l .eq. kho2 ) .or. &
889 (l .eq. kno3 ) .or. (l .eq. kno ) .or. &
890 (l .eq. kno2 ) .or. (l .eq. khono ) .or. &
891 (l .eq. kpan ) .or. (l .eq. kch3o2 ) .or. &
892 (l .eq. kch3oh ) .or. (l .eq. kch3ooh)) then
893 ido_l = 0
894 end if
895 end if
896 if (ido_l .gt. 0) then
897 chem(it,kt1:kt2,jt,l) = rsub(l,k1:k2,1)*factgas
898 end if
899 end do
900 end if
901
902 p1st = param_first_scalar
903 if (aboxtest_map_method .ne. 2) then
904 if (aboxtest_gases_fixed .ne. 10) then
905 if (p_sulf .ge. p1st) &
906 chem(it,kt1:kt2,jt,p_sulf) = rsub(kh2so4,k1:k2,1)*factgas
907 if (p_hno3 .ge. p1st) &
908 chem(it,kt1:kt2,jt,p_hno3) = rsub(khno3,k1:k2,1)*factgas
909 if (p_hcl .ge. p1st) &
910 chem(it,kt1:kt2,jt,p_hcl) = rsub(khcl,k1:k2,1)*factgas
911 if (p_nh3 .ge. p1st) &
912 chem(it,kt1:kt2,jt,p_nh3) = rsub(knh3,k1:k2,1)*factgas
913
914 if (p_o3 .ge. p1st) &
915 chem(it,kt1:kt2,jt,p_o3) = rsub(ko3,k1:k2,1)*factgas
916 if (p_so2 .ge. p1st) &
917 chem(it,kt1:kt2,jt,p_so2) = rsub(kso2,k1:k2,1)*factgas
918 if (p_h2o2 .ge. p1st) &
919 chem(it,kt1:kt2,jt,p_h2o2) = rsub(kh2o2,k1:k2,1)*factgas
920 if (p_hcho .ge. p1st) &
921 chem(it,kt1:kt2,jt,p_hcho) = rsub(khcho,k1:k2,1)*factgas
922 if (p_ora1 .ge. p1st) &
923 chem(it,kt1:kt2,jt,p_ora1) = rsub(khcooh,k1:k2,1)*factgas
924 if (p_ho .ge. p1st) &
925 chem(it,kt1:kt2,jt,p_ho) = rsub(koh,k1:k2,1)*factgas
926 if (p_ho2 .ge. p1st) &
927 chem(it,kt1:kt2,jt,p_ho2) = rsub(kho2,k1:k2,1)*factgas
928 if (p_no3 .ge. p1st) &
929 chem(it,kt1:kt2,jt,p_no3) = rsub(kno3,k1:k2,1)*factgas
930 if (p_no .ge. p1st) &
931 chem(it,kt1:kt2,jt,p_no) = rsub(kno,k1:k2,1)*factgas
932 if (p_no2 .ge. p1st) &
933 chem(it,kt1:kt2,jt,p_no2) = rsub(kno2,k1:k2,1)*factgas
934 if (p_hono .ge. p1st) &
935 chem(it,kt1:kt2,jt,p_hono) = rsub(khono,k1:k2,1)*factgas
936 if (p_pan .ge. p1st) &
937 chem(it,kt1:kt2,jt,p_pan) = rsub(kpan,k1:k2,1)*factgas
938 if (p_ch3o2 .ge. p1st) &
939 chem(it,kt1:kt2,jt,p_ch3o2) = rsub(kch3o2,k1:k2,1)*factgas
940 if (p_ch3oh .ge. p1st) &
941 chem(it,kt1:kt2,jt,p_ch3oh) = rsub(kch3oh,k1:k2,1)*factgas
942 if (p_op1 .ge. p1st) &
943 chem(it,kt1:kt2,jt,p_op1) = rsub(kch3ooh,k1:k2,1)*factgas
944 end if
945
946 do iphase=1,nphase_aer
947 do itype=1,ntype_aer
948 do n = 1, nsize_aer(itype)
949 chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase)) = &
950 rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1)*factaerso4
951 chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase)) = &
952 rsub(numptr_aer(n,itype,iphase),k1:k2,1)*factaernum
953
954 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) &
955 chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase)) = &
956 rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1)*factaerno3
957 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) &
958 chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase)) = &
959 rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1)*factaercl
960 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) &
961 chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase)) = &
962 rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1)*factaermsa
963 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) &
964 chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase)) = &
965 rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1)*factaerco3
966 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) &
967 chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase)) = &
968 rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1)*factaernh4
969 if (lptr_na_aer(n,itype,iphase) .ge. p1st) &
970 chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase)) = &
971 rsub(lptr_na_aer(n,itype,iphase),k1:k2,1)*factaerna
972 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) &
973 chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase)) = &
974 rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1)*factaerca
975 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) &
976 chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase)) = &
977 rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1)*factaeroin
978 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) &
979 chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase)) = &
980 rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1)*factaeroc
981 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) &
982 chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase)) = &
983 rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1)*factaerbc
984 if (hyswptr_aer(n,itype) .ge. p1st) &
985 chem(it,kt1:kt2,jt,hyswptr_aer(n,itype)) = &
986 rsub(hyswptr_aer(n,itype),k1:k2,1)*factaerhysw
987 if (waterptr_aer(n,itype) .ge. p1st) &
988 chem(it,kt1:kt2,jt,waterptr_aer(n,itype)) = &
989 rsub(waterptr_aer(n,itype),k1:k2,1)*factaerwater
990 end do ! size
991 end do ! type
992 end do ! phase
993 end if
994
995
996 return
997
998 end subroutine mapaer_tofrom_host
999
1000
1001 !-----------------------------------------------------------------------
1002 ! *** note - eventually is_aerosol will be a subr argument
1003 subroutine init_data_mosaic_asect( is_aerosol )
1004 ! subroutine init_data_mosaic_asect( )
1005
1006 use module_data_mosaic_asect
1007 use module_data_mosaic_other, only: lunerr, lunout, &
1008 aboxtest_testmode, aboxtest_units_convert, &
1009 aboxtest_rh_method, aboxtest_map_method, &
1010 aboxtest_gases_fixed, aboxtest_min_temp, &
1011 aboxtest_min_relhum, aboxtest_max_relhum
1012 use module_data_mosaic_therm, only: nbin_a, nbin_a_maxd
1013 use module_mosaic_csuesat, only: init_csuesat
1014 use module_mosaic_movesect, only: move_sections, test_move_sections
1015 use module_peg_util, only: peg_error_fatal
1016
1017
1018 use module_configure, only: &
1019 p_so4_a01, p_so4_a02, p_so4_a03, p_so4_a04, &
1020 p_so4_a05, p_so4_a06, p_so4_a07, p_so4_a08
1021 #if defined ( cw_species_are_in_registry )
1022 use module_configure, only: &
1023 p_so4_cw01, p_no3_cw01, p_cl_cw01, p_nh4_cw01, p_na_cw01, &
1024 p_so4_cw02, p_no3_cw02, p_cl_cw02, p_nh4_cw02, p_na_cw02, &
1025 p_so4_cw03, p_no3_cw03, p_cl_cw03, p_nh4_cw03, p_na_cw03, &
1026 p_so4_cw04, p_no3_cw04, p_cl_cw04, p_nh4_cw04, p_na_cw04, &
1027 p_so4_cw05, p_no3_cw05, p_cl_cw05, p_nh4_cw05, p_na_cw05, &
1028 p_so4_cw06, p_no3_cw06, p_cl_cw06, p_nh4_cw06, p_na_cw06, &
1029 p_so4_cw07, p_no3_cw07, p_cl_cw07, p_nh4_cw07, p_na_cw07, &
1030 p_so4_cw08, p_no3_cw08, p_cl_cw08, p_nh4_cw08, p_na_cw08, &
1031 p_oin_cw01, p_oc_cw01, p_bc_cw01, p_num_cw01, &
1032 p_oin_cw02, p_oc_cw02, p_bc_cw02, p_num_cw02, &
1033 p_oin_cw03, p_oc_cw03, p_bc_cw03, p_num_cw03, &
1034 p_oin_cw04, p_oc_cw04, p_bc_cw04, p_num_cw04, &
1035 p_oin_cw05, p_oc_cw05, p_bc_cw05, p_num_cw05, &
1036 p_oin_cw06, p_oc_cw06, p_bc_cw06, p_num_cw06, &
1037 p_oin_cw07, p_oc_cw07, p_bc_cw07, p_num_cw07, &
1038 p_oin_cw08, p_oc_cw08, p_bc_cw08, p_num_cw08
1039 #endif
1040
1041 use module_state_description, only: param_first_scalar, num_chem
1042
1043 implicit none
1044
1045 ! *** note - eventually is_aerosol will be a subr argument
1046 logical, intent(out) :: is_aerosol(num_chem)
1047
1048 ! local variables
1049 integer idum, itype, l, ldum, n, nhi, nsize_aer_dum
1050 real dum
1051 real, parameter :: pi = 3.14159265
1052
1053 !
1054 ! set some "pegasus" control variables
1055 !
1056 msectional = 20
1057 maerocoag = -2
1058 maerchem = 1
1059 maeroptical = 1
1060 maerchem_boxtest_output = -1
1061
1062 !
1063 ! set ntype_aer = 1
1064 !
1065 ntype_aer = 1
1066
1067 !
1068 ! set number of aerosol bins using the wrf-chem sulfate pointers
1069 !
1070 nsize_aer(:) = 0
1071 itype=1
1072 if (p_so4_a01 .ge. param_first_scalar) nsize_aer(itype) = 1
1073 if (p_so4_a02 .ge. param_first_scalar) nsize_aer(itype) = 2
1074 if (p_so4_a03 .ge. param_first_scalar) nsize_aer(itype) = 3
1075 if (p_so4_a04 .ge. param_first_scalar) nsize_aer(itype) = 4
1076 if (p_so4_a05 .ge. param_first_scalar) nsize_aer(itype) = 5
1077 if (p_so4_a06 .ge. param_first_scalar) nsize_aer(itype) = 6
1078 if (p_so4_a07 .ge. param_first_scalar) nsize_aer(itype) = 7
1079 if (p_so4_a08 .ge. param_first_scalar) nsize_aer(itype) = 8
1080
1081 if (nsize_aer(itype) .le. 0) then
1082 call peg_error_fatal( lunerr, &
1083 'init_data_mosaic_asect - nsize_aer = 0' )
1084 else if (nsize_aer(itype) .gt. maxd_asize) then
1085 call peg_error_fatal( lunerr, &
1086 'init_data_mosaic_asect - nsize_aer > maxd_asize' )
1087 end if
1088
1089 !
1090 ! set nbin_a to total number of aerosol bins (for all types)
1091 !
1092 nbin_a = 0
1093 do itype = 1, ntype_aer
1094 nbin_a = nbin_a + nsize_aer(itype)
1095 end do
1096 if (nbin_a .gt. nbin_a_maxd) then
1097 call peg_error_fatal( lunerr, &
1098 'init_data_mosaic_asect - nbin_a > nbin_a_maxd' )
1099 end if
1100
1101 !
1102 ! set nphase_aer (number of active aerosol species phases),
1103 ! the xx_phase, and maerosolincw
1104 !
1105 nphase_aer = 0
1106 maerosolincw = 0
1107 if (nsize_aer(1) .gt. 0) then
1108 nphase_aer = 1
1109 ai_phase = 1
1110
1111 #if defined ( cw_species_are_in_registry )
1112 if (p_so4_cw01 .ge. param_first_scalar) then
1113 nphase_aer = 2
1114 cw_phase = 2
1115 maerosolincw = 1
1116 end if
1117 #endif
1118 end if
1119
1120
1121 #if defined ( aboxtest_box_testing_active )
1122 ! *** start of "box testing" code section ***
1123 ! these code lines should be inactive when running wrf-chem
1124 !
1125 ! set some variables to "box test" values
1126 call aboxtest_get_extra_args( 10, &
1127 msectional, maerosolincw, maerocoag, &
1128 maerchem, maeroptical, maerchem_boxtest_output, &
1129 lunerr, lunout, idum, dum, dum )
1130 call aboxtest_get_extra_args( 11, &
1131 aboxtest_testmode, aboxtest_units_convert, &
1132 aboxtest_rh_method, aboxtest_map_method, &
1133 aboxtest_gases_fixed, nsize_aer_dum, &
1134 idum, idum, idum, dum, dum )
1135
1136 itype = 1
1137 if (nsize_aer_dum > 0) nsize_aer(itype) = nsize_aer_dum
1138
1139 aboxtest_min_temp = 0.0
1140 aboxtest_min_relhum = 0.0
1141 aboxtest_max_relhum = 1.0
1142 ! *** end of "box testing" code section ***
1143 #endif
1144
1145
1146 !
1147 ! set master aerosol chemical types
1148 !
1149 ntot_mastercomp_aer = 11
1150
1151 l = 1
1152 mastercompindx_so4_aer = l
1153 name_mastercomp_aer( l ) = 'sulfate'
1154 dens_mastercomp_aer( l ) = dens_so4_aer
1155 mw_mastercomp_aer( l ) = mw_so4_aer
1156 hygro_mastercomp_aer(l ) = hygro_so4_aer
1157
1158 l = 2
1159 mastercompindx_no3_aer = l
1160 name_mastercomp_aer( l ) = 'nitrate'
1161 dens_mastercomp_aer( l ) = dens_no3_aer
1162 mw_mastercomp_aer( l ) = mw_no3_aer
1163 hygro_mastercomp_aer(l ) = hygro_no3_aer
1164
1165 l = 3
1166 mastercompindx_cl_aer = l
1167 name_mastercomp_aer( l ) = 'chloride'
1168 dens_mastercomp_aer( l ) = dens_cl_aer
1169 mw_mastercomp_aer( l ) = mw_cl_aer
1170 hygro_mastercomp_aer(l ) = hygro_cl_aer
1171
1172 l = 4
1173 mastercompindx_msa_aer = l
1174 name_mastercomp_aer( l ) = 'msa'
1175 dens_mastercomp_aer( l ) = dens_msa_aer
1176 mw_mastercomp_aer( l ) = mw_msa_aer
1177 hygro_mastercomp_aer(l ) = hygro_msa_aer
1178
1179 l = 5
1180 mastercompindx_co3_aer = l
1181 name_mastercomp_aer( l ) = 'carbonate'
1182 dens_mastercomp_aer( l ) = dens_co3_aer
1183 mw_mastercomp_aer( l ) = mw_co3_aer
1184 hygro_mastercomp_aer(l ) = hygro_co3_aer
1185
1186 l = 6
1187 mastercompindx_nh4_aer = l
1188 name_mastercomp_aer( l ) = 'ammonium'
1189 dens_mastercomp_aer( l ) = dens_nh4_aer
1190 mw_mastercomp_aer( l ) = mw_nh4_aer
1191 hygro_mastercomp_aer(l ) = hygro_nh4_aer
1192
1193 l = 7
1194 mastercompindx_na_aer = l
1195 name_mastercomp_aer( l ) = 'sodium'
1196 dens_mastercomp_aer( l ) = dens_na_aer
1197 mw_mastercomp_aer( l ) = mw_na_aer
1198 hygro_mastercomp_aer(l ) = hygro_na_aer
1199
1200 l = 8
1201 mastercompindx_ca_aer = l
1202 name_mastercomp_aer( l ) = 'calcium'
1203 dens_mastercomp_aer( l ) = dens_ca_aer
1204 mw_mastercomp_aer( l ) = mw_ca_aer
1205 hygro_mastercomp_aer(l ) = hygro_ca_aer
1206
1207 l = 9
1208 mastercompindx_oin_aer = l
1209 name_mastercomp_aer( l ) = 'otherinorg'
1210 dens_mastercomp_aer( l ) = dens_oin_aer
1211 mw_mastercomp_aer( l ) = mw_oin_aer
1212 hygro_mastercomp_aer(l ) = hygro_oin_aer
1213
1214 l = 10
1215 mastercompindx_oc_aer = l
1216 name_mastercomp_aer( l ) = 'organic-c'
1217 dens_mastercomp_aer( l ) = dens_oc_aer
1218 mw_mastercomp_aer( l ) = mw_oc_aer
1219 hygro_mastercomp_aer(l ) = hygro_oc_aer
1220
1221 l = 11
1222 mastercompindx_bc_aer = l
1223 name_mastercomp_aer( l ) = 'black-c'
1224 dens_mastercomp_aer( l ) = dens_bc_aer
1225 mw_mastercomp_aer( l ) = mw_bc_aer
1226 hygro_mastercomp_aer(l ) = hygro_bc_aer
1227
1228
1229 !
1230 ! set section size arrays
1231 !
1232 do itype = 1, ntype_aer
1233 nhi = nsize_aer(itype)
1234 dlo_sect(1,itype) = 3.90625e-6
1235 dhi_sect(nhi,itype) = 10.0e-4
1236
1237 dum = alog( dhi_sect(nhi,itype)/dlo_sect(1,itype) ) / nhi
1238 do n = 2, nhi
1239 dlo_sect(n,itype) = dlo_sect(1,itype) * exp( (n-1)*dum )
1240 dhi_sect(n-1,itype) = dlo_sect(n,itype)
1241 end do
1242 do n = 1, nhi
1243 dcen_sect(n,itype) = sqrt( dlo_sect(n,itype)*dhi_sect(n,itype) )
1244 volumlo_sect(n,itype) = (pi/6.) * (dlo_sect(n,itype)**3)
1245 volumhi_sect(n,itype) = (pi/6.) * (dhi_sect(n,itype)**3)
1246 volumcen_sect(n,itype) = (pi/6.) * (dcen_sect(n,itype)**3)
1247 sigmag_aer(n,itype) = (dhi_sect(n,itype)/dlo_sect(n,itype))**0.289
1248 end do
1249 end do
1250
1251 !
1252 ! set pointers to wrf chem-array species
1253 !
1254 call init_data_mosaic_ptr( is_aerosol )
1255
1256 !
1257 ! csuesat initialization
1258 !
1259 call init_csuesat
1260
1261 !
1262 ! move_sect initialization (and testing)
1263 !
1264 ! subr move_sections( iflag, iclm, jclm, k, m )
1265 call move_sections( -1, 1, 1, 1, 1 )
1266
1267 call test_move_sections( 1, 1, 1, 1, 1 )
1268
1269
1270 end subroutine init_data_mosaic_asect
1271
1272
1273 !-----------------------------------------------------------------------
1274 subroutine init_data_mosaic_ptr( is_aerosol )
1275
1276 use module_configure
1277 use module_state_description, only: param_first_scalar,num_chem
1278 use module_data_mosaic_asect
1279 use module_data_mosaic_other, only: &
1280 kh2so4, khno3, khcl, knh3, ko3, kh2o, ktemp, &
1281 kso2, kh2o2, khcho, khcooh, koh, kho2, &
1282 kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh, &
1283 lmaxd, l2maxd, ltot, ltot2, lunout, lunerr, name
1284 use module_peg_util, only: peg_error_fatal, peg_message
1285 use module_mosaic_wetscav, only: initwet
1286
1287 implicit none
1288
1289 ! subr arguments
1290 logical, intent(out) :: is_aerosol(num_chem)
1291 ! local variables
1292 integer l, ll, n, p1st
1293 integer iaddto_ncomp, iaddto_ncomp_plustracer
1294 integer l_mastercomp, lptr_dum
1295 integer mcindx_dum
1296 integer isize, itype, iphase
1297 integer nphasetxt, nsizetxt, nspectxt, ntypetxt
1298 integer ncomp_dum(maxd_asize,maxd_aphase)
1299 integer ncomp_plustracer_dum(maxd_asize,maxd_aphase)
1300
1301 integer y_so4, y_no3, y_cl, y_msa, y_co3, y_nh4, y_na, &
1302 y_ca, y_oin, y_oc, y_bc, y_hysw, y_water, y_num
1303 integer y_cw_so4, y_cw_no3, y_cw_cl, y_cw_msa, y_cw_co3, &
1304 y_cw_nh4, y_cw_na, &
1305 y_cw_ca, y_cw_oin, y_cw_oc, y_cw_bc, y_cw_num
1306
1307 character*200 msg
1308 character*8 phasetxt, sizetxt, spectxt, typetxt
1309
1310
1311 p1st = param_first_scalar
1312 !
1313 ! set up pointers to aerosol species in the wrf-chem "chem" array
1314 ! note: lptr=1 points to the first chem species which is "unused"
1315 !
1316 itype=1
1317 lptr_so4_aer(:,itype,:) = 1
1318 lptr_no3_aer(:,itype,:) = 1
1319 lptr_cl_aer(:,itype,:) = 1
1320 lptr_msa_aer(:,itype,:) = 1
1321 lptr_co3_aer(:,itype,:) = 1
1322 lptr_nh4_aer(:,itype,:) = 1
1323 lptr_na_aer(:,itype,:) = 1
1324 lptr_ca_aer(:,itype,:) = 1
1325 lptr_oin_aer(:,itype,:) = 1
1326 lptr_oc_aer(:,itype,:) = 1
1327 lptr_bc_aer(:,itype,:) = 1
1328 hyswptr_aer(:,itype) = 1
1329 waterptr_aer(:,itype) = 1
1330 numptr_aer(:,itype,:) = 1
1331
1332
1333 if (nsize_aer(itype) .ge. 1) then
1334 lptr_so4_aer(01,itype,ai_phase) = p_so4_a01
1335 lptr_no3_aer(01,itype,ai_phase) = p_no3_a01
1336 lptr_cl_aer(01,itype,ai_phase) = p_cl_a01
1337 lptr_msa_aer(01,itype,ai_phase) = p_msa_a01
1338 lptr_co3_aer(01,itype,ai_phase) = p_co3_a01
1339 lptr_nh4_aer(01,itype,ai_phase) = p_nh4_a01
1340 lptr_na_aer(01,itype,ai_phase) = p_na_a01
1341 lptr_ca_aer(01,itype,ai_phase) = p_ca_a01
1342 lptr_oin_aer(01,itype,ai_phase) = p_oin_a01
1343 lptr_oc_aer(01,itype,ai_phase) = p_oc_a01
1344 lptr_bc_aer(01,itype,ai_phase) = p_bc_a01
1345 hyswptr_aer(01,itype) = p_hysw_a01
1346 waterptr_aer(01,itype) = p_water_a01
1347 numptr_aer(01,itype,ai_phase) = p_num_a01
1348 end if
1349
1350 if (nsize_aer(itype) .ge. 2) then
1351 lptr_so4_aer(02,itype,ai_phase) = p_so4_a02
1352 lptr_no3_aer(02,itype,ai_phase) = p_no3_a02
1353 lptr_cl_aer(02,itype,ai_phase) = p_cl_a02
1354 lptr_msa_aer(02,itype,ai_phase) = p_msa_a02
1355 lptr_co3_aer(02,itype,ai_phase) = p_co3_a02
1356 lptr_nh4_aer(02,itype,ai_phase) = p_nh4_a02
1357 lptr_na_aer(02,itype,ai_phase) = p_na_a02
1358 lptr_ca_aer(02,itype,ai_phase) = p_ca_a02
1359 lptr_oin_aer(02,itype,ai_phase) = p_oin_a02
1360 lptr_oc_aer(02,itype,ai_phase) = p_oc_a02
1361 lptr_bc_aer(02,itype,ai_phase) = p_bc_a02
1362 hyswptr_aer(02,itype) = p_hysw_a02
1363 waterptr_aer(02,itype) = p_water_a02
1364 numptr_aer(02,itype,ai_phase) = p_num_a02
1365 end if
1366
1367 if (nsize_aer(itype) .ge. 3) then
1368 lptr_so4_aer(03,itype,ai_phase) = p_so4_a03
1369 lptr_no3_aer(03,itype,ai_phase) = p_no3_a03
1370 lptr_cl_aer(03,itype,ai_phase) = p_cl_a03
1371 lptr_msa_aer(03,itype,ai_phase) = p_msa_a03
1372 lptr_co3_aer(03,itype,ai_phase) = p_co3_a03
1373 lptr_nh4_aer(03,itype,ai_phase) = p_nh4_a03
1374 lptr_na_aer(03,itype,ai_phase) = p_na_a03
1375 lptr_ca_aer(03,itype,ai_phase) = p_ca_a03
1376 lptr_oin_aer(03,itype,ai_phase) = p_oin_a03
1377 lptr_oc_aer(03,itype,ai_phase) = p_oc_a03
1378 lptr_bc_aer(03,itype,ai_phase) = p_bc_a03
1379 hyswptr_aer(03,itype) = p_hysw_a03
1380 waterptr_aer(03,itype) = p_water_a03
1381 numptr_aer(03,itype,ai_phase) = p_num_a03
1382 end if
1383
1384 if (nsize_aer(itype) .ge. 4) then
1385 lptr_so4_aer(04,itype,ai_phase) = p_so4_a04
1386 lptr_no3_aer(04,itype,ai_phase) = p_no3_a04
1387 lptr_cl_aer(04,itype,ai_phase) = p_cl_a04
1388 lptr_msa_aer(04,itype,ai_phase) = p_msa_a04
1389 lptr_co3_aer(04,itype,ai_phase) = p_co3_a04
1390 lptr_nh4_aer(04,itype,ai_phase) = p_nh4_a04
1391 lptr_na_aer(04,itype,ai_phase) = p_na_a04
1392 lptr_ca_aer(04,itype,ai_phase) = p_ca_a04
1393 lptr_oin_aer(04,itype,ai_phase) = p_oin_a04
1394 lptr_oc_aer(04,itype,ai_phase) = p_oc_a04
1395 lptr_bc_aer(04,itype,ai_phase) = p_bc_a04
1396 hyswptr_aer(04,itype) = p_hysw_a04
1397 waterptr_aer(04,itype) = p_water_a04
1398 numptr_aer(04,itype,ai_phase) = p_num_a04
1399 end if
1400
1401 if (nsize_aer(itype) .ge. 5) then
1402 lptr_so4_aer(05,itype,ai_phase) = p_so4_a05
1403 lptr_no3_aer(05,itype,ai_phase) = p_no3_a05
1404 lptr_cl_aer(05,itype,ai_phase) = p_cl_a05
1405 lptr_msa_aer(05,itype,ai_phase) = p_msa_a05
1406 lptr_co3_aer(05,itype,ai_phase) = p_co3_a05
1407 lptr_nh4_aer(05,itype,ai_phase) = p_nh4_a05
1408 lptr_na_aer(05,itype,ai_phase) = p_na_a05
1409 lptr_ca_aer(05,itype,ai_phase) = p_ca_a05
1410 lptr_oin_aer(05,itype,ai_phase) = p_oin_a05
1411 lptr_oc_aer(05,itype,ai_phase) = p_oc_a05
1412 lptr_bc_aer(05,itype,ai_phase) = p_bc_a05
1413 hyswptr_aer(05,itype) = p_hysw_a05
1414 waterptr_aer(05,itype) = p_water_a05
1415 numptr_aer(05,itype,ai_phase) = p_num_a05
1416 end if
1417
1418 if (nsize_aer(itype) .ge. 6) then
1419 lptr_so4_aer(06,itype,ai_phase) = p_so4_a06
1420 lptr_no3_aer(06,itype,ai_phase) = p_no3_a06
1421 lptr_cl_aer(06,itype,ai_phase) = p_cl_a06
1422 lptr_msa_aer(06,itype,ai_phase) = p_msa_a06
1423 lptr_co3_aer(06,itype,ai_phase) = p_co3_a06
1424 lptr_nh4_aer(06,itype,ai_phase) = p_nh4_a06
1425 lptr_na_aer(06,itype,ai_phase) = p_na_a06
1426 lptr_ca_aer(06,itype,ai_phase) = p_ca_a06
1427 lptr_oin_aer(06,itype,ai_phase) = p_oin_a06
1428 lptr_oc_aer(06,itype,ai_phase) = p_oc_a06
1429 lptr_bc_aer(06,itype,ai_phase) = p_bc_a06
1430 hyswptr_aer(06,itype) = p_hysw_a06
1431 waterptr_aer(06,itype) = p_water_a06
1432 numptr_aer(06,itype,ai_phase) = p_num_a06
1433 end if
1434
1435 if (nsize_aer(itype) .ge. 7) then
1436 lptr_so4_aer(07,itype,ai_phase) = p_so4_a07
1437 lptr_no3_aer(07,itype,ai_phase) = p_no3_a07
1438 lptr_cl_aer(07,itype,ai_phase) = p_cl_a07
1439 lptr_msa_aer(07,itype,ai_phase) = p_msa_a07
1440 lptr_co3_aer(07,itype,ai_phase) = p_co3_a07
1441 lptr_nh4_aer(07,itype,ai_phase) = p_nh4_a07
1442 lptr_na_aer(07,itype,ai_phase) = p_na_a07
1443 lptr_ca_aer(07,itype,ai_phase) = p_ca_a07
1444 lptr_oin_aer(07,itype,ai_phase) = p_oin_a07
1445 lptr_oc_aer(07,itype,ai_phase) = p_oc_a07
1446 lptr_bc_aer(07,itype,ai_phase) = p_bc_a07
1447 hyswptr_aer(07,itype) = p_hysw_a07
1448 waterptr_aer(07,itype) = p_water_a07
1449 numptr_aer(07,itype,ai_phase) = p_num_a07
1450 end if
1451
1452 if (nsize_aer(itype) .ge. 8) then
1453 lptr_so4_aer(08,itype,ai_phase) = p_so4_a08
1454 lptr_no3_aer(08,itype,ai_phase) = p_no3_a08
1455 lptr_cl_aer(08,itype,ai_phase) = p_cl_a08
1456 lptr_msa_aer(08,itype,ai_phase) = p_msa_a08
1457 lptr_co3_aer(08,itype,ai_phase) = p_co3_a08
1458 lptr_nh4_aer(08,itype,ai_phase) = p_nh4_a08
1459 lptr_na_aer(08,itype,ai_phase) = p_na_a08
1460 lptr_ca_aer(08,itype,ai_phase) = p_ca_a08
1461 lptr_oin_aer(08,itype,ai_phase) = p_oin_a08
1462 lptr_oc_aer(08,itype,ai_phase) = p_oc_a08
1463 lptr_bc_aer(08,itype,ai_phase) = p_bc_a08
1464 hyswptr_aer(08,itype) = p_hysw_a08
1465 waterptr_aer(08,itype) = p_water_a08
1466 numptr_aer(08,itype,ai_phase) = p_num_a08
1467 end if
1468
1469
1470 #if defined ( cw_species_are_in_registry )
1471 ! this code is "active" only when cw species are in the registry
1472 if (nsize_aer(itype) .ge. 1) then
1473 if (cw_phase .gt. 0) then
1474 lptr_so4_aer(01,itype,cw_phase) = p_so4_cw01
1475 lptr_no3_aer(01,itype,cw_phase) = p_no3_cw01
1476 lptr_cl_aer(01,itype,cw_phase) = p_cl_cw01
1477 lptr_msa_aer(01,itype,cw_phase) = p_msa_cw01
1478 lptr_co3_aer(01,itype,cw_phase) = p_co3_cw01
1479 lptr_nh4_aer(01,itype,cw_phase) = p_nh4_cw01
1480 lptr_na_aer(01,itype,cw_phase) = p_na_cw01
1481 lptr_ca_aer(01,itype,cw_phase) = p_ca_cw01
1482 lptr_oin_aer(01,itype,cw_phase) = p_oin_cw01
1483 lptr_oc_aer(01,itype,cw_phase) = p_oc_cw01
1484 lptr_bc_aer(01,itype,cw_phase) = p_bc_cw01
1485 numptr_aer(01,itype,cw_phase) = p_num_cw01
1486 end if
1487 end if
1488
1489 if (nsize_aer(itype) .ge. 2) then
1490 if (cw_phase .gt. 0) then
1491 lptr_so4_aer(02,itype,cw_phase) = p_so4_cw02
1492 lptr_no3_aer(02,itype,cw_phase) = p_no3_cw02
1493 lptr_cl_aer(02,itype,cw_phase) = p_cl_cw02
1494 lptr_msa_aer(02,itype,cw_phase) = p_msa_cw02
1495 lptr_co3_aer(02,itype,cw_phase) = p_co3_cw02
1496 lptr_nh4_aer(02,itype,cw_phase) = p_nh4_cw02
1497 lptr_na_aer(02,itype,cw_phase) = p_na_cw02
1498 lptr_ca_aer(02,itype,cw_phase) = p_ca_cw02
1499 lptr_oin_aer(02,itype,cw_phase) = p_oin_cw02
1500 lptr_oc_aer(02,itype,cw_phase) = p_oc_cw02
1501 lptr_bc_aer(02,itype,cw_phase) = p_bc_cw02
1502 numptr_aer(02,itype,cw_phase) = p_num_cw02
1503 end if
1504 end if
1505
1506 if (nsize_aer(itype) .ge. 3) then
1507 if (cw_phase .gt. 0) then
1508 lptr_so4_aer(03,itype,cw_phase) = p_so4_cw03
1509 lptr_no3_aer(03,itype,cw_phase) = p_no3_cw03
1510 lptr_cl_aer(03,itype,cw_phase) = p_cl_cw03
1511 lptr_msa_aer(03,itype,cw_phase) = p_msa_cw03
1512 lptr_co3_aer(03,itype,cw_phase) = p_co3_cw03
1513 lptr_nh4_aer(03,itype,cw_phase) = p_nh4_cw03
1514 lptr_na_aer(03,itype,cw_phase) = p_na_cw03
1515 lptr_ca_aer(03,itype,cw_phase) = p_ca_cw03
1516 lptr_oin_aer(03,itype,cw_phase) = p_oin_cw03
1517 lptr_oc_aer(03,itype,cw_phase) = p_oc_cw03
1518 lptr_bc_aer(03,itype,cw_phase) = p_bc_cw03
1519 numptr_aer(03,itype,cw_phase) = p_num_cw03
1520 end if
1521 end if
1522
1523 if (nsize_aer(itype) .ge. 4) then
1524 if (cw_phase .gt. 0) then
1525 lptr_so4_aer(04,itype,cw_phase) = p_so4_cw04
1526 lptr_no3_aer(04,itype,cw_phase) = p_no3_cw04
1527 lptr_cl_aer(04,itype,cw_phase) = p_cl_cw04
1528 lptr_msa_aer(04,itype,cw_phase) = p_msa_cw04
1529 lptr_co3_aer(04,itype,cw_phase) = p_co3_cw04
1530 lptr_nh4_aer(04,itype,cw_phase) = p_nh4_cw04
1531 lptr_na_aer(04,itype,cw_phase) = p_na_cw04
1532 lptr_ca_aer(04,itype,cw_phase) = p_ca_cw04
1533 lptr_oin_aer(04,itype,cw_phase) = p_oin_cw04
1534 lptr_oc_aer(04,itype,cw_phase) = p_oc_cw04
1535 lptr_bc_aer(04,itype,cw_phase) = p_bc_cw04
1536 numptr_aer(04,itype,cw_phase) = p_num_cw04
1537 end if
1538 end if
1539
1540 if (nsize_aer(itype) .ge. 5) then
1541 if (cw_phase .gt. 0) then
1542 lptr_so4_aer(05,itype,cw_phase) = p_so4_cw05
1543 lptr_no3_aer(05,itype,cw_phase) = p_no3_cw05
1544 lptr_cl_aer(05,itype,cw_phase) = p_cl_cw05
1545 lptr_msa_aer(05,itype,cw_phase) = p_msa_cw05
1546 lptr_co3_aer(05,itype,cw_phase) = p_co3_cw05
1547 lptr_nh4_aer(05,itype,cw_phase) = p_nh4_cw05
1548 lptr_na_aer(05,itype,cw_phase) = p_na_cw05
1549 lptr_ca_aer(05,itype,cw_phase) = p_ca_cw05
1550 lptr_oin_aer(05,itype,cw_phase) = p_oin_cw05
1551 lptr_oc_aer(05,itype,cw_phase) = p_oc_cw05
1552 lptr_bc_aer(05,itype,cw_phase) = p_bc_cw05
1553 numptr_aer(05,itype,cw_phase) = p_num_cw05
1554 end if
1555 end if
1556
1557 if (nsize_aer(itype) .ge. 6) then
1558 if (cw_phase .gt. 0) then
1559 lptr_so4_aer(06,itype,cw_phase) = p_so4_cw06
1560 lptr_no3_aer(06,itype,cw_phase) = p_no3_cw06
1561 lptr_cl_aer(06,itype,cw_phase) = p_cl_cw06
1562 lptr_msa_aer(06,itype,cw_phase) = p_msa_cw06
1563 lptr_co3_aer(06,itype,cw_phase) = p_co3_cw06
1564 lptr_nh4_aer(06,itype,cw_phase) = p_nh4_cw06
1565 lptr_na_aer(06,itype,cw_phase) = p_na_cw06
1566 lptr_ca_aer(06,itype,cw_phase) = p_ca_cw06
1567 lptr_oin_aer(06,itype,cw_phase) = p_oin_cw06
1568 lptr_oc_aer(06,itype,cw_phase) = p_oc_cw06
1569 lptr_bc_aer(06,itype,cw_phase) = p_bc_cw06
1570 numptr_aer(06,itype,cw_phase) = p_num_cw06
1571 end if
1572 end if
1573
1574 if (nsize_aer(itype) .ge. 7) then
1575 if (cw_phase .gt. 0) then
1576 lptr_so4_aer(07,itype,cw_phase) = p_so4_cw07
1577 lptr_no3_aer(07,itype,cw_phase) = p_no3_cw07
1578 lptr_cl_aer(07,itype,cw_phase) = p_cl_cw07
1579 lptr_msa_aer(07,itype,cw_phase) = p_msa_cw07
1580 lptr_co3_aer(07,itype,cw_phase) = p_co3_cw07
1581 lptr_nh4_aer(07,itype,cw_phase) = p_nh4_cw07
1582 lptr_na_aer(07,itype,cw_phase) = p_na_cw07
1583 lptr_ca_aer(07,itype,cw_phase) = p_ca_cw07
1584 lptr_oin_aer(07,itype,cw_phase) = p_oin_cw07
1585 lptr_oc_aer(07,itype,cw_phase) = p_oc_cw07
1586 lptr_bc_aer(07,itype,cw_phase) = p_bc_cw07
1587 numptr_aer(07,itype,cw_phase) = p_num_cw07
1588 end if
1589 end if
1590
1591 if (nsize_aer(itype) .ge. 8) then
1592 if (cw_phase .gt. 0) then
1593 lptr_so4_aer(08,itype,cw_phase) = p_so4_cw08
1594 lptr_no3_aer(08,itype,cw_phase) = p_no3_cw08
1595 lptr_cl_aer(08,itype,cw_phase) = p_cl_cw08
1596 lptr_msa_aer(08,itype,cw_phase) = p_msa_cw08
1597 lptr_co3_aer(08,itype,cw_phase) = p_co3_cw08
1598 lptr_nh4_aer(08,itype,cw_phase) = p_nh4_cw08
1599 lptr_na_aer(08,itype,cw_phase) = p_na_cw08
1600 lptr_ca_aer(08,itype,cw_phase) = p_ca_cw08
1601 lptr_oin_aer(08,itype,cw_phase) = p_oin_cw08
1602 lptr_oc_aer(08,itype,cw_phase) = p_oc_cw08
1603 lptr_bc_aer(08,itype,cw_phase) = p_bc_cw08
1604 numptr_aer(08,itype,cw_phase) = p_num_cw08
1605 end if
1606 end if
1607 #endif
1608
1609
1610 !
1611 ! define the massptr_aer and mastercompptr_aer pointers
1612 ! and the name() species names
1613 !
1614
1615 ! first initialize
1616 do l = 1, l2maxd
1617 write( name(l), '(a,i4.4,15x)' ) 'r', l
1618 end do
1619 massptr_aer(:,:,:,:) = -999888777
1620 mastercompptr_aer(:,:) = -999888777
1621
1622 do 2800 itype = 1, ntype_aer
1623
1624 if (itype .eq. 1) then
1625 typetxt = ' '
1626 ntypetxt = 1
1627 if (ntype_aer .gt. 1) then
1628 typetxt = '_t1'
1629 ntypetxt = 3
1630 end if
1631 else if (itype .le. 9) then
1632 write(typetxt,'(a,i1)') '_t', itype
1633 ntypetxt = 3
1634 else if (itype .le. 99) then
1635 write(typetxt,'(a,i2)') '_t', itype
1636 ntypetxt = 4
1637 else
1638 typetxt = '_t?'
1639 ntypetxt = 3
1640 end if
1641
1642 ncomp_dum(:,:) = 0
1643 ncomp_plustracer_dum(:,:) = 0
1644
1645 do 2700 isize = 1, nsize_aer(itype)
1646 n =isize
1647
1648 if (isize .le. 9) then
1649 write(sizetxt,'(i1)') isize
1650 nsizetxt = 1
1651 else if (isize .le. 99) then
1652 write(sizetxt,'(i2)') isize
1653 nsizetxt = 2
1654 else if (isize .le. 999) then
1655 write(sizetxt,'(i3)') isize
1656 nsizetxt = 3
1657 else
1658 sizetxt = 's?'
1659 nsizetxt = 2
1660 end if
1661
1662
1663 do 2600 iphase = 1, nphase_aer
1664
1665 if (iphase .eq. ai_phase) then
1666 phasetxt = 'a'
1667 nphasetxt = 1
1668 else if (iphase .eq. cw_phase) then
1669 phasetxt = 'cw'
1670 nphasetxt = 2
1671 else
1672 phasetxt = 'p?'
1673 nphasetxt = 2
1674 end if
1675
1676
1677 do 2500 l_mastercomp = -2, ntot_mastercomp_aer
1678
1679 iaddto_ncomp = 1
1680 iaddto_ncomp_plustracer = 1
1681
1682 if (l_mastercomp .eq. -2) then
1683 iaddto_ncomp = 0
1684 iaddto_ncomp_plustracer = 0
1685 lptr_dum = numptr_aer(n,itype,iphase)
1686 mcindx_dum = -2
1687 spectxt = 'numb_'
1688 nspectxt = 5
1689
1690 else if (l_mastercomp .eq. -1) then
1691 if (iphase .ne. ai_phase) goto 2500
1692 iaddto_ncomp = 0
1693 iaddto_ncomp_plustracer = 0
1694 lptr_dum = waterptr_aer(n,itype)
1695 mcindx_dum = -1
1696 spectxt = 'water_'
1697 nspectxt = 6
1698
1699 else if (l_mastercomp .eq. 0) then
1700 if (iphase .ne. ai_phase) goto 2500
1701 iaddto_ncomp = 0
1702 iaddto_ncomp_plustracer = 0
1703 lptr_dum = hyswptr_aer(n,itype)
1704 mcindx_dum = 0
1705 spectxt = 'hysw_'
1706 nspectxt = 5
1707
1708 else if (l_mastercomp .eq. mastercompindx_so4_aer) then
1709 lptr_dum = lptr_so4_aer(n,itype,iphase)
1710 mcindx_dum = mastercompindx_so4_aer
1711 spectxt = 'so4_'
1712 nspectxt = 4
1713
1714 else if (l_mastercomp .eq. mastercompindx_no3_aer) then
1715 lptr_dum = lptr_no3_aer(n,itype,iphase)
1716 mcindx_dum = mastercompindx_no3_aer
1717 spectxt = 'no3_'
1718 nspectxt = 4
1719
1720 else if (l_mastercomp .eq. mastercompindx_cl_aer) then
1721 lptr_dum = lptr_cl_aer(n,itype,iphase)
1722 mcindx_dum = mastercompindx_cl_aer
1723 spectxt = 'cl_'
1724 nspectxt = 3
1725
1726 else if (l_mastercomp .eq. mastercompindx_msa_aer) then
1727 lptr_dum = lptr_msa_aer(n,itype,iphase)
1728 mcindx_dum = mastercompindx_msa_aer
1729 spectxt = 'msa_'
1730 nspectxt = 4
1731
1732 else if (l_mastercomp .eq. mastercompindx_co3_aer) then
1733 lptr_dum = lptr_co3_aer(n,itype,iphase)
1734 mcindx_dum = mastercompindx_co3_aer
1735 spectxt = 'co3_'
1736 nspectxt = 4
1737
1738 else if (l_mastercomp .eq. mastercompindx_nh4_aer) then
1739 lptr_dum = lptr_nh4_aer(n,itype,iphase)
1740 mcindx_dum = mastercompindx_nh4_aer
1741 spectxt = 'nh4_'
1742 nspectxt = 4
1743
1744 else if (l_mastercomp .eq. mastercompindx_na_aer) then
1745 lptr_dum = lptr_na_aer(n,itype,iphase)
1746 mcindx_dum = mastercompindx_na_aer
1747 spectxt = 'na_'
1748 nspectxt = 3
1749
1750 else if (l_mastercomp .eq. mastercompindx_ca_aer) then
1751 lptr_dum = lptr_ca_aer(n,itype,iphase)
1752 mcindx_dum = mastercompindx_ca_aer
1753 spectxt = 'ca_'
1754 nspectxt = 3
1755
1756 else if (l_mastercomp .eq. mastercompindx_oin_aer) then
1757 lptr_dum = lptr_oin_aer(n,itype,iphase)
1758 mcindx_dum = mastercompindx_oin_aer
1759 spectxt = 'oin_'
1760 nspectxt = 4
1761
1762 else if (l_mastercomp .eq. mastercompindx_oc_aer) then
1763 lptr_dum = lptr_oc_aer(n,itype,iphase)
1764 mcindx_dum = mastercompindx_oc_aer
1765 spectxt = 'oc_'
1766 nspectxt = 3
1767
1768 else if (l_mastercomp .eq. mastercompindx_bc_aer) then
1769 lptr_dum = lptr_bc_aer(n,itype,iphase)
1770 mcindx_dum = mastercompindx_bc_aer
1771 spectxt = 'bc_'
1772 nspectxt = 3
1773
1774 else
1775 goto 2500
1776 end if
1777
1778
1779 if (lptr_dum .gt. lmaxd) then
1780 ! rce 2005-mar-14 - added check for lptr_dum > lmaxd
1781 write( msg, '(a,3(1x,i4))' ) 'itype, isize, iphase =', &
1782 itype, isize, iphase
1783 call peg_message( lunout, msg )
1784 write( msg, '(a,3(1x,i4))' ) 'l_mastercomp, lptr_dum, lmaxd =', &
1785 l_mastercomp, lptr_dum, lmaxd
1786 call peg_message( lunout, msg )
1787 msg = '*** subr init_data_mosaic_ptr error - lptr_dum > lmaxd'
1788 call peg_error_fatal( lunerr, msg )
1789
1790 else if (lptr_dum .ge. p1st) then
1791
1792 ncomp_dum(isize,iphase) = ncomp_dum(isize,iphase) + iaddto_ncomp
1793 ncomp_plustracer_dum(isize,iphase) = &
1794 ncomp_plustracer_dum(isize,iphase) + iaddto_ncomp_plustracer
1795
1796 name(lptr_dum) = &
1797 spectxt(1:nspectxt) // phasetxt(1:nphasetxt) // &
1798 sizetxt(1:nsizetxt) // typetxt(1:ntypetxt)
1799
1800 if (l_mastercomp .eq. -2) then
1801 ! (numptr_aer is already set)
1802 mprognum_aer(n,itype,iphase) = 1
1803
1804 else if (l_mastercomp .eq. -1) then
1805 ! (waterptr_aer is already set)
1806 continue
1807
1808 else if (l_mastercomp .eq. 0) then
1809 ! (hyswptr_aer is already set)
1810 continue
1811
1812 else if (l_mastercomp .gt. 0) then
1813 ll = ncomp_plustracer_dum(isize,iphase)
1814 massptr_aer(ll,n,itype,iphase) = lptr_dum
1815 mastercompptr_aer(ll,itype) = mcindx_dum
1816
1817 name_aer(ll,itype) = name_mastercomp_aer(mcindx_dum)
1818 dens_aer(ll,itype) = dens_mastercomp_aer(mcindx_dum)
1819 mw_aer(ll,itype) = mw_mastercomp_aer(mcindx_dum)
1820 hygro_aer(ll,itype) = hygro_mastercomp_aer(mcindx_dum)
1821
1822 end if
1823
1824 end if
1825
1826 2500 continue ! l_mastercomp = -1, ntot_mastercomp_aer
1827
1828 2600 continue ! iphase = 1, nphase_aer
1829
1830 2700 continue ! isize = 1, nsize_aer(itype)
1831
1832
1833 ! now set ncomp_aer and ncomp_plustracer_aer,
1834 ! *** and check that the values computed for each size and phase all match
1835 ncomp_aer(itype) = ncomp_dum(1,ai_phase)
1836 ncomp_plustracer_aer(itype) = ncomp_plustracer_dum(1,ai_phase)
1837
1838 do iphase = 1, nphase_aer
1839 do isize = 1, nsize_aer(itype)
1840 if (ncomp_aer(itype) .ne. ncomp_dum(isize,iphase)) then
1841 msg = '*** subr init_data_mosaic_ptr - ' // &
1842 'ncomp_aer .ne. ncomp_dum'
1843 call peg_message( lunerr, msg )
1844 write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase
1845 call peg_message( lunerr, msg )
1846 write(msg,9350) 'ncomp_aer, ncomp_dum =', &
1847 ncomp_aer(itype), ncomp_dum(isize,iphase)
1848 call peg_error_fatal( lunerr, msg )
1849 end if
1850 if (ncomp_plustracer_aer(itype) .ne. &
1851 ncomp_plustracer_dum(isize,iphase)) then
1852 msg = '*** subr init_data_mosaic_ptr - ' // &
1853 'ncomp_plustracer_aer .ne. ncomp_plustracer_dum'
1854 call peg_message( lunerr, msg )
1855 write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase
1856 call peg_message( lunerr, msg )
1857 write(msg,9350) &
1858 'ncomp_plustracer_aer, ncomp_plustracer_dum =', &
1859 ncomp_plustracer_aer(itype), &
1860 ncomp_plustracer_dum(isize,iphase)
1861 call peg_error_fatal( lunerr, msg )
1862 end if
1863 end do
1864 end do
1865
1866
1867 2800 continue ! itype = 1, ntype_aer
1868
1869
1870 9320 format( a, i1, i1, a, 8x )
1871
1872 !
1873 ! output wrfch pointers
1874 !
1875 9350 format( a, 32(1x,i4) )
1876 msg = ' '
1877 call peg_message( lunout, msg )
1878 msg = 'output from subr init_data_mosaic_ptr'
1879 call peg_message( lunout, msg )
1880 write(msg,9350) 'nphase_aer = ', nphase_aer
1881 call peg_message( lunout, msg )
1882
1883 do iphase=1,nphase_aer
1884
1885 write(msg,9350) 'iphase = ', iphase
1886 call peg_message( lunout, msg )
1887 write(msg,9350) 'ntype_aer = ', ntype_aer
1888 call peg_message( lunout, msg )
1889
1890 do itype=1,ntype_aer
1891
1892 write(msg,9350) 'itype = ', itype
1893 call peg_message( lunout, msg )
1894 write(msg,9350) 'nsize_aer = ', nsize_aer(itype)
1895 call peg_message( lunout, msg )
1896 write(msg,9350) 'lptr_so4_aer ', &
1897 (lptr_so4_aer(n,itype,iphase), n=1,nsize_aer(itype))
1898 call peg_message( lunout, msg )
1899 write(msg,9350) 'lptr_no3_aer ', &
1900 (lptr_no3_aer(n,itype,iphase), n=1,nsize_aer(itype))
1901 call peg_message( lunout, msg )
1902 write(msg,9350) 'lptr_cl_aer ', &
1903 (lptr_cl_aer(n,itype,iphase), n=1,nsize_aer(itype))
1904 call peg_message( lunout, msg )
1905 write(msg,9350) 'lptr_msa_aer ', &
1906 (lptr_msa_aer(n,itype,iphase), n=1,nsize_aer(itype))
1907 call peg_message( lunout, msg )
1908 write(msg,9350) 'lptr_co3_aer ', &
1909 (lptr_co3_aer(n,itype,iphase), n=1,nsize_aer(itype))
1910 call peg_message( lunout, msg )
1911 write(msg,9350) 'lptr_nh4_aer ', &
1912 (lptr_nh4_aer(n,itype,iphase), n=1,nsize_aer(itype))
1913 call peg_message( lunout, msg )
1914 write(msg,9350) 'lptr_na_aer ', &
1915 (lptr_na_aer(n,itype,iphase), n=1,nsize_aer(itype))
1916 call peg_message( lunout, msg )
1917 write(msg,9350) 'lptr_ca_aer ', &
1918 (lptr_ca_aer(n,itype,iphase), n=1,nsize_aer(itype))
1919 call peg_message( lunout, msg )
1920 write(msg,9350) 'lptr_oin_aer ', &
1921 (lptr_oin_aer(n,itype,iphase), n=1,nsize_aer(itype))
1922 call peg_message( lunout, msg )
1923 write(msg,9350) 'lptr_oc_aer ', &
1924 (lptr_oc_aer(n,itype,iphase), n=1,nsize_aer(itype))
1925 call peg_message( lunout, msg )
1926 write(msg,9350) 'lptr_bc_aer ', &
1927 (lptr_bc_aer(n,itype,iphase), n=1,nsize_aer(itype))
1928 call peg_message( lunout, msg )
1929 write(msg,9350) 'hyswptr_aer', &
1930 (hyswptr_aer(n,itype), n=1,nsize_aer(itype))
1931 call peg_message( lunout, msg )
1932 write(msg,9350) 'waterptr_aer ', &
1933 (waterptr_aer(n,itype), n=1,nsize_aer(itype))
1934 call peg_message( lunout, msg )
1935 write(msg,9350) 'numptr_aer ', &
1936 (numptr_aer(n,itype,iphase), n=1,nsize_aer(itype))
1937 call peg_message( lunout, msg )
1938
1939
1940 do ll = 1, ncomp_plustracer_aer(itype)
1941 write(msg,9350) 'massptr_aer(), ll', &
1942 (massptr_aer(ll,n,itype,iphase), n=1,nsize_aer(itype)), ll
1943 call peg_message( lunout, msg )
1944 end do
1945 end do ! type
1946 end do ! phase
1947
1948 !
1949 ! check aerosol species pointers for "validity"
1950 !
1951 do iphase=1,nphase_aer
1952 do itype=1,ntype_aer
1953 y_so4 = 0
1954 y_no3 = 0
1955 y_cl = 0
1956 y_msa = 0
1957 y_co3 = 0
1958 y_nh4 = 0
1959 y_na = 0
1960 y_ca = 0
1961 y_oin = 0
1962 y_oc = 0
1963 y_bc = 0
1964 y_hysw = 0
1965 y_water = 0
1966 y_num = 0
1967
1968 do n = 1, nsize_aer(itype)
1969 if (lptr_so4_aer(n,itype,iphase) .ge. p1st) y_so4 = y_so4 + 1
1970 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) y_no3 = y_no3 + 1
1971 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) y_cl = y_cl + 1
1972 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) y_msa = y_msa + 1
1973 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) y_co3 = y_co3 + 1
1974 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) y_nh4 = y_nh4 + 1
1975 if (lptr_na_aer(n,itype,iphase) .ge. p1st) y_na = y_na + 1
1976 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) y_ca = y_ca + 1
1977 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) y_oin = y_oin + 1
1978 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) y_oc = y_oc + 1
1979 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) y_bc = y_bc + 1
1980 if (hyswptr_aer(n,itype) .ge. p1st) y_hysw = y_hysw + 1
1981 if (waterptr_aer(n,itype) .ge. p1st) y_water = y_water + 1
1982 if (numptr_aer(n,itype,iphase) .ge. p1st) y_num = y_num + 1
1983
1984 end do
1985
1986 ! these must be defined for all aerosol bins
1987 if (y_so4 .ne. nsize_aer(itype)) then
1988 msg = '*** subr init_data_mosaic_ptr - ptr error for so4'
1989 call peg_message( lunerr, msg )
1990 write(msg,9350) 'phase, type=', iphase,itype
1991 call peg_error_fatal( lunerr, msg )
1992 else if (y_water .ne. nsize_aer(itype)) then
1993 msg = '*** subr init_data_mosaic_ptr - ptr error for water'
1994 call peg_message( lunerr, msg )
1995 write(msg,9350) 'phase, type=', iphase,itype
1996 call peg_error_fatal( lunerr, msg )
1997 else if (y_num .ne. nsize_aer(itype)) then
1998 msg = '*** subr init_data_mosaic_ptr - ptr error for num'
1999 call peg_message( lunerr, msg )
2000 write(msg,9350) 'phase, type=', iphase,itype
2001 call peg_error_fatal( lunerr, msg )
2002 end if
2003
2004
2005 ! these must be defined for all aerosol bins
2006 ! or else undefined for all aerosol bins
2007 if ((y_no3 .ne. 0) .and. &
2008 (y_no3 .ne. nsize_aer(itype))) then
2009 msg = '*** subr init_data_mosaic_ptr - ptr error for no3'
2010 call peg_message( lunerr, msg )
2011 write(msg,9350) 'phase, type=', iphase,itype
2012 call peg_error_fatal( lunerr, msg )
2013 else if ((y_cl .ne. 0) .and. &
2014 (y_cl .ne. nsize_aer(itype))) then
2015 msg = '*** subr init_data_mosaic_ptr - ptr error for cl'
2016 call peg_message( lunerr, msg )
2017 write(msg,9350) 'phase, type=', iphase,itype
2018 call peg_error_fatal( lunerr, msg )
2019 else if ((y_msa .ne. 0) .and. &
2020 (y_msa .ne. nsize_aer(itype))) then
2021 msg = '*** subr init_data_mosaic_ptr - ptr error for msa'
2022 call peg_message( lunerr, msg )
2023 write(msg,9350) 'phase, type=', iphase,itype
2024 call peg_error_fatal( lunerr, msg )
2025 else if ((y_co3 .ne. 0) .and. &
2026 (y_co3 .ne. nsize_aer(itype))) then
2027 msg = '*** subr init_data_mosaic_ptr - ptr error for co3'
2028 call peg_message( lunerr, msg )
2029 write(msg,9350) 'phase, type=', iphase,itype
2030 call peg_error_fatal( lunerr, msg )
2031 else if ((y_nh4 .ne. 0) .and. &
2032 (y_nh4 .ne. nsize_aer(itype))) then
2033 msg = '*** subr init_data_mosaic_ptr - ptr error for nh4'
2034 call peg_message( lunerr, msg )
2035 write(msg,9350) 'phase, type=', iphase,itype
2036 call peg_error_fatal( lunerr, msg )
2037 else if ((y_na .ne. 0) .and. &
2038 (y_na .ne. nsize_aer(itype))) then
2039 msg = '*** subr init_data_mosaic_ptr - ptr error for na'
2040 call peg_message( lunerr, msg )
2041 write(msg,9350) 'phase, type=', iphase,itype
2042 call peg_error_fatal( lunerr, msg )
2043 else if ((y_ca .ne. 0) .and. &
2044 (y_ca .ne. nsize_aer(itype))) then
2045 msg = '*** subr init_data_mosaic_ptr - ptr error for ca'
2046 call peg_message( lunerr, msg )
2047 write(msg,9350) 'phase, type=', iphase,itype
2048 call peg_error_fatal( lunerr, msg )
2049 else if ((y_oin .ne. 0) .and. &
2050 (y_oin .ne. nsize_aer(itype))) then
2051 msg = '*** subr init_data_mosaic_ptr - ptr error for oin'
2052 call peg_message( lunerr, msg )
2053 write(msg,9350) 'phase, type=', iphase,itype
2054 call peg_error_fatal( lunerr, msg )
2055 else if ((y_oc .ne. 0) .and. &
2056 (y_oc .ne. nsize_aer(itype))) then
2057 msg = '*** subr init_data_mosaic_ptr - ptr error for oc'
2058 call peg_message( lunerr, msg )
2059 write(msg,9350) 'phase, type=', iphase,itype
2060 call peg_error_fatal( lunerr, msg )
2061 else if ((y_bc .ne. 0) .and. &
2062 (y_bc .ne. nsize_aer(itype))) then
2063 msg = '*** subr init_data_mosaic_ptr - ptr error for bc'
2064 call peg_message( lunerr, msg )
2065 write(msg,9350) 'phase, type=', iphase,itype
2066 call peg_error_fatal( lunerr, msg )
2067 else if ((y_hysw .ne. 0) .and. &
2068 (y_hysw .ne. nsize_aer(itype))) then
2069 msg = '*** subr init_data_mosaic_ptr - ptr error for hysw'
2070 call peg_message( lunerr, msg )
2071 write(msg,9350) 'phase, type=', iphase,itype
2072 call peg_error_fatal( lunerr, msg )
2073 end if
2074
2075 enddo ! type
2076 enddo ! phase
2077 !
2078 ! set pointers for gases
2079 ! rce 2004-dec-02 - gases not required to be present
2080 !
2081 if (p_sulf .ge. p1st) then
2082 kh2so4 = p_sulf
2083 ! else
2084 ! msg = '*** subr init_data_mosaic_ptr - ptr error for h2so4'
2085 ! call peg_error_fatal( lunerr, msg )
2086 end if
2087 if (p_hno3 .ge. p1st) then
2088 khno3 = p_hno3
2089 ! else
2090 ! msg = '*** subr init_data_mosaic_ptr - ptr error for hno3'
2091 ! call peg_error_fatal( lunerr, msg )
2092 end if
2093 if (p_hcl .ge. p1st) then
2094 khcl = p_hcl
2095 ! else
2096 ! msg = '*** subr init_data_mosaic_ptr - ptr error for hcl'
2097 ! call peg_error_fatal( lunerr, msg )
2098 end if
2099 if (p_nh3 .ge. p1st) then
2100 knh3 = p_nh3
2101 ! else
2102 ! msg = '*** subr init_data_mosaic_ptr - ptr error for nh3'
2103 ! call peg_error_fatal( lunerr, msg )
2104 end if
2105 if (p_o3 .ge. p1st) then
2106 ko3 = p_o3
2107 ! else
2108 ! msg = '*** subr init_data_mosaic_ptr - ptr error for o3'
2109 ! call peg_error_fatal( lunerr, msg )
2110 end if
2111
2112 ! rce 2005-apr-12 - added following species for cldchem, here and below:
2113 ! kso2, kh2o2, khcho, khcooh, koh, kho2,
2114 ! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh
2115 if (p_so2 .ge. p1st) kso2 = p_so2
2116 if (p_h2o2 .ge. p1st) kh2o2 = p_h2o2
2117 if (p_hcho .ge. p1st) khcho = p_hcho
2118 if (p_ora1 .ge. p1st) khcooh = p_ora1
2119 if (p_ho .ge. p1st) koh = p_ho
2120 if (p_ho2 .ge. p1st) kho2 = p_ho2
2121 if (p_no3 .ge. p1st) kno3 = p_no3
2122 if (p_no .ge. p1st) kno = p_no
2123 if (p_no2 .ge. p1st) kno2 = p_no2
2124 if (p_hono .ge. p1st) khono = p_hono
2125 if (p_pan .ge. p1st) kpan = p_pan
2126 if (p_ch3o2 .ge. p1st) kch3o2 = p_ch3o2
2127 if (p_ch3oh .ge. p1st) kch3oh = p_ch3oh
2128 if (p_op1 .ge. p1st) kch3ooh = p_op1
2129
2130 !
2131 ! calc ltot, ltot2, kh2o, ktemp
2132 !
2133 is_aerosol(:) = .false.
2134 ltot = 0
2135 ltot = max( ltot, kh2so4 )
2136 ltot = max( ltot, khno3 )
2137 ltot = max( ltot, khcl )
2138 ltot = max( ltot, knh3 )
2139 ltot = max( ltot, ko3 )
2140 ltot = max( ltot, kso2 )
2141 ltot = max( ltot, kh2o2 )
2142 ltot = max( ltot, khcho )
2143 ltot = max( ltot, khcooh )
2144 ltot = max( ltot, koh )
2145 ltot = max( ltot, kho2 )
2146 ltot = max( ltot, kno3 )
2147 ltot = max( ltot, kno )
2148 ltot = max( ltot, kno2 )
2149 ltot = max( ltot, khono )
2150 ltot = max( ltot, kpan )
2151 ltot = max( ltot, kch3o2 )
2152 ltot = max( ltot, kch3oh )
2153 ltot = max( ltot, kch3ooh )
2154 do iphase=1,nphase_aer
2155 do itype=1,ntype_aer
2156 do n = 1, nsize_aer(itype)
2157 do ll = 1, ncomp_plustracer_aer(itype)
2158 ltot = max( ltot, massptr_aer(ll,n,itype,iphase) )
2159 is_aerosol(massptr_aer(ll,n,itype,iphase))=.true.
2160 end do
2161 ltot = max( ltot, hyswptr_aer(n,itype) )
2162 ltot = max( ltot, waterptr_aer(n,itype) )
2163 ltot = max( ltot, numptr_aer(n,itype,iphase) )
2164 l = hyswptr_aer(n,itype)
2165 if (l .ge. p1st) is_aerosol(l)=.true.
2166 l = waterptr_aer(n,itype)
2167 if (l .ge. p1st) is_aerosol(l)=.true.
2168 l = numptr_aer(n,itype,iphase)
2169 if (l .ge. p1st) is_aerosol(l)=.true.
2170 end do
2171 end do
2172 end do
2173
2174 kh2o = ltot + 1
2175 ktemp = ltot + 2
2176 ltot2 = ktemp
2177
2178 write( msg, '(a,4(1x,i4))' ) 'ltot, ltot2, lmaxd, l2maxd =', &
2179 ltot, ltot2, lmaxd, l2maxd
2180 call peg_message( lunout, msg )
2181 if ((ltot .gt. lmaxd) .or. (ltot2 .gt. l2maxd)) then
2182 msg = '*** subr init_data_mosaic_ptr - ltot/ltot2 too big'
2183 call peg_error_fatal( lunerr, msg )
2184 end if
2185
2186 if (p_sulf .ge. p1st) name(kh2so4 ) = 'h2so4'
2187 if (p_hno3 .ge. p1st) name(khno3 ) = 'hno3'
2188 if (p_hcl .ge. p1st) name(khcl ) = 'hcl'
2189 if (p_nh3 .ge. p1st) name(knh3 ) = 'nh3'
2190 if (p_o3 .ge. p1st) name(ko3 ) = 'o3'
2191 if (p_so2 .ge. p1st) name(kso2 ) = 'so2'
2192 if (p_h2o2 .ge. p1st) name(kh2o2 ) = 'h2o2'
2193 if (p_hcho .ge. p1st) name(khcho ) = 'hcho'
2194 if (p_ora1 .ge. p1st) name(khcooh ) = 'hcooh'
2195 if (p_ho .ge. p1st) name(koh ) = 'oh'
2196 if (p_ho2 .ge. p1st) name(kho2 ) = 'ho2'
2197 if (p_no3 .ge. p1st) name(kno3 ) = 'no3'
2198 if (p_no .ge. p1st) name(kno ) = 'no'
2199 if (p_no2 .ge. p1st) name(kno2 ) = 'no2'
2200 if (p_hono .ge. p1st) name(khono ) = 'hono'
2201 if (p_pan .ge. p1st) name(kpan ) = 'pan'
2202 if (p_ch3o2 .ge. p1st) name(kch3o2 ) = 'ch3o2'
2203 if (p_ch3oh .ge. p1st) name(kch3oh ) = 'ch3oh'
2204 if (p_op1 .ge. p1st) name(kch3ooh) = 'ch3ooh'
2205 name(ktemp) = 'temp'
2206 name(kh2o) = 'h2o'
2207
2208 call initwet( &
2209 ntype_aer, nsize_aer, ncomp_aer, &
2210 massptr_aer, dens_aer, numptr_aer, &
2211 maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, &
2212 dcen_sect, sigmag_aer, &
2213 waterptr_aer, dens_water_aer, &
2214 scavimptblvol, scavimptblnum, nimptblgrow_mind, &
2215 nimptblgrow_maxd, dlndg_nimptblgrow)
2216
2217 return
2218 end subroutine init_data_mosaic_ptr
2219
2220
2221 !-----------------------------------------------------------------------
2222 subroutine aerchem_debug_dump( &
2223 iflag, iclm, jclm, dtchem )
2224
2225 use module_data_mosaic_asect
2226 use module_data_mosaic_other
2227 implicit none
2228
2229 ! include 'v33com'
2230 ! include 'v33com2'
2231 ! include 'v33com9a'
2232
2233 integer iflag, iclm, jclm
2234 real dtchem
2235
2236 ! local variables
2237 integer ientryno
2238 save ientryno
2239 integer iphase, itype, k, l, m, n
2240
2241 real dtchem_sv1
2242 save dtchem_sv1
2243 real rsub_sv1(l2maxd,kmaxd,nsubareamaxd)
2244
2245 data ientryno / -13579 /
2246
2247
2248 ! check for bypass based on some control variable ?
2249
2250
2251 ! do initial output when ientryno = -13579
2252 if (ientryno .ne. -13579) goto 1000
2253
2254 ientryno = +1
2255
2256 95010 format( a )
2257 95020 format( 8( 1x, i8 ) )
2258 95030 format( 4( 1pe18.10 ) )
2259
2260 print 95010, 'aerchem_debug_dump start -- first time'
2261 print 95020, ltot, ltot2, itot, jtot, ktot
2262 print 95010, (name(l), l=1,ltot2)
2263
2264 print 95020, maerocoag, maerchem, maeroptical
2265 print 95020, msectional, maerosolincw
2266 do iphase = 1, nphase_aer
2267 do itype=1,ntype_aer
2268 print 95020, iphase, itype, nsize_aer(itype), &
2269 ncomp_plustracer_aer(itype)
2270
2271 do n = 1, ncomp_plustracer_aer(itype)
2272 print 95010, &
2273 name_aer(n,itype)
2274 print 95030, &
2275 dens_aer(n,itype), mw_aer(n,itype)
2276 end do
2277
2278 do n = 1, nsize_aer(itype)
2279 print 95020, &
2280 ncomp_plustracer_aer(n), ncomp_aer(n), &
2281 waterptr_aer(n,itype), numptr_aer(n,itype,iphase), &
2282 mprognum_aer(n,itype,iphase)
2283 print 95020, &
2284 (mastercompptr_aer(l,itype), massptr_aer(l,n,itype,iphase), &
2285 l=1,ncomp_plustracer_aer(itype))
2286 print 95030, &
2287 volumcen_sect(n,itype), volumlo_sect(n,itype), &
2288 volumhi_sect(n,itype), dcen_sect(n,itype), &
2289 dlo_sect(n,itype), dhi_sect(n,itype)
2290 print 95020, &
2291 lptr_so4_aer(n,itype,iphase), lptr_msa_aer(n,itype,iphase), &
2292 lptr_no3_aer(n,itype,iphase), lptr_cl_aer(n,itype,iphase), &
2293 lptr_co3_aer(n,itype,iphase), lptr_nh4_aer(n,itype,iphase), &
2294 lptr_na_aer(n,itype,iphase), lptr_ca_aer(n,itype,iphase), &
2295 lptr_oin_aer(n,itype,iphase), lptr_oc_aer(n,itype,iphase), &
2296 lptr_bc_aer(n,itype,iphase), hyswptr_aer(n,itype)
2297 end do ! size
2298 end do ! type
2299 end do ! phase
2300 print 95010, 'aerchem_debug_dump end -- first time'
2301
2302 !
2303 ! test iflag
2304 !
2305 1000 continue
2306 if (iflag .eq. 1) goto 1010
2307 if (iflag .eq. 2) goto 2000
2308 if (iflag .eq. 3) goto 3000
2309 return
2310
2311 !
2312 ! iflag=1 -- save initial values
2313 ! AND FOR NOW do output too
2314 !
2315 1010 continue
2316 dtchem_sv1 = dtchem
2317 do m = 1, nsubareas
2318 do k = 1, ktot
2319 do l = 1, ltot2
2320 rsub_sv1(l,k,m) = rsub(l,k,m)
2321 end do
2322 end do
2323 end do
2324
2325 print 95010, 'aerchem_debug_dump start -- iflag=1'
2326 do m = 1, nsubareas
2327 do k = 1, ktot
2328 print 95020, iymdcur, ihmscur, &
2329 iclm, jclm, k, m, nsubareas, iflag
2330 print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), &
2331 ptotclm(k), afracsubarea(k,m)
2332 print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2)
2333 end do
2334 end do
2335 print 95010, 'aerchem_debug_dump end -- iflag=1'
2336
2337 return
2338
2339 !
2340 ! iflag=2 -- save intermediate values before doing move_sections
2341 ! (this is deactivated for now)
2342 !
2343 2000 continue
2344 return
2345
2346
2347 !
2348 ! iflag=3 -- do output
2349 !
2350 3000 continue
2351 print 95010, 'aerchem_debug_dump start -- iflag=3'
2352 do m = 1, nsubareas
2353 do k = 1, ktot
2354 print 95020, iymdcur, ihmscur, &
2355 iclm, jclm, k, m, nsubareas, iflag
2356 print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), &
2357 ptotclm(k), afracsubarea(k,m)
2358 print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2)
2359 end do
2360 end do
2361 print 95010, 'aerchem_debug_dump end -- iflag=3'
2362
2363
2364 return
2365 end subroutine aerchem_debug_dump
2366
2367
2368
2369 !-----------------------------------------------------------------------
2370 end module module_mosaic_driver