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