| blob | 25e7bb61a5844ec17e388da4b8e4ded369703a37 |
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
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
87 contains
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 !-----------------------------------------------------------------------
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 )
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
120 use module_state_description, only: num_moist, num_chem
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
131 implicit none
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 !-----------------------------------------------------------------------
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
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.
178 real, intent(in) :: dtstep, dtstepc
179 ! dtstep - main model time step (s)
180 ! dtstepc - time step for gas and aerosol chemistry(s)
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)
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)
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)
201 type(grid_config_rec_type), intent(in) :: config_flags
202 ! config_flags - configuration and control parameters
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
216 real :: dtchem, dtcoag, dtnuc
217 real :: dum
218 real :: rsub0(l2maxd,kmaxd,nsubareamaxd)
220 character*100 msg
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
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 - 1)/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-1
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
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
266 ! ktmaps,ktmape = first/last wrf kt for which aer chem is done
267 ktmaps = kts
268 ktmape = kte-1
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-1) + k_pegshift
277 ! set some variables to their wrf-chem "standard" values
278 mode_force_dump = 0
279 levdbg_err = 0
280 levdbg_info = 15
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 )
289 t = dtstep*(ktau-1)
290 ncorecnt = ktau - 1
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
305 ! set "pegasus" grid size variables
306 itot = ite
307 jtot = jte
308 nsubareas = 1
310 ijcount_dum = 0
312 call print_mosaic_stats( 0 )
315 do 2920 jt = jts, jte
316 do 2910 it = its, ite
318 ijcount_dum = ijcount_dum + 1
319 dtchem = dtstepc
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
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 )
343 !rce 22-jul-2006 - save initial mixrats
344 rsub0(:,:,:) = rsub(:,:,:)
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
359 ! if (ijcount_dum .le. 1) i_force_dump = 1
360 ! i_force_dump = 0
362 if (i_force_dump > 0) call aerchem_debug_dump( 1, it, jt, dtchem )
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
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 )
376 ! note units for aerosol is now ug/m3
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
384 if (i_force_dump > 0) call aerchem_debug_dump( 3, it, jt, dtchem )
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
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
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 )
416 ! print 93010, 'backfrm mapaerbb', it, jt
417 2910 continue
418 2920 continue
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
425 return
426 end subroutine mosaic_aerchem_driver
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 )
437 USE module_state_description, only: num_chem
438 USE module_data_mosaic_asect
439 IMPLICIT NONE
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
446 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
447 INTENT(IN) :: alt
449 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
450 INTENT(IN ) :: chem
452 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
453 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
455 INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase
457 imax = min(ite,ide-1)
458 jmax = min(jte,jde-1)
459 kmax = kte-1
460 !
461 ! Sum over bins with center diameter < 2.5e-4 cm for pm2_5_dry,
462 ! pm2_5_dry_ec, and pm2_5_water. All bins go into pm10
463 !
464 pm2_5_dry(its:ite,kts:kte,jts:jte) = 0.
465 pm2_5_dry_ec(its:ite,kts:kte,jts:jte) = 0.
466 pm2_5_water(its:ite,kts:kte,jts:jte) = 0.
467 pm10(its:ite,kts:kte,jts:jte) = 0.
469 do iphase=1,nphase_aer
470 do itype=1,ntype_aer
471 do n = 1, nsize_aer(itype)
472 if (dcen_sect(n,itype) .le. 2.5e-4) then
473 do j=jts,jmax
474 do k=kts,kmax
475 do i=its,imax
476 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) &
477 + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) &
478 + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) &
479 + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) &
480 + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) &
481 + chem(i,k,j,lptr_na_aer(n,itype,iphase)) &
482 + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) &
483 + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) &
484 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
486 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) &
487 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
489 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) &
490 + chem(i,k,j,waterptr_aer(n,itype))
492 pm10(i,k,j) = pm10(i,k,j) + pm2_5_dry(i,k,j)
493 enddo
494 enddo
495 enddo
496 else
497 do j=jts,jmax
498 do k=kts,kmax
499 do i=its,imax
500 pm10(i,k,j) = pm10(i,k,j) &
501 + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) &
502 + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) &
503 + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) &
504 + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) &
505 + chem(i,k,j,lptr_na_aer(n,itype,iphase)) &
506 + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) &
507 + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) &
508 + chem(i,k,j,lptr_bc_aer(n,itype,iphase))
509 enddo
510 enddo
511 enddo
512 endif
513 enddo ! size
514 enddo ! type
515 enddo ! phase
517 !Convert the units from mixing ratio to concentration (ug m^-3)
518 pm2_5_dry(its:imax,kts:kmax,jts:jmax) = pm2_5_dry(its:imax,kts:kmax,jts:jmax) &
519 / alt(its:imax,kts:kmax,jts:jmax)
520 pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) &
521 / alt(its:imax,kts:kmax,jts:jmax)
522 pm2_5_water(its:imax,kts:kmax,jts:jmax) = pm2_5_water(its:imax,kts:kmax,jts:jmax) &
523 / alt(its:imax,kts:kmax,jts:jmax)
525 end subroutine sum_pm_mosaic
527 ! ----------------------------------------------------------------------
528 subroutine mapaer_tofrom_host( imap, &
529 ims,ime, jms,jme, kms,kme, &
530 its,ite, jts,jte, kts,kte, &
531 it, jt, ktmaps,ktmape, &
532 num_moist, num_chem, moist, chem, &
533 t_phy, p_phy, rho_phy )
535 use module_configure, only: &
536 p_qv, p_qc, p_sulf, p_hno3, p_hcl, p_nh3, p_o3, &
537 p_so2, p_h2o2, p_hcho, p_ora1, p_ho, p_ho2, p_no3, &
538 p_no, p_no2, p_hono, p_pan, p_ch3o2, p_ch3oh, p_op1
539 use module_state_description, only: param_first_scalar
540 use module_data_mosaic_asect
541 use module_data_mosaic_other
542 use module_mosaic_csuesat, only: esat_gchm
543 use module_peg_util, only: peg_error_fatal, peg_message
545 implicit none
547 ! subr arguments
549 ! imap determines mapping direction (chem-->rsub if <=0, rsub-->chem if >0)
550 integer, intent(in) :: imap
551 ! wrf array dimensions
552 integer, intent(in) :: num_moist, num_chem
553 integer, intent(in) :: ims, ime, jms, jme, kms, kme
554 integer, intent(in) :: its, ite, jts, jte, kts, kte
555 ! do mapping for wrf i,k,j grid points = [it,ktmaps:ktmape,jt]
556 integer, intent(in) :: it, jt, ktmaps, ktmape
557 !
558 real, intent(in), dimension( ims:ime, kms:kme, jms:jme ) :: &
559 t_phy, rho_phy, p_phy
561 real, intent(in), &
562 dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: &
563 moist
565 real, intent(inout), &
566 dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: &
567 chem
570 ! local variables
571 integer ido_l, idum, iphase, itype, &
572 k, k1, k2, kt, kt1, kt2, k_pegshift, l, n
573 integer p1st
574 real dum, dumesat, dumrsat, dumrelhum, onemeps
575 real factdens, factpres, factmoist, factgas, &
576 factaerso4, factaerno3, factaercl, factaermsa, &
577 factaerco3, factaernh4, factaerna, factaerca, &
578 factaeroin, factaeroc, factaerbc, &
579 factaerhysw, factaerwater, factaernum
581 real, parameter :: eps=0.622
583 character*80 msg
586 !
587 ! units conversion factors
588 ! wrf-chem value = pegasus value X factor
589 !
590 factdens = 28.966e3 ! moleair/cm3 --> kgair/m3
591 factpres = 0.1 ! dyne/cm2 --> pa
592 factmoist = eps ! moleh2o/moleair --> kgh2o/kgair
593 factgas = 1.0e6 ! mole/moleair --> ppm
595 !wig 9-Nov-2004: Change to converting from concentration to converting
596 ! from mixing ratio.
597 ! factaernum = 40.9 ! #/moleair --> #/m3 at STP
598 !! at 1 atm & 298 k, 1 m3 = 40.9 moleair, 1 liter = 0.0409 moleair
599 factaernum = 1000./28.966 ! 1 kg air = (1000/28.966) moleair
601 dum = factaernum*1.0e6 ! g/moleair --> ug/m3 at STP
602 factaerso4 = dum*mw_so4_aer
603 factaerno3 = dum*mw_no3_aer
604 factaercl = dum*mw_cl_aer
605 factaermsa = dum*mw_msa_aer
606 factaerco3 = dum*mw_co3_aer
607 factaernh4 = dum*mw_nh4_aer
608 factaerna = dum*mw_na_aer
609 factaerca = dum*mw_ca_aer
610 factaeroin = dum
611 factaeroc = dum
612 factaerbc = dum
613 factaerhysw = dum*mw_water_aer
614 factaerwater = dum*mw_water_aer
616 ! If aboxtest_units_convert=10, turn off units conversions both here
617 ! and in module_mosaic. This is for testing, to allow exact agreements.
618 if (aboxtest_units_convert .eq. 10) then
619 factdens = 1.0
620 factpres = 1.0
621 factmoist = 1.0
622 factgas = 1.0
623 factaernum = 1.0
624 factaerso4 = 1.0
625 factaerno3 = 1.0
626 factaercl = 1.0
627 factaermsa = 1.0
628 factaerco3 = 1.0
629 factaernh4 = 1.0
630 factaerna = 1.0
631 factaerca = 1.0
632 factaeroin = 1.0
633 factaeroc = 1.0
634 factaerbc = 1.0
635 factaerhysw = 1.0
636 factaerwater = 1.0
637 end if
640 ! rce 2005-mar-09 - set ktot in mapaer_tofrom_host;
641 ! use k_pegshift for calc of ktot and k (=k_peg)
642 ! k_pegshift = k index shift between wrf-chem and pegasus arrays
643 k_pegshift = k_pegbegin - kts
645 ! set ktot = highest k index for pegasus arrays
646 ! since kts=1 and k_pegbegin=1, get k_pegshift=0 and ktot=kte-1
647 ktot = (kte-1) + k_pegshift
648 ! *** check that ktot and kte <= kmaxd ***
649 if ((kte > kmaxd) .or. (ktot > kmaxd) .or. (ktot <= 0)) then
650 write( msg, '(a,4i5)' ) &
651 '*** subr mapaer_tofrom_host -- ' // &
652 'ktot, kmaxd, kts, kte', ktot, kmaxd, kts, kte
653 call peg_message( lunerr, msg )
654 msg = '*** subr mosaic_aerchem_driver -- ' // &
655 'kte>kmaxd OR ktot>kmaxd OR ktot<=0'
656 call peg_error_fatal( lunerr, msg )
657 end if
659 ! rce 2005-apr-28 - changed mapping loops to improve memory access
660 ! now do rsub(l,k1:k2,m) <--> chem(it,kt1:kt2,jt,l) for each species
661 kt1 = ktmaps
662 kt2 = ktmape
663 k1 = kt1 + k_pegshift
664 k2 = kt2 + k_pegshift
666 if (imap .gt. 0) goto 2000
668 !
669 ! imap==0 -- map species and state variables from host arrays
670 ! to rsub, cairclm, ptotclm
672 ! first zero everything (except relhumclm)
673 rsub(:,:,:) = 0.0
674 cairclm(:) = 0.0
675 ptotclm(:) = 0.0
676 afracsubarea(:,:) = 0.0
677 relhumclm(:) = aboxtest_min_relhum
678 rcldwtr_sub(:,:) = 0.0
680 adrydens_sub( :,:,:,:) = 0.0
681 aqmassdry_sub(:,:,:,:) = 0.0
682 aqvoldry_sub( :,:,:,:) = 0.0
684 ! map gas and aerosol mixing ratios based on aboxtest_map_method
685 ! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx
686 ! 2 - map 181 pegasus species using rsub(l) = chem(l+1)
687 ! 3 - do 2 followed by 1
688 ! other - same as 1
689 ! (2 and 3 are for box test purposes)
690 if ((aboxtest_map_method .eq. 2) .or. &
691 (aboxtest_map_method .eq. 3)) then
692 do l = 2, num_chem
693 rsub(l,k1:k2,1) = chem(it,kt1:kt2,jt,l)/factgas
694 end do
695 end if
697 p1st = param_first_scalar
698 if (aboxtest_map_method .ne. 2) then
699 if (p_sulf .ge. p1st) &
700 rsub(kh2so4,k1:k2,1) = chem(it,kt1:kt2,jt,p_sulf)/factgas
701 if (p_hno3 .ge. p1st) &
702 rsub(khno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_hno3)/factgas
703 if (p_hcl .ge. p1st) &
704 rsub(khcl,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcl)/factgas
705 if (p_nh3 .ge. p1st) &
706 rsub(knh3,k1:k2,1) = chem(it,kt1:kt2,jt,p_nh3)/factgas
708 ! rce 2005-apr-12 - added following species for cldchem, here and below:
709 ! ko3, kso2, kh2o2, khcho, khcooh, koh, kho2,
710 ! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh
711 if (p_o3 .ge. p1st) &
712 rsub(ko3,k1:k2,1) = chem(it,kt1:kt2,jt,p_o3)/factgas
713 if (p_so2 .ge. p1st) &
714 rsub(kso2,k1:k2,1) = chem(it,kt1:kt2,jt,p_so2)/factgas
715 if (p_h2o2 .ge. p1st) &
716 rsub(kh2o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_h2o2)/factgas
717 if (p_hcho .ge. p1st) &
718 rsub(khcho,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcho)/factgas
719 if (p_ora1 .ge. p1st) &
720 rsub(khcooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ora1)/factgas
721 if (p_ho .ge. p1st) &
722 rsub(koh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho)/factgas
723 if (p_ho2 .ge. p1st) &
724 rsub(kho2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho2)/factgas
725 if (p_no3 .ge. p1st) &
726 rsub(kno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_no3)/factgas
727 if (p_no .ge. p1st) &
728 rsub(kno,k1:k2,1) = chem(it,kt1:kt2,jt,p_no)/factgas
729 if (p_no2 .ge. p1st) &
730 rsub(kno2,k1:k2,1) = chem(it,kt1:kt2,jt,p_no2)/factgas
731 if (p_hono .ge. p1st) &
732 rsub(khono,k1:k2,1) = chem(it,kt1:kt2,jt,p_hono)/factgas
733 if (p_pan .ge. p1st) &
734 rsub(kpan,k1:k2,1) = chem(it,kt1:kt2,jt,p_pan)/factgas
735 if (p_ch3o2 .ge. p1st) &
736 rsub(kch3o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3o2)/factgas
737 if (p_ch3oh .ge. p1st) &
738 rsub(kch3oh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3oh)/factgas
739 if (p_op1 .ge. p1st) &
740 rsub(kch3ooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_op1)/factgas
742 do iphase=1,nphase_aer
743 do itype=1,ntype_aer
744 do n = 1, nsize_aer(itype)
745 rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1) = &
746 chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase))/factaerso4
747 rsub(numptr_aer(n,itype,iphase),k1:k2,1) = &
748 chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase))/factaernum
750 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) &
751 rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1) = &
752 chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase))/factaerno3
753 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) &
754 rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1) = &
755 chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase))/factaercl
756 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) &
757 rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1) = &
758 chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase))/factaermsa
759 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) &
760 rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1) = &
761 chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase))/factaerco3
762 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) &
763 rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1) = &
764 chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase))/factaernh4
765 if (lptr_na_aer(n,itype,iphase) .ge. p1st) &
766 rsub(lptr_na_aer(n,itype,iphase),k1:k2,1) = &
767 chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase))/factaerna
768 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) &
769 rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1) = &
770 chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase))/factaerca
771 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) &
772 rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1) = &
773 chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase))/factaeroin
774 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) &
775 rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1) = &
776 chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase))/factaeroc
777 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) &
778 rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1) = &
779 chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase))/factaerbc
780 if (hyswptr_aer(n,itype) .ge. p1st) &
781 rsub(hyswptr_aer(n,itype),k1:k2,1) = &
782 chem(it,kt1:kt2,jt,hyswptr_aer(n,itype))/factaerhysw
783 if (waterptr_aer(n,itype) .ge. p1st) &
784 rsub(waterptr_aer(n,itype),k1:k2,1) = &
785 chem(it,kt1:kt2,jt,waterptr_aer(n,itype))/factaerwater
786 end do ! size
787 end do ! type
788 end do ! phase
789 end if
791 ! map state variables
792 afracsubarea(k1:k2,1) = 1.0
793 rsub(ktemp,k1:k2,1) = t_phy(it,kt1:kt2,jt)
794 rsub(kh2o,k1:k2,1) = moist(it,kt1:kt2,jt,p_qv)/factmoist
795 cairclm(k1:k2) = rho_phy(it,kt1:kt2,jt)/factdens
796 ptotclm(k1:k2) = p_phy(it,kt1:kt2,jt)/factpres
797 if (p_qc .ge. p1st) &
798 rcldwtr_sub(k1:k2,1) = moist(it,kt1:kt2,jt,p_qc)/factmoist
800 ! compute or get relative humidity, based on aboxtest_rh_method
801 ! 1 - compute from water vapor, temperature, and pressure
802 ! 2 - get from test driver via aboxtest_get_extra_args with iflag=30
803 ! 3 - do both, and use the relhum from test driver
804 ! other positive - same as 1
805 ! 0 or negative - set to aboxtest_min_relhum
807 #if defined ( aboxtest_box_testing_active )
808 ! *** start of "box testing" code section ***
809 ! these code lines should be inactive when running wrf-chem
810 !
811 ! get relhumclm from box test driver
812 if ((aboxtest_rh_method .eq. 2) .or. &
813 (aboxtest_rh_method .eq. 3)) then
814 do kt = ktmaps, ktmape
815 k = kt + k_pegshift
816 call aboxtest_get_extra_args( 30, &
817 it, jt, k, idum, idum, idum, idum, idum, idum, &
818 relhumclm(k), dum )
819 end do
820 end if
821 ! *** end of "box testing" code section ***
822 #endif
824 ! compute relhumclm from water vapor, temperature, and pressure
825 ! *** force relhum to between aboxtest_min/max_relhum
826 if ((aboxtest_rh_method .gt. 0) .and. &
827 (aboxtest_rh_method .ne. 2)) then
828 do kt = ktmaps, ktmape
829 k = kt + k_pegshift
830 onemeps = 1.0 - 0.622
831 dumesat = esat_gchm( rsub(ktemp,k,1) )
832 dumrsat = dumesat / (ptotclm(k) - onemeps*dumesat)
833 dumrelhum = rsub(kh2o,k,1) / max( dumrsat, 1.e-20 )
834 dumrelhum = max( 0.0, min( 0.99, dumrelhum ) )
836 if (aboxtest_rh_method .eq. 3) then
837 ! write(msg,9720) k, relhumclm(k), dumrelhum, &
838 ! (dumrelhum-relhumclm(k))
839 !9720 format( 'k,rh1,rh2,2-1', i4, 3f14.10 )
840 ! call peg_message( lunerr, msg )
841 continue
842 else
843 relhumclm(k) = dumrelhum
844 end if
845 relhumclm(k) = max( relhumclm(k), aboxtest_min_relhum )
846 relhumclm(k) = min( relhumclm(k), aboxtest_max_relhum )
847 end do
848 end if
850 ! *** force temperature to be > aboxtest_min_temp
851 do kt = ktmaps, ktmape
852 k = kt + k_pegshift
853 rsub(ktemp,k,1) = &
854 max( rsub(ktemp,k,1), aboxtest_min_temp )
855 end do
857 return
860 !
861 ! imap==1 -- map species from rsub back to host arrays
862 ! (map gas and aerosol mixing ratios based on aboxtest_map_method as above)
863 !
864 ! when aboxtest_gases_fixed==10, leave gases (h2so4,hno3,...) unchanged
865 !
866 2000 continue
867 ! map gas and aerosol mixing ratios based on aboxtest_map_method
868 ! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx
869 ! 2 - map 181 pegasus species using rsub(l) = chem(l+1)
870 ! 3 - do 2 followed by 1
871 ! other - same as 1
872 ! (2 and 3 are for box test purposes)
873 if ((aboxtest_map_method .eq. 2) .or. &
874 (aboxtest_map_method .eq. 3)) then
875 do l = 2, num_chem
876 ido_l = 1
877 if (aboxtest_gases_fixed .eq. 10) then
878 if ((l .eq. kh2so4 ) .or. (l .eq. khno3 ) .or. &
879 (l .eq. khcl ) .or. (l .eq. knh3 ) .or. &
880 (l .eq. ko3 ) .or. &
881 (l .eq. kso2 ) .or. (l .eq. kh2o2 ) .or. &
882 (l .eq. khcho ) .or. (l .eq. khcooh ) .or. &
883 (l .eq. koh ) .or. (l .eq. kho2 ) .or. &
884 (l .eq. kno3 ) .or. (l .eq. kno ) .or. &
885 (l .eq. kno2 ) .or. (l .eq. khono ) .or. &
886 (l .eq. kpan ) .or. (l .eq. kch3o2 ) .or. &
887 (l .eq. kch3oh ) .or. (l .eq. kch3ooh)) then
888 ido_l = 0
889 end if
890 end if
891 if (ido_l .gt. 0) then
892 chem(it,kt1:kt2,jt,l) = rsub(l,k1:k2,1)*factgas
893 end if
894 end do
895 end if
897 p1st = param_first_scalar
898 if (aboxtest_map_method .ne. 2) then
899 if (aboxtest_gases_fixed .ne. 10) then
900 if (p_sulf .ge. p1st) &
901 chem(it,kt1:kt2,jt,p_sulf) = rsub(kh2so4,k1:k2,1)*factgas
902 if (p_hno3 .ge. p1st) &
903 chem(it,kt1:kt2,jt,p_hno3) = rsub(khno3,k1:k2,1)*factgas
904 if (p_hcl .ge. p1st) &
905 chem(it,kt1:kt2,jt,p_hcl) = rsub(khcl,k1:k2,1)*factgas
906 if (p_nh3 .ge. p1st) &
907 chem(it,kt1:kt2,jt,p_nh3) = rsub(knh3,k1:k2,1)*factgas
909 if (p_o3 .ge. p1st) &
910 chem(it,kt1:kt2,jt,p_o3) = rsub(ko3,k1:k2,1)*factgas
911 if (p_so2 .ge. p1st) &
912 chem(it,kt1:kt2,jt,p_so2) = rsub(kso2,k1:k2,1)*factgas
913 if (p_h2o2 .ge. p1st) &
914 chem(it,kt1:kt2,jt,p_h2o2) = rsub(kh2o2,k1:k2,1)*factgas
915 if (p_hcho .ge. p1st) &
916 chem(it,kt1:kt2,jt,p_hcho) = rsub(khcho,k1:k2,1)*factgas
917 if (p_ora1 .ge. p1st) &
918 chem(it,kt1:kt2,jt,p_ora1) = rsub(khcooh,k1:k2,1)*factgas
919 if (p_ho .ge. p1st) &
920 chem(it,kt1:kt2,jt,p_ho) = rsub(koh,k1:k2,1)*factgas
921 if (p_ho2 .ge. p1st) &
922 chem(it,kt1:kt2,jt,p_ho2) = rsub(kho2,k1:k2,1)*factgas
923 if (p_no3 .ge. p1st) &
924 chem(it,kt1:kt2,jt,p_no3) = rsub(kno3,k1:k2,1)*factgas
925 if (p_no .ge. p1st) &
926 chem(it,kt1:kt2,jt,p_no) = rsub(kno,k1:k2,1)*factgas
927 if (p_no2 .ge. p1st) &
928 chem(it,kt1:kt2,jt,p_no2) = rsub(kno2,k1:k2,1)*factgas
929 if (p_hono .ge. p1st) &
930 chem(it,kt1:kt2,jt,p_hono) = rsub(khono,k1:k2,1)*factgas
931 if (p_pan .ge. p1st) &
932 chem(it,kt1:kt2,jt,p_pan) = rsub(kpan,k1:k2,1)*factgas
933 if (p_ch3o2 .ge. p1st) &
934 chem(it,kt1:kt2,jt,p_ch3o2) = rsub(kch3o2,k1:k2,1)*factgas
935 if (p_ch3oh .ge. p1st) &
936 chem(it,kt1:kt2,jt,p_ch3oh) = rsub(kch3oh,k1:k2,1)*factgas
937 if (p_op1 .ge. p1st) &
938 chem(it,kt1:kt2,jt,p_op1) = rsub(kch3ooh,k1:k2,1)*factgas
939 end if
941 do iphase=1,nphase_aer
942 do itype=1,ntype_aer
943 do n = 1, nsize_aer(itype)
944 chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase)) = &
945 rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1)*factaerso4
946 chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase)) = &
947 rsub(numptr_aer(n,itype,iphase),k1:k2,1)*factaernum
949 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) &
950 chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase)) = &
951 rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1)*factaerno3
952 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) &
953 chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase)) = &
954 rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1)*factaercl
955 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) &
956 chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase)) = &
957 rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1)*factaermsa
958 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) &
959 chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase)) = &
960 rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1)*factaerco3
961 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) &
962 chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase)) = &
963 rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1)*factaernh4
964 if (lptr_na_aer(n,itype,iphase) .ge. p1st) &
965 chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase)) = &
966 rsub(lptr_na_aer(n,itype,iphase),k1:k2,1)*factaerna
967 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) &
968 chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase)) = &
969 rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1)*factaerca
970 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) &
971 chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase)) = &
972 rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1)*factaeroin
973 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) &
974 chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase)) = &
975 rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1)*factaeroc
976 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) &
977 chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase)) = &
978 rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1)*factaerbc
979 if (hyswptr_aer(n,itype) .ge. p1st) &
980 chem(it,kt1:kt2,jt,hyswptr_aer(n,itype)) = &
981 rsub(hyswptr_aer(n,itype),k1:k2,1)*factaerhysw
982 if (waterptr_aer(n,itype) .ge. p1st) &
983 chem(it,kt1:kt2,jt,waterptr_aer(n,itype)) = &
984 rsub(waterptr_aer(n,itype),k1:k2,1)*factaerwater
985 end do ! size
986 end do ! type
987 end do ! phase
988 end if
991 return
993 end subroutine mapaer_tofrom_host
996 !-----------------------------------------------------------------------
997 ! *** note - eventually is_aerosol will be a subr argument
998 subroutine init_data_mosaic_asect( is_aerosol )
999 ! subroutine init_data_mosaic_asect( )
1001 use module_data_mosaic_asect
1002 use module_data_mosaic_other, only: lunerr, lunout, &
1003 aboxtest_testmode, aboxtest_units_convert, &
1004 aboxtest_rh_method, aboxtest_map_method, &
1005 aboxtest_gases_fixed, aboxtest_min_temp, &
1006 aboxtest_min_relhum, aboxtest_max_relhum
1007 use module_data_mosaic_therm, only: nbin_a, nbin_a_maxd
1008 use module_mosaic_csuesat, only: init_csuesat
1009 use module_mosaic_movesect, only: move_sections, test_move_sections
1010 use module_peg_util, only: peg_error_fatal
1013 use module_configure, only: &
1014 p_so4_a01, p_so4_a02, p_so4_a03, p_so4_a04, &
1015 p_so4_a05, p_so4_a06, p_so4_a07, p_so4_a08
1016 #if defined ( cw_species_are_in_registry )
1017 use module_configure, only: &
1018 p_so4_cw01, p_no3_cw01, p_cl_cw01, p_nh4_cw01, p_na_cw01, &
1019 p_so4_cw02, p_no3_cw02, p_cl_cw02, p_nh4_cw02, p_na_cw02, &
1020 p_so4_cw03, p_no3_cw03, p_cl_cw03, p_nh4_cw03, p_na_cw03, &
1021 p_so4_cw04, p_no3_cw04, p_cl_cw04, p_nh4_cw04, p_na_cw04, &
1022 p_so4_cw05, p_no3_cw05, p_cl_cw05, p_nh4_cw05, p_na_cw05, &
1023 p_so4_cw06, p_no3_cw06, p_cl_cw06, p_nh4_cw06, p_na_cw06, &
1024 p_so4_cw07, p_no3_cw07, p_cl_cw07, p_nh4_cw07, p_na_cw07, &
1025 p_so4_cw08, p_no3_cw08, p_cl_cw08, p_nh4_cw08, p_na_cw08, &
1026 p_oin_cw01, p_oc_cw01, p_bc_cw01, p_num_cw01, &
1027 p_oin_cw02, p_oc_cw02, p_bc_cw02, p_num_cw02, &
1028 p_oin_cw03, p_oc_cw03, p_bc_cw03, p_num_cw03, &
1029 p_oin_cw04, p_oc_cw04, p_bc_cw04, p_num_cw04, &
1030 p_oin_cw05, p_oc_cw05, p_bc_cw05, p_num_cw05, &
1031 p_oin_cw06, p_oc_cw06, p_bc_cw06, p_num_cw06, &
1032 p_oin_cw07, p_oc_cw07, p_bc_cw07, p_num_cw07, &
1033 p_oin_cw08, p_oc_cw08, p_bc_cw08, p_num_cw08
1034 #endif
1036 use module_state_description, only: param_first_scalar, num_chem
1038 implicit none
1040 ! *** note - eventually is_aerosol will be a subr argument
1041 logical, intent(out) :: is_aerosol(num_chem)
1043 ! local variables
1044 integer idum, itype, l, ldum, n, nhi, nsize_aer_dum
1045 real dum
1046 real, parameter :: pi = 3.14159265
1048 !
1049 ! set some "pegasus" control variables
1050 !
1051 msectional = 20
1052 maerocoag = -2
1053 maerchem = 1
1054 maeroptical = 1
1055 maerchem_boxtest_output = -1
1057 !
1058 ! set ntype_aer = 1
1059 !
1060 ntype_aer = 1
1062 !
1063 ! set number of aerosol bins using the wrf-chem sulfate pointers
1064 !
1065 nsize_aer(:) = 0
1066 itype=1
1067 if (p_so4_a01 .ge. param_first_scalar) nsize_aer(itype) = 1
1068 if (p_so4_a02 .ge. param_first_scalar) nsize_aer(itype) = 2
1069 if (p_so4_a03 .ge. param_first_scalar) nsize_aer(itype) = 3
1070 if (p_so4_a04 .ge. param_first_scalar) nsize_aer(itype) = 4
1071 if (p_so4_a05 .ge. param_first_scalar) nsize_aer(itype) = 5
1072 if (p_so4_a06 .ge. param_first_scalar) nsize_aer(itype) = 6
1073 if (p_so4_a07 .ge. param_first_scalar) nsize_aer(itype) = 7
1074 if (p_so4_a08 .ge. param_first_scalar) nsize_aer(itype) = 8
1076 if (nsize_aer(itype) .le. 0) then
1077 call peg_error_fatal( lunerr, &
1078 'init_data_mosaic_asect - nsize_aer = 0' )
1079 else if (nsize_aer(itype) .gt. maxd_asize) then
1080 call peg_error_fatal( lunerr, &
1081 'init_data_mosaic_asect - nsize_aer > maxd_asize' )
1082 end if
1084 !
1085 ! set nbin_a to total number of aerosol bins (for all types)
1086 !
1087 nbin_a = 0
1088 do itype = 1, ntype_aer
1089 nbin_a = nbin_a + nsize_aer(itype)
1090 end do
1091 if (nbin_a .gt. nbin_a_maxd) then
1092 call peg_error_fatal( lunerr, &
1093 'init_data_mosaic_asect - nbin_a > nbin_a_maxd' )
1094 end if
1096 !
1097 ! set nphase_aer (number of active aerosol species phases),
1098 ! the xx_phase, and maerosolincw
1099 !
1100 nphase_aer = 0
1101 maerosolincw = 0
1102 if (nsize_aer(1) .gt. 0) then
1103 nphase_aer = 1
1104 ai_phase = 1
1106 #if defined ( cw_species_are_in_registry )
1107 if (p_so4_cw01 .ge. param_first_scalar) then
1108 nphase_aer = 2
1109 cw_phase = 2
1110 maerosolincw = 1
1111 end if
1112 #endif
1113 end if
1116 #if defined ( aboxtest_box_testing_active )
1117 ! *** start of "box testing" code section ***
1118 ! these code lines should be inactive when running wrf-chem
1119 !
1120 ! set some variables to "box test" values
1121 call aboxtest_get_extra_args( 10, &
1122 msectional, maerosolincw, maerocoag, &
1123 maerchem, maeroptical, maerchem_boxtest_output, &
1124 lunerr, lunout, idum, dum, dum )
1125 call aboxtest_get_extra_args( 11, &
1126 aboxtest_testmode, aboxtest_units_convert, &
1127 aboxtest_rh_method, aboxtest_map_method, &
1128 aboxtest_gases_fixed, nsize_aer_dum, &
1129 idum, idum, idum, dum, dum )
1131 itype = 1
1132 if (nsize_aer_dum > 0) nsize_aer(itype) = nsize_aer_dum
1134 aboxtest_min_temp = 0.0
1135 aboxtest_min_relhum = 0.0
1136 aboxtest_max_relhum = 1.0
1137 ! *** end of "box testing" code section ***
1138 #endif
1141 !
1142 ! set master aerosol chemical types
1143 !
1144 ntot_mastercomp_aer = 11
1146 l = 1
1147 mastercompindx_so4_aer = l
1148 name_mastercomp_aer( l ) = 'sulfate'
1149 dens_mastercomp_aer( l ) = dens_so4_aer
1150 mw_mastercomp_aer( l ) = mw_so4_aer
1151 hygro_mastercomp_aer(l ) = hygro_so4_aer
1153 l = 2
1154 mastercompindx_no3_aer = l
1155 name_mastercomp_aer( l ) = 'nitrate'
1156 dens_mastercomp_aer( l ) = dens_no3_aer
1157 mw_mastercomp_aer( l ) = mw_no3_aer
1158 hygro_mastercomp_aer(l ) = hygro_no3_aer
1160 l = 3
1161 mastercompindx_cl_aer = l
1162 name_mastercomp_aer( l ) = 'chloride'
1163 dens_mastercomp_aer( l ) = dens_cl_aer
1164 mw_mastercomp_aer( l ) = mw_cl_aer
1165 hygro_mastercomp_aer(l ) = hygro_cl_aer
1167 l = 4
1168 mastercompindx_msa_aer = l
1169 name_mastercomp_aer( l ) = 'msa'
1170 dens_mastercomp_aer( l ) = dens_msa_aer
1171 mw_mastercomp_aer( l ) = mw_msa_aer
1172 hygro_mastercomp_aer(l ) = hygro_msa_aer
1174 l = 5
1175 mastercompindx_co3_aer = l
1176 name_mastercomp_aer( l ) = 'carbonate'
1177 dens_mastercomp_aer( l ) = dens_co3_aer
1178 mw_mastercomp_aer( l ) = mw_co3_aer
1179 hygro_mastercomp_aer(l ) = hygro_co3_aer
1181 l = 6
1182 mastercompindx_nh4_aer = l
1183 name_mastercomp_aer( l ) = 'ammonium'
1184 dens_mastercomp_aer( l ) = dens_nh4_aer
1185 mw_mastercomp_aer( l ) = mw_nh4_aer
1186 hygro_mastercomp_aer(l ) = hygro_nh4_aer
1188 l = 7
1189 mastercompindx_na_aer = l
1190 name_mastercomp_aer( l ) = 'sodium'
1191 dens_mastercomp_aer( l ) = dens_na_aer
1192 mw_mastercomp_aer( l ) = mw_na_aer
1193 hygro_mastercomp_aer(l ) = hygro_na_aer
1195 l = 8
1196 mastercompindx_ca_aer = l
1197 name_mastercomp_aer( l ) = 'calcium'
1198 dens_mastercomp_aer( l ) = dens_ca_aer
1199 mw_mastercomp_aer( l ) = mw_ca_aer
1200 hygro_mastercomp_aer(l ) = hygro_ca_aer
1202 l = 9
1203 mastercompindx_oin_aer = l
1204 name_mastercomp_aer( l ) = 'otherinorg'
1205 dens_mastercomp_aer( l ) = dens_oin_aer
1206 mw_mastercomp_aer( l ) = mw_oin_aer
1207 hygro_mastercomp_aer(l ) = hygro_oin_aer
1209 l = 10
1210 mastercompindx_oc_aer = l
1211 name_mastercomp_aer( l ) = 'organic-c'
1212 dens_mastercomp_aer( l ) = dens_oc_aer
1213 mw_mastercomp_aer( l ) = mw_oc_aer
1214 hygro_mastercomp_aer(l ) = hygro_oc_aer
1216 l = 11
1217 mastercompindx_bc_aer = l
1218 name_mastercomp_aer( l ) = 'black-c'
1219 dens_mastercomp_aer( l ) = dens_bc_aer
1220 mw_mastercomp_aer( l ) = mw_bc_aer
1221 hygro_mastercomp_aer(l ) = hygro_bc_aer
1224 !
1225 ! set section size arrays
1226 !
1227 do itype = 1, ntype_aer
1228 nhi = nsize_aer(itype)
1229 dlo_sect(1,itype) = 3.90625e-6
1230 dhi_sect(nhi,itype) = 10.0e-4
1232 dum = alog( dhi_sect(nhi,itype)/dlo_sect(1,itype) ) / nhi
1233 do n = 2, nhi
1234 dlo_sect(n,itype) = dlo_sect(1,itype) * exp( (n-1)*dum )
1235 dhi_sect(n-1,itype) = dlo_sect(n,itype)
1236 end do
1237 do n = 1, nhi
1238 dcen_sect(n,itype) = sqrt( dlo_sect(n,itype)*dhi_sect(n,itype) )
1239 volumlo_sect(n,itype) = (pi/6.) * (dlo_sect(n,itype)**3)
1240 volumhi_sect(n,itype) = (pi/6.) * (dhi_sect(n,itype)**3)
1241 volumcen_sect(n,itype) = (pi/6.) * (dcen_sect(n,itype)**3)
1242 sigmag_aer(n,itype) = (dhi_sect(n,itype)/dlo_sect(n,itype))**0.289
1243 end do
1244 end do
1246 !
1247 ! set pointers to wrf chem-array species
1248 !
1249 call init_data_mosaic_ptr( is_aerosol )
1251 !
1252 ! csuesat initialization
1253 !
1254 call init_csuesat
1256 !
1257 ! move_sect initialization (and testing)
1258 !
1259 ! subr move_sections( iflag, iclm, jclm, k, m )
1260 call move_sections( -1, 1, 1, 1, 1 )
1262 call test_move_sections( 1, 1, 1, 1, 1 )
1265 end subroutine init_data_mosaic_asect
1268 !-----------------------------------------------------------------------
1269 subroutine init_data_mosaic_ptr( is_aerosol )
1271 use module_configure
1272 use module_state_description, only: param_first_scalar,num_chem
1273 use module_data_mosaic_asect
1274 use module_data_mosaic_other, only: &
1275 kh2so4, khno3, khcl, knh3, ko3, kh2o, ktemp, &
1276 kso2, kh2o2, khcho, khcooh, koh, kho2, &
1277 kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh, &
1278 lmaxd, l2maxd, ltot, ltot2, lunout, lunerr, name
1279 use module_peg_util, only: peg_error_fatal, peg_message
1280 use module_mosaic_wetscav, only: initwet
1282 implicit none
1284 ! subr arguments
1285 logical, intent(out) :: is_aerosol(num_chem)
1286 ! local variables
1287 integer l, ll, n, p1st
1288 integer iaddto_ncomp, iaddto_ncomp_plustracer
1289 integer l_mastercomp, lptr_dum
1290 integer mcindx_dum
1291 integer isize, itype, iphase
1292 integer nphasetxt, nsizetxt, nspectxt, ntypetxt
1293 integer ncomp_dum(maxd_asize,maxd_aphase)
1294 integer ncomp_plustracer_dum(maxd_asize,maxd_aphase)
1296 integer y_so4, y_no3, y_cl, y_msa, y_co3, y_nh4, y_na, &
1297 y_ca, y_oin, y_oc, y_bc, y_hysw, y_water, y_num
1298 integer y_cw_so4, y_cw_no3, y_cw_cl, y_cw_msa, y_cw_co3, &
1299 y_cw_nh4, y_cw_na, &
1300 y_cw_ca, y_cw_oin, y_cw_oc, y_cw_bc, y_cw_num
1302 character*200 msg
1303 character*8 phasetxt, sizetxt, spectxt, typetxt
1306 p1st = param_first_scalar
1307 !
1308 ! set up pointers to aerosol species in the wrf-chem "chem" array
1309 ! note: lptr=1 points to the first chem species which is "unused"
1310 !
1311 itype=1
1312 lptr_so4_aer(:,itype,:) = 1
1313 lptr_no3_aer(:,itype,:) = 1
1314 lptr_cl_aer(:,itype,:) = 1
1315 lptr_msa_aer(:,itype,:) = 1
1316 lptr_co3_aer(:,itype,:) = 1
1317 lptr_nh4_aer(:,itype,:) = 1
1318 lptr_na_aer(:,itype,:) = 1
1319 lptr_ca_aer(:,itype,:) = 1
1320 lptr_oin_aer(:,itype,:) = 1
1321 lptr_oc_aer(:,itype,:) = 1
1322 lptr_bc_aer(:,itype,:) = 1
1323 hyswptr_aer(:,itype) = 1
1324 waterptr_aer(:,itype) = 1
1325 numptr_aer(:,itype,:) = 1
1328 if (nsize_aer(itype) .ge. 1) then
1329 lptr_so4_aer(01,itype,ai_phase) = p_so4_a01
1330 lptr_no3_aer(01,itype,ai_phase) = p_no3_a01
1331 lptr_cl_aer(01,itype,ai_phase) = p_cl_a01
1332 lptr_msa_aer(01,itype,ai_phase) = p_msa_a01
1333 lptr_co3_aer(01,itype,ai_phase) = p_co3_a01
1334 lptr_nh4_aer(01,itype,ai_phase) = p_nh4_a01
1335 lptr_na_aer(01,itype,ai_phase) = p_na_a01
1336 lptr_ca_aer(01,itype,ai_phase) = p_ca_a01
1337 lptr_oin_aer(01,itype,ai_phase) = p_oin_a01
1338 lptr_oc_aer(01,itype,ai_phase) = p_oc_a01
1339 lptr_bc_aer(01,itype,ai_phase) = p_bc_a01
1340 hyswptr_aer(01,itype) = p_hysw_a01
1341 waterptr_aer(01,itype) = p_water_a01
1342 numptr_aer(01,itype,ai_phase) = p_num_a01
1343 end if
1345 if (nsize_aer(itype) .ge. 2) then
1346 lptr_so4_aer(02,itype,ai_phase) = p_so4_a02
1347 lptr_no3_aer(02,itype,ai_phase) = p_no3_a02
1348 lptr_cl_aer(02,itype,ai_phase) = p_cl_a02
1349 lptr_msa_aer(02,itype,ai_phase) = p_msa_a02
1350 lptr_co3_aer(02,itype,ai_phase) = p_co3_a02
1351 lptr_nh4_aer(02,itype,ai_phase) = p_nh4_a02
1352 lptr_na_aer(02,itype,ai_phase) = p_na_a02
1353 lptr_ca_aer(02,itype,ai_phase) = p_ca_a02
1354 lptr_oin_aer(02,itype,ai_phase) = p_oin_a02
1355 lptr_oc_aer(02,itype,ai_phase) = p_oc_a02
1356 lptr_bc_aer(02,itype,ai_phase) = p_bc_a02
1357 hyswptr_aer(02,itype) = p_hysw_a02
1358 waterptr_aer(02,itype) = p_water_a02
1359 numptr_aer(02,itype,ai_phase) = p_num_a02
1360 end if
1362 if (nsize_aer(itype) .ge. 3) then
1363 lptr_so4_aer(03,itype,ai_phase) = p_so4_a03
1364 lptr_no3_aer(03,itype,ai_phase) = p_no3_a03
1365 lptr_cl_aer(03,itype,ai_phase) = p_cl_a03
1366 lptr_msa_aer(03,itype,ai_phase) = p_msa_a03
1367 lptr_co3_aer(03,itype,ai_phase) = p_co3_a03
1368 lptr_nh4_aer(03,itype,ai_phase) = p_nh4_a03
1369 lptr_na_aer(03,itype,ai_phase) = p_na_a03
1370 lptr_ca_aer(03,itype,ai_phase) = p_ca_a03
1371 lptr_oin_aer(03,itype,ai_phase) = p_oin_a03
1372 lptr_oc_aer(03,itype,ai_phase) = p_oc_a03
1373 lptr_bc_aer(03,itype,ai_phase) = p_bc_a03
1374 hyswptr_aer(03,itype) = p_hysw_a03
1375 waterptr_aer(03,itype) = p_water_a03
1376 numptr_aer(03,itype,ai_phase) = p_num_a03
1377 end if
1379 if (nsize_aer(itype) .ge. 4) then
1380 lptr_so4_aer(04,itype,ai_phase) = p_so4_a04
1381 lptr_no3_aer(04,itype,ai_phase) = p_no3_a04
1382 lptr_cl_aer(04,itype,ai_phase) = p_cl_a04
1383 lptr_msa_aer(04,itype,ai_phase) = p_msa_a04
1384 lptr_co3_aer(04,itype,ai_phase) = p_co3_a04
1385 lptr_nh4_aer(04,itype,ai_phase) = p_nh4_a04
1386 lptr_na_aer(04,itype,ai_phase) = p_na_a04
1387 lptr_ca_aer(04,itype,ai_phase) = p_ca_a04
1388 lptr_oin_aer(04,itype,ai_phase) = p_oin_a04
1389 lptr_oc_aer(04,itype,ai_phase) = p_oc_a04
1390 lptr_bc_aer(04,itype,ai_phase) = p_bc_a04
1391 hyswptr_aer(04,itype) = p_hysw_a04
1392 waterptr_aer(04,itype) = p_water_a04
1393 numptr_aer(04,itype,ai_phase) = p_num_a04
1394 end if
1396 if (nsize_aer(itype) .ge. 5) then
1397 lptr_so4_aer(05,itype,ai_phase) = p_so4_a05
1398 lptr_no3_aer(05,itype,ai_phase) = p_no3_a05
1399 lptr_cl_aer(05,itype,ai_phase) = p_cl_a05
1400 lptr_msa_aer(05,itype,ai_phase) = p_msa_a05
1401 lptr_co3_aer(05,itype,ai_phase) = p_co3_a05
1402 lptr_nh4_aer(05,itype,ai_phase) = p_nh4_a05
1403 lptr_na_aer(05,itype,ai_phase) = p_na_a05
1404 lptr_ca_aer(05,itype,ai_phase) = p_ca_a05
1405 lptr_oin_aer(05,itype,ai_phase) = p_oin_a05
1406 lptr_oc_aer(05,itype,ai_phase) = p_oc_a05
1407 lptr_bc_aer(05,itype,ai_phase) = p_bc_a05
1408 hyswptr_aer(05,itype) = p_hysw_a05
1409 waterptr_aer(05,itype) = p_water_a05
1410 numptr_aer(05,itype,ai_phase) = p_num_a05
1411 end if
1413 if (nsize_aer(itype) .ge. 6) then
1414 lptr_so4_aer(06,itype,ai_phase) = p_so4_a06
1415 lptr_no3_aer(06,itype,ai_phase) = p_no3_a06
1416 lptr_cl_aer(06,itype,ai_phase) = p_cl_a06
1417 lptr_msa_aer(06,itype,ai_phase) = p_msa_a06
1418 lptr_co3_aer(06,itype,ai_phase) = p_co3_a06
1419 lptr_nh4_aer(06,itype,ai_phase) = p_nh4_a06
1420 lptr_na_aer(06,itype,ai_phase) = p_na_a06
1421 lptr_ca_aer(06,itype,ai_phase) = p_ca_a06
1422 lptr_oin_aer(06,itype,ai_phase) = p_oin_a06
1423 lptr_oc_aer(06,itype,ai_phase) = p_oc_a06
1424 lptr_bc_aer(06,itype,ai_phase) = p_bc_a06
1425 hyswptr_aer(06,itype) = p_hysw_a06
1426 waterptr_aer(06,itype) = p_water_a06
1427 numptr_aer(06,itype,ai_phase) = p_num_a06
1428 end if
1430 if (nsize_aer(itype) .ge. 7) then
1431 lptr_so4_aer(07,itype,ai_phase) = p_so4_a07
1432 lptr_no3_aer(07,itype,ai_phase) = p_no3_a07
1433 lptr_cl_aer(07,itype,ai_phase) = p_cl_a07
1434 lptr_msa_aer(07,itype,ai_phase) = p_msa_a07
1435 lptr_co3_aer(07,itype,ai_phase) = p_co3_a07
1436 lptr_nh4_aer(07,itype,ai_phase) = p_nh4_a07
1437 lptr_na_aer(07,itype,ai_phase) = p_na_a07
1438 lptr_ca_aer(07,itype,ai_phase) = p_ca_a07
1439 lptr_oin_aer(07,itype,ai_phase) = p_oin_a07
1440 lptr_oc_aer(07,itype,ai_phase) = p_oc_a07
1441 lptr_bc_aer(07,itype,ai_phase) = p_bc_a07
1442 hyswptr_aer(07,itype) = p_hysw_a07
1443 waterptr_aer(07,itype) = p_water_a07
1444 numptr_aer(07,itype,ai_phase) = p_num_a07
1445 end if
1447 if (nsize_aer(itype) .ge. 8) then
1448 lptr_so4_aer(08,itype,ai_phase) = p_so4_a08
1449 lptr_no3_aer(08,itype,ai_phase) = p_no3_a08
1450 lptr_cl_aer(08,itype,ai_phase) = p_cl_a08
1451 lptr_msa_aer(08,itype,ai_phase) = p_msa_a08
1452 lptr_co3_aer(08,itype,ai_phase) = p_co3_a08
1453 lptr_nh4_aer(08,itype,ai_phase) = p_nh4_a08
1454 lptr_na_aer(08,itype,ai_phase) = p_na_a08
1455 lptr_ca_aer(08,itype,ai_phase) = p_ca_a08
1456 lptr_oin_aer(08,itype,ai_phase) = p_oin_a08
1457 lptr_oc_aer(08,itype,ai_phase) = p_oc_a08
1458 lptr_bc_aer(08,itype,ai_phase) = p_bc_a08
1459 hyswptr_aer(08,itype) = p_hysw_a08
1460 waterptr_aer(08,itype) = p_water_a08
1461 numptr_aer(08,itype,ai_phase) = p_num_a08
1462 end if
1465 #if defined ( cw_species_are_in_registry )
1466 ! this code is "active" only when cw species are in the registry
1467 if (nsize_aer(itype) .ge. 1) then
1468 if (cw_phase .gt. 0) then
1469 lptr_so4_aer(01,itype,cw_phase) = p_so4_cw01
1470 lptr_no3_aer(01,itype,cw_phase) = p_no3_cw01
1471 lptr_cl_aer(01,itype,cw_phase) = p_cl_cw01
1472 lptr_msa_aer(01,itype,cw_phase) = p_msa_cw01
1473 lptr_co3_aer(01,itype,cw_phase) = p_co3_cw01
1474 lptr_nh4_aer(01,itype,cw_phase) = p_nh4_cw01
1475 lptr_na_aer(01,itype,cw_phase) = p_na_cw01
1476 lptr_ca_aer(01,itype,cw_phase) = p_ca_cw01
1477 lptr_oin_aer(01,itype,cw_phase) = p_oin_cw01
1478 lptr_oc_aer(01,itype,cw_phase) = p_oc_cw01
1479 lptr_bc_aer(01,itype,cw_phase) = p_bc_cw01
1480 numptr_aer(01,itype,cw_phase) = p_num_cw01
1481 end if
1482 end if
1484 if (nsize_aer(itype) .ge. 2) then
1485 if (cw_phase .gt. 0) then
1486 lptr_so4_aer(02,itype,cw_phase) = p_so4_cw02
1487 lptr_no3_aer(02,itype,cw_phase) = p_no3_cw02
1488 lptr_cl_aer(02,itype,cw_phase) = p_cl_cw02
1489 lptr_msa_aer(02,itype,cw_phase) = p_msa_cw02
1490 lptr_co3_aer(02,itype,cw_phase) = p_co3_cw02
1491 lptr_nh4_aer(02,itype,cw_phase) = p_nh4_cw02
1492 lptr_na_aer(02,itype,cw_phase) = p_na_cw02
1493 lptr_ca_aer(02,itype,cw_phase) = p_ca_cw02
1494 lptr_oin_aer(02,itype,cw_phase) = p_oin_cw02
1495 lptr_oc_aer(02,itype,cw_phase) = p_oc_cw02
1496 lptr_bc_aer(02,itype,cw_phase) = p_bc_cw02
1497 numptr_aer(02,itype,cw_phase) = p_num_cw02
1498 end if
1499 end if
1501 if (nsize_aer(itype) .ge. 3) then
1502 if (cw_phase .gt. 0) then
1503 lptr_so4_aer(03,itype,cw_phase) = p_so4_cw03
1504 lptr_no3_aer(03,itype,cw_phase) = p_no3_cw03
1505 lptr_cl_aer(03,itype,cw_phase) = p_cl_cw03
1506 lptr_msa_aer(03,itype,cw_phase) = p_msa_cw03
1507 lptr_co3_aer(03,itype,cw_phase) = p_co3_cw03
1508 lptr_nh4_aer(03,itype,cw_phase) = p_nh4_cw03
1509 lptr_na_aer(03,itype,cw_phase) = p_na_cw03
1510 lptr_ca_aer(03,itype,cw_phase) = p_ca_cw03
1511 lptr_oin_aer(03,itype,cw_phase) = p_oin_cw03
1512 lptr_oc_aer(03,itype,cw_phase) = p_oc_cw03
1513 lptr_bc_aer(03,itype,cw_phase) = p_bc_cw03
1514 numptr_aer(03,itype,cw_phase) = p_num_cw03
1515 end if
1516 end if
1518 if (nsize_aer(itype) .ge. 4) then
1519 if (cw_phase .gt. 0) then
1520 lptr_so4_aer(04,itype,cw_phase) = p_so4_cw04
1521 lptr_no3_aer(04,itype,cw_phase) = p_no3_cw04
1522 lptr_cl_aer(04,itype,cw_phase) = p_cl_cw04
1523 lptr_msa_aer(04,itype,cw_phase) = p_msa_cw04
1524 lptr_co3_aer(04,itype,cw_phase) = p_co3_cw04
1525 lptr_nh4_aer(04,itype,cw_phase) = p_nh4_cw04
1526 lptr_na_aer(04,itype,cw_phase) = p_na_cw04
1527 lptr_ca_aer(04,itype,cw_phase) = p_ca_cw04
1528 lptr_oin_aer(04,itype,cw_phase) = p_oin_cw04
1529 lptr_oc_aer(04,itype,cw_phase) = p_oc_cw04
1530 lptr_bc_aer(04,itype,cw_phase) = p_bc_cw04
1531 numptr_aer(04,itype,cw_phase) = p_num_cw04
1532 end if
1533 end if
1535 if (nsize_aer(itype) .ge. 5) then
1536 if (cw_phase .gt. 0) then
1537 lptr_so4_aer(05,itype,cw_phase) = p_so4_cw05
1538 lptr_no3_aer(05,itype,cw_phase) = p_no3_cw05
1539 lptr_cl_aer(05,itype,cw_phase) = p_cl_cw05
1540 lptr_msa_aer(05,itype,cw_phase) = p_msa_cw05
1541 lptr_co3_aer(05,itype,cw_phase) = p_co3_cw05
1542 lptr_nh4_aer(05,itype,cw_phase) = p_nh4_cw05
1543 lptr_na_aer(05,itype,cw_phase) = p_na_cw05
1544 lptr_ca_aer(05,itype,cw_phase) = p_ca_cw05
1545 lptr_oin_aer(05,itype,cw_phase) = p_oin_cw05
1546 lptr_oc_aer(05,itype,cw_phase) = p_oc_cw05
1547 lptr_bc_aer(05,itype,cw_phase) = p_bc_cw05
1548 numptr_aer(05,itype,cw_phase) = p_num_cw05
1549 end if
1550 end if
1552 if (nsize_aer(itype) .ge. 6) then
1553 if (cw_phase .gt. 0) then
1554 lptr_so4_aer(06,itype,cw_phase) = p_so4_cw06
1555 lptr_no3_aer(06,itype,cw_phase) = p_no3_cw06
1556 lptr_cl_aer(06,itype,cw_phase) = p_cl_cw06
1557 lptr_msa_aer(06,itype,cw_phase) = p_msa_cw06
1558 lptr_co3_aer(06,itype,cw_phase) = p_co3_cw06
1559 lptr_nh4_aer(06,itype,cw_phase) = p_nh4_cw06
1560 lptr_na_aer(06,itype,cw_phase) = p_na_cw06
1561 lptr_ca_aer(06,itype,cw_phase) = p_ca_cw06
1562 lptr_oin_aer(06,itype,cw_phase) = p_oin_cw06
1563 lptr_oc_aer(06,itype,cw_phase) = p_oc_cw06
1564 lptr_bc_aer(06,itype,cw_phase) = p_bc_cw06
1565 numptr_aer(06,itype,cw_phase) = p_num_cw06
1566 end if
1567 end if
1569 if (nsize_aer(itype) .ge. 7) then
1570 if (cw_phase .gt. 0) then
1571 lptr_so4_aer(07,itype,cw_phase) = p_so4_cw07
1572 lptr_no3_aer(07,itype,cw_phase) = p_no3_cw07
1573 lptr_cl_aer(07,itype,cw_phase) = p_cl_cw07
1574 lptr_msa_aer(07,itype,cw_phase) = p_msa_cw07
1575 lptr_co3_aer(07,itype,cw_phase) = p_co3_cw07
1576 lptr_nh4_aer(07,itype,cw_phase) = p_nh4_cw07
1577 lptr_na_aer(07,itype,cw_phase) = p_na_cw07
1578 lptr_ca_aer(07,itype,cw_phase) = p_ca_cw07
1579 lptr_oin_aer(07,itype,cw_phase) = p_oin_cw07
1580 lptr_oc_aer(07,itype,cw_phase) = p_oc_cw07
1581 lptr_bc_aer(07,itype,cw_phase) = p_bc_cw07
1582 numptr_aer(07,itype,cw_phase) = p_num_cw07
1583 end if
1584 end if
1586 if (nsize_aer(itype) .ge. 8) then
1587 if (cw_phase .gt. 0) then
1588 lptr_so4_aer(08,itype,cw_phase) = p_so4_cw08
1589 lptr_no3_aer(08,itype,cw_phase) = p_no3_cw08
1590 lptr_cl_aer(08,itype,cw_phase) = p_cl_cw08
1591 lptr_msa_aer(08,itype,cw_phase) = p_msa_cw08
1592 lptr_co3_aer(08,itype,cw_phase) = p_co3_cw08
1593 lptr_nh4_aer(08,itype,cw_phase) = p_nh4_cw08
1594 lptr_na_aer(08,itype,cw_phase) = p_na_cw08
1595 lptr_ca_aer(08,itype,cw_phase) = p_ca_cw08
1596 lptr_oin_aer(08,itype,cw_phase) = p_oin_cw08
1597 lptr_oc_aer(08,itype,cw_phase) = p_oc_cw08
1598 lptr_bc_aer(08,itype,cw_phase) = p_bc_cw08
1599 numptr_aer(08,itype,cw_phase) = p_num_cw08
1600 end if
1601 end if
1602 #endif
1605 !
1606 ! define the massptr_aer and mastercompptr_aer pointers
1607 ! and the name() species names
1608 !
1610 ! first initialize
1611 do l = 1, l2maxd
1612 write( name(l), '(a,i4.4,15x)' ) 'r', l
1613 end do
1614 massptr_aer(:,:,:,:) = -999888777
1615 mastercompptr_aer(:,:) = -999888777
1617 do 2800 itype = 1, ntype_aer
1619 if (itype .eq. 1) then
1620 typetxt = ' '
1621 ntypetxt = 1
1622 if (ntype_aer .gt. 1) then
1623 typetxt = '_t1'
1624 ntypetxt = 3
1625 end if
1626 else if (itype .le. 9) then
1627 write(typetxt,'(a,i1)') '_t', itype
1628 ntypetxt = 3
1629 else if (itype .le. 99) then
1630 write(typetxt,'(a,i2)') '_t', itype
1631 ntypetxt = 4
1632 else
1633 typetxt = '_t?'
1634 ntypetxt = 3
1635 end if
1637 ncomp_dum(:,:) = 0
1638 ncomp_plustracer_dum(:,:) = 0
1640 do 2700 isize = 1, nsize_aer(itype)
1641 n =isize
1643 if (isize .le. 9) then
1644 write(sizetxt,'(i1)') isize
1645 nsizetxt = 1
1646 else if (isize .le. 99) then
1647 write(sizetxt,'(i2)') isize
1648 nsizetxt = 2
1649 else if (isize .le. 999) then
1650 write(sizetxt,'(i3)') isize
1651 nsizetxt = 3
1652 else
1653 sizetxt = 's?'
1654 nsizetxt = 2
1655 end if
1658 do 2600 iphase = 1, nphase_aer
1660 if (iphase .eq. ai_phase) then
1661 phasetxt = 'a'
1662 nphasetxt = 1
1663 else if (iphase .eq. cw_phase) then
1664 phasetxt = 'cw'
1665 nphasetxt = 2
1666 else
1667 phasetxt = 'p?'
1668 nphasetxt = 2
1669 end if
1672 do 2500 l_mastercomp = -2, ntot_mastercomp_aer
1674 iaddto_ncomp = 1
1675 iaddto_ncomp_plustracer = 1
1677 if (l_mastercomp .eq. -2) then
1678 iaddto_ncomp = 0
1679 iaddto_ncomp_plustracer = 0
1680 lptr_dum = numptr_aer(n,itype,iphase)
1681 mcindx_dum = -2
1682 spectxt = 'numb_'
1683 nspectxt = 5
1685 else if (l_mastercomp .eq. -1) then
1686 if (iphase .ne. ai_phase) goto 2500
1687 iaddto_ncomp = 0
1688 iaddto_ncomp_plustracer = 0
1689 lptr_dum = waterptr_aer(n,itype)
1690 mcindx_dum = -1
1691 spectxt = 'water_'
1692 nspectxt = 6
1694 else if (l_mastercomp .eq. 0) then
1695 if (iphase .ne. ai_phase) goto 2500
1696 iaddto_ncomp = 0
1697 iaddto_ncomp_plustracer = 0
1698 lptr_dum = hyswptr_aer(n,itype)
1699 mcindx_dum = 0
1700 spectxt = 'hysw_'
1701 nspectxt = 5
1703 else if (l_mastercomp .eq. mastercompindx_so4_aer) then
1704 lptr_dum = lptr_so4_aer(n,itype,iphase)
1705 mcindx_dum = mastercompindx_so4_aer
1706 spectxt = 'so4_'
1707 nspectxt = 4
1709 else if (l_mastercomp .eq. mastercompindx_no3_aer) then
1710 lptr_dum = lptr_no3_aer(n,itype,iphase)
1711 mcindx_dum = mastercompindx_no3_aer
1712 spectxt = 'no3_'
1713 nspectxt = 4
1715 else if (l_mastercomp .eq. mastercompindx_cl_aer) then
1716 lptr_dum = lptr_cl_aer(n,itype,iphase)
1717 mcindx_dum = mastercompindx_cl_aer
1718 spectxt = 'cl_'
1719 nspectxt = 3
1721 else if (l_mastercomp .eq. mastercompindx_msa_aer) then
1722 lptr_dum = lptr_msa_aer(n,itype,iphase)
1723 mcindx_dum = mastercompindx_msa_aer
1724 spectxt = 'msa_'
1725 nspectxt = 4
1727 else if (l_mastercomp .eq. mastercompindx_co3_aer) then
1728 lptr_dum = lptr_co3_aer(n,itype,iphase)
1729 mcindx_dum = mastercompindx_co3_aer
1730 spectxt = 'co3_'
1731 nspectxt = 4
1733 else if (l_mastercomp .eq. mastercompindx_nh4_aer) then
1734 lptr_dum = lptr_nh4_aer(n,itype,iphase)
1735 mcindx_dum = mastercompindx_nh4_aer
1736 spectxt = 'nh4_'
1737 nspectxt = 4
1739 else if (l_mastercomp .eq. mastercompindx_na_aer) then
1740 lptr_dum = lptr_na_aer(n,itype,iphase)
1741 mcindx_dum = mastercompindx_na_aer
1742 spectxt = 'na_'
1743 nspectxt = 3
1745 else if (l_mastercomp .eq. mastercompindx_ca_aer) then
1746 lptr_dum = lptr_ca_aer(n,itype,iphase)
1747 mcindx_dum = mastercompindx_ca_aer
1748 spectxt = 'ca_'
1749 nspectxt = 3
1751 else if (l_mastercomp .eq. mastercompindx_oin_aer) then
1752 lptr_dum = lptr_oin_aer(n,itype,iphase)
1753 mcindx_dum = mastercompindx_oin_aer
1754 spectxt = 'oin_'
1755 nspectxt = 4
1757 else if (l_mastercomp .eq. mastercompindx_oc_aer) then
1758 lptr_dum = lptr_oc_aer(n,itype,iphase)
1759 mcindx_dum = mastercompindx_oc_aer
1760 spectxt = 'oc_'
1761 nspectxt = 3
1763 else if (l_mastercomp .eq. mastercompindx_bc_aer) then
1764 lptr_dum = lptr_bc_aer(n,itype,iphase)
1765 mcindx_dum = mastercompindx_bc_aer
1766 spectxt = 'bc_'
1767 nspectxt = 3
1769 else
1770 goto 2500
1771 end if
1774 if (lptr_dum .gt. lmaxd) then
1775 ! rce 2005-mar-14 - added check for lptr_dum > lmaxd
1776 write( msg, '(a,3(1x,i4))' ) 'itype, isize, iphase =', &
1777 itype, isize, iphase
1778 call peg_message( lunout, msg )
1779 write( msg, '(a,3(1x,i4))' ) 'l_mastercomp, lptr_dum, lmaxd =', &
1780 l_mastercomp, lptr_dum, lmaxd
1781 call peg_message( lunout, msg )
1782 msg = '*** subr init_data_mosaic_ptr error - lptr_dum > lmaxd'
1783 call peg_error_fatal( lunerr, msg )
1785 else if (lptr_dum .ge. p1st) then
1787 ncomp_dum(isize,iphase) = ncomp_dum(isize,iphase) + iaddto_ncomp
1788 ncomp_plustracer_dum(isize,iphase) = &
1789 ncomp_plustracer_dum(isize,iphase) + iaddto_ncomp_plustracer
1791 name(lptr_dum) = &
1792 spectxt(1:nspectxt) // phasetxt(1:nphasetxt) // &
1793 sizetxt(1:nsizetxt) // typetxt(1:ntypetxt)
1795 if (l_mastercomp .eq. -2) then
1796 ! (numptr_aer is already set)
1797 mprognum_aer(n,itype,iphase) = 1
1799 else if (l_mastercomp .eq. -1) then
1800 ! (waterptr_aer is already set)
1801 continue
1803 else if (l_mastercomp .eq. 0) then
1804 ! (hyswptr_aer is already set)
1805 continue
1807 else if (l_mastercomp .gt. 0) then
1808 ll = ncomp_plustracer_dum(isize,iphase)
1809 massptr_aer(ll,n,itype,iphase) = lptr_dum
1810 mastercompptr_aer(ll,itype) = mcindx_dum
1812 name_aer(ll,itype) = name_mastercomp_aer(mcindx_dum)
1813 dens_aer(ll,itype) = dens_mastercomp_aer(mcindx_dum)
1814 mw_aer(ll,itype) = mw_mastercomp_aer(mcindx_dum)
1815 hygro_aer(ll,itype) = hygro_mastercomp_aer(mcindx_dum)
1817 end if
1819 end if
1821 2500 continue ! l_mastercomp = -1, ntot_mastercomp_aer
1823 2600 continue ! iphase = 1, nphase_aer
1825 2700 continue ! isize = 1, nsize_aer(itype)
1828 ! now set ncomp_aer and ncomp_plustracer_aer,
1829 ! *** and check that the values computed for each size and phase all match
1830 ncomp_aer(itype) = ncomp_dum(1,ai_phase)
1831 ncomp_plustracer_aer(itype) = ncomp_plustracer_dum(1,ai_phase)
1833 do iphase = 1, nphase_aer
1834 do isize = 1, nsize_aer(itype)
1835 if (ncomp_aer(itype) .ne. ncomp_dum(isize,iphase)) then
1836 msg = '*** subr init_data_mosaic_ptr - ' // &
1837 'ncomp_aer .ne. ncomp_dum'
1838 call peg_message( lunerr, msg )
1839 write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase
1840 call peg_message( lunerr, msg )
1841 write(msg,9350) 'ncomp_aer, ncomp_dum =', &
1842 ncomp_aer(itype), ncomp_dum(isize,iphase)
1843 call peg_error_fatal( lunerr, msg )
1844 end if
1845 if (ncomp_plustracer_aer(itype) .ne. &
1846 ncomp_plustracer_dum(isize,iphase)) then
1847 msg = '*** subr init_data_mosaic_ptr - ' // &
1848 'ncomp_plustracer_aer .ne. ncomp_plustracer_dum'
1849 call peg_message( lunerr, msg )
1850 write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase
1851 call peg_message( lunerr, msg )
1852 write(msg,9350) &
1853 'ncomp_plustracer_aer, ncomp_plustracer_dum =', &
1854 ncomp_plustracer_aer(itype), &
1855 ncomp_plustracer_dum(isize,iphase)
1856 call peg_error_fatal( lunerr, msg )
1857 end if
1858 end do
1859 end do
1862 2800 continue ! itype = 1, ntype_aer
1865 9320 format( a, i1, i1, a, 8x )
1867 !
1868 ! output wrfch pointers
1869 !
1870 9350 format( a, 32(1x,i4) )
1871 msg = ' '
1872 call peg_message( lunout, msg )
1873 msg = 'output from subr init_data_mosaic_ptr'
1874 call peg_message( lunout, msg )
1875 write(msg,9350) 'nphase_aer = ', nphase_aer
1876 call peg_message( lunout, msg )
1878 do iphase=1,nphase_aer
1880 write(msg,9350) 'iphase = ', iphase
1881 call peg_message( lunout, msg )
1882 write(msg,9350) 'ntype_aer = ', ntype_aer
1883 call peg_message( lunout, msg )
1885 do itype=1,ntype_aer
1887 write(msg,9350) 'itype = ', itype
1888 call peg_message( lunout, msg )
1889 write(msg,9350) 'nsize_aer = ', nsize_aer(itype)
1890 call peg_message( lunout, msg )
1891 write(msg,9350) 'lptr_so4_aer ', &
1892 (lptr_so4_aer(n,itype,iphase), n=1,nsize_aer(itype))
1893 call peg_message( lunout, msg )
1894 write(msg,9350) 'lptr_no3_aer ', &
1895 (lptr_no3_aer(n,itype,iphase), n=1,nsize_aer(itype))
1896 call peg_message( lunout, msg )
1897 write(msg,9350) 'lptr_cl_aer ', &
1898 (lptr_cl_aer(n,itype,iphase), n=1,nsize_aer(itype))
1899 call peg_message( lunout, msg )
1900 write(msg,9350) 'lptr_msa_aer ', &
1901 (lptr_msa_aer(n,itype,iphase), n=1,nsize_aer(itype))
1902 call peg_message( lunout, msg )
1903 write(msg,9350) 'lptr_co3_aer ', &
1904 (lptr_co3_aer(n,itype,iphase), n=1,nsize_aer(itype))
1905 call peg_message( lunout, msg )
1906 write(msg,9350) 'lptr_nh4_aer ', &
1907 (lptr_nh4_aer(n,itype,iphase), n=1,nsize_aer(itype))
1908 call peg_message( lunout, msg )
1909 write(msg,9350) 'lptr_na_aer ', &
1910 (lptr_na_aer(n,itype,iphase), n=1,nsize_aer(itype))
1911 call peg_message( lunout, msg )
1912 write(msg,9350) 'lptr_ca_aer ', &
1913 (lptr_ca_aer(n,itype,iphase), n=1,nsize_aer(itype))
1914 call peg_message( lunout, msg )
1915 write(msg,9350) 'lptr_oin_aer ', &
1916 (lptr_oin_aer(n,itype,iphase), n=1,nsize_aer(itype))
1917 call peg_message( lunout, msg )
1918 write(msg,9350) 'lptr_oc_aer ', &
1919 (lptr_oc_aer(n,itype,iphase), n=1,nsize_aer(itype))
1920 call peg_message( lunout, msg )
1921 write(msg,9350) 'lptr_bc_aer ', &
1922 (lptr_bc_aer(n,itype,iphase), n=1,nsize_aer(itype))
1923 call peg_message( lunout, msg )
1924 write(msg,9350) 'hyswptr_aer', &
1925 (hyswptr_aer(n,itype), n=1,nsize_aer(itype))
1926 call peg_message( lunout, msg )
1927 write(msg,9350) 'waterptr_aer ', &
1928 (waterptr_aer(n,itype), n=1,nsize_aer(itype))
1929 call peg_message( lunout, msg )
1930 write(msg,9350) 'numptr_aer ', &
1931 (numptr_aer(n,itype,iphase), n=1,nsize_aer(itype))
1932 call peg_message( lunout, msg )
1935 do ll = 1, ncomp_plustracer_aer(itype)
1936 write(msg,9350) 'massptr_aer(), ll', &
1937 (massptr_aer(ll,n,itype,iphase), n=1,nsize_aer(itype)), ll
1938 call peg_message( lunout, msg )
1939 end do
1940 end do ! type
1941 end do ! phase
1943 !
1944 ! check aerosol species pointers for "validity"
1945 !
1946 do iphase=1,nphase_aer
1947 do itype=1,ntype_aer
1948 y_so4 = 0
1949 y_no3 = 0
1950 y_cl = 0
1951 y_msa = 0
1952 y_co3 = 0
1953 y_nh4 = 0
1954 y_na = 0
1955 y_ca = 0
1956 y_oin = 0
1957 y_oc = 0
1958 y_bc = 0
1959 y_hysw = 0
1960 y_water = 0
1961 y_num = 0
1963 do n = 1, nsize_aer(itype)
1964 if (lptr_so4_aer(n,itype,iphase) .ge. p1st) y_so4 = y_so4 + 1
1965 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) y_no3 = y_no3 + 1
1966 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) y_cl = y_cl + 1
1967 if (lptr_msa_aer(n,itype,iphase) .ge. p1st) y_msa = y_msa + 1
1968 if (lptr_co3_aer(n,itype,iphase) .ge. p1st) y_co3 = y_co3 + 1
1969 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) y_nh4 = y_nh4 + 1
1970 if (lptr_na_aer(n,itype,iphase) .ge. p1st) y_na = y_na + 1
1971 if (lptr_ca_aer(n,itype,iphase) .ge. p1st) y_ca = y_ca + 1
1972 if (lptr_oin_aer(n,itype,iphase) .ge. p1st) y_oin = y_oin + 1
1973 if (lptr_oc_aer(n,itype,iphase) .ge. p1st) y_oc = y_oc + 1
1974 if (lptr_bc_aer(n,itype,iphase) .ge. p1st) y_bc = y_bc + 1
1975 if (hyswptr_aer(n,itype) .ge. p1st) y_hysw = y_hysw + 1
1976 if (waterptr_aer(n,itype) .ge. p1st) y_water = y_water + 1
1977 if (numptr_aer(n,itype,iphase) .ge. p1st) y_num = y_num + 1
1979 end do
1981 ! these must be defined for all aerosol bins
1982 if (y_so4 .ne. nsize_aer(itype)) then
1983 msg = '*** subr init_data_mosaic_ptr - ptr error for so4'
1984 call peg_message( lunerr, msg )
1985 write(msg,9350) 'phase, type=', iphase,itype
1986 call peg_error_fatal( lunerr, msg )
1987 else if (y_water .ne. nsize_aer(itype)) then
1988 msg = '*** subr init_data_mosaic_ptr - ptr error for water'
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_num .ne. nsize_aer(itype)) then
1993 msg = '*** subr init_data_mosaic_ptr - ptr error for num'
1994 call peg_message( lunerr, msg )
1995 write(msg,9350) 'phase, type=', iphase,itype
1996 call peg_error_fatal( lunerr, msg )
1997 end if
2000 ! these must be defined for all aerosol bins
2001 ! or else undefined for all aerosol bins
2002 if ((y_no3 .ne. 0) .and. &
2003 (y_no3 .ne. nsize_aer(itype))) then
2004 msg = '*** subr init_data_mosaic_ptr - ptr error for no3'
2005 call peg_message( lunerr, msg )
2006 write(msg,9350) 'phase, type=', iphase,itype
2007 call peg_error_fatal( lunerr, msg )
2008 else if ((y_cl .ne. 0) .and. &
2009 (y_cl .ne. nsize_aer(itype))) then
2010 msg = '*** subr init_data_mosaic_ptr - ptr error for cl'
2011 call peg_message( lunerr, msg )
2012 write(msg,9350) 'phase, type=', iphase,itype
2013 call peg_error_fatal( lunerr, msg )
2014 else if ((y_msa .ne. 0) .and. &
2015 (y_msa .ne. nsize_aer(itype))) then
2016 msg = '*** subr init_data_mosaic_ptr - ptr error for msa'
2017 call peg_message( lunerr, msg )
2018 write(msg,9350) 'phase, type=', iphase,itype
2019 call peg_error_fatal( lunerr, msg )
2020 else if ((y_co3 .ne. 0) .and. &
2021 (y_co3 .ne. nsize_aer(itype))) then
2022 msg = '*** subr init_data_mosaic_ptr - ptr error for co3'
2023 call peg_message( lunerr, msg )
2024 write(msg,9350) 'phase, type=', iphase,itype
2025 call peg_error_fatal( lunerr, msg )
2026 else if ((y_nh4 .ne. 0) .and. &
2027 (y_nh4 .ne. nsize_aer(itype))) then
2028 msg = '*** subr init_data_mosaic_ptr - ptr error for nh4'
2029 call peg_message( lunerr, msg )
2030 write(msg,9350) 'phase, type=', iphase,itype
2031 call peg_error_fatal( lunerr, msg )
2032 else if ((y_na .ne. 0) .and. &
2033 (y_na .ne. nsize_aer(itype))) then
2034 msg = '*** subr init_data_mosaic_ptr - ptr error for na'
2035 call peg_message( lunerr, msg )
2036 write(msg,9350) 'phase, type=', iphase,itype
2037 call peg_error_fatal( lunerr, msg )
2038 else if ((y_ca .ne. 0) .and. &
2039 (y_ca .ne. nsize_aer(itype))) then
2040 msg = '*** subr init_data_mosaic_ptr - ptr error for ca'
2041 call peg_message( lunerr, msg )
2042 write(msg,9350) 'phase, type=', iphase,itype
2043 call peg_error_fatal( lunerr, msg )
2044 else if ((y_oin .ne. 0) .and. &
2045 (y_oin .ne. nsize_aer(itype))) then
2046 msg = '*** subr init_data_mosaic_ptr - ptr error for oin'
2047 call peg_message( lunerr, msg )
2048 write(msg,9350) 'phase, type=', iphase,itype
2049 call peg_error_fatal( lunerr, msg )
2050 else if ((y_oc .ne. 0) .and. &
2051 (y_oc .ne. nsize_aer(itype))) then
2052 msg = '*** subr init_data_mosaic_ptr - ptr error for oc'
2053 call peg_message( lunerr, msg )
2054 write(msg,9350) 'phase, type=', iphase,itype
2055 call peg_error_fatal( lunerr, msg )
2056 else if ((y_bc .ne. 0) .and. &
2057 (y_bc .ne. nsize_aer(itype))) then
2058 msg = '*** subr init_data_mosaic_ptr - ptr error for bc'
2059 call peg_message( lunerr, msg )
2060 write(msg,9350) 'phase, type=', iphase,itype
2061 call peg_error_fatal( lunerr, msg )
2062 else if ((y_hysw .ne. 0) .and. &
2063 (y_hysw .ne. nsize_aer(itype))) then
2064 msg = '*** subr init_data_mosaic_ptr - ptr error for hysw'
2065 call peg_message( lunerr, msg )
2066 write(msg,9350) 'phase, type=', iphase,itype
2067 call peg_error_fatal( lunerr, msg )
2068 end if
2070 enddo ! type
2071 enddo ! phase
2072 !
2073 ! set pointers for gases
2074 ! rce 2004-dec-02 - gases not required to be present
2075 !
2076 if (p_sulf .ge. p1st) then
2077 kh2so4 = p_sulf
2078 ! else
2079 ! msg = '*** subr init_data_mosaic_ptr - ptr error for h2so4'
2080 ! call peg_error_fatal( lunerr, msg )
2081 end if
2082 if (p_hno3 .ge. p1st) then
2083 khno3 = p_hno3
2084 ! else
2085 ! msg = '*** subr init_data_mosaic_ptr - ptr error for hno3'
2086 ! call peg_error_fatal( lunerr, msg )
2087 end if
2088 if (p_hcl .ge. p1st) then
2089 khcl = p_hcl
2090 ! else
2091 ! msg = '*** subr init_data_mosaic_ptr - ptr error for hcl'
2092 ! call peg_error_fatal( lunerr, msg )
2093 end if
2094 if (p_nh3 .ge. p1st) then
2095 knh3 = p_nh3
2096 ! else
2097 ! msg = '*** subr init_data_mosaic_ptr - ptr error for nh3'
2098 ! call peg_error_fatal( lunerr, msg )
2099 end if
2100 if (p_o3 .ge. p1st) then
2101 ko3 = p_o3
2102 ! else
2103 ! msg = '*** subr init_data_mosaic_ptr - ptr error for o3'
2104 ! call peg_error_fatal( lunerr, msg )
2105 end if
2107 ! rce 2005-apr-12 - added following species for cldchem, here and below:
2108 ! kso2, kh2o2, khcho, khcooh, koh, kho2,
2109 ! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh
2110 if (p_so2 .ge. p1st) kso2 = p_so2
2111 if (p_h2o2 .ge. p1st) kh2o2 = p_h2o2
2112 if (p_hcho .ge. p1st) khcho = p_hcho
2113 if (p_ora1 .ge. p1st) khcooh = p_ora1
2114 if (p_ho .ge. p1st) koh = p_ho
2115 if (p_ho2 .ge. p1st) kho2 = p_ho2
2116 if (p_no3 .ge. p1st) kno3 = p_no3
2117 if (p_no .ge. p1st) kno = p_no
2118 if (p_no2 .ge. p1st) kno2 = p_no2
2119 if (p_hono .ge. p1st) khono = p_hono
2120 if (p_pan .ge. p1st) kpan = p_pan
2121 if (p_ch3o2 .ge. p1st) kch3o2 = p_ch3o2
2122 if (p_ch3oh .ge. p1st) kch3oh = p_ch3oh
2123 if (p_op1 .ge. p1st) kch3ooh = p_op1
2125 !
2126 ! calc ltot, ltot2, kh2o, ktemp
2127 !
2128 is_aerosol(:) = .false.
2129 ltot = 0
2130 ltot = max( ltot, kh2so4 )
2131 ltot = max( ltot, khno3 )
2132 ltot = max( ltot, khcl )
2133 ltot = max( ltot, knh3 )
2134 ltot = max( ltot, ko3 )
2135 ltot = max( ltot, kso2 )
2136 ltot = max( ltot, kh2o2 )
2137 ltot = max( ltot, khcho )
2138 ltot = max( ltot, khcooh )
2139 ltot = max( ltot, koh )
2140 ltot = max( ltot, kho2 )
2141 ltot = max( ltot, kno3 )
2142 ltot = max( ltot, kno )
2143 ltot = max( ltot, kno2 )
2144 ltot = max( ltot, khono )
2145 ltot = max( ltot, kpan )
2146 ltot = max( ltot, kch3o2 )
2147 ltot = max( ltot, kch3oh )
2148 ltot = max( ltot, kch3ooh )
2149 do iphase=1,nphase_aer
2150 do itype=1,ntype_aer
2151 do n = 1, nsize_aer(itype)
2152 do ll = 1, ncomp_plustracer_aer(itype)
2153 ltot = max( ltot, massptr_aer(ll,n,itype,iphase) )
2154 is_aerosol(massptr_aer(ll,n,itype,iphase))=.true.
2155 end do
2156 ltot = max( ltot, hyswptr_aer(n,itype) )
2157 ltot = max( ltot, waterptr_aer(n,itype) )
2158 ltot = max( ltot, numptr_aer(n,itype,iphase) )
2159 l = hyswptr_aer(n,itype)
2160 if (l .ge. p1st) is_aerosol(l)=.true.
2161 l = waterptr_aer(n,itype)
2162 if (l .ge. p1st) is_aerosol(l)=.true.
2163 l = numptr_aer(n,itype,iphase)
2164 if (l .ge. p1st) is_aerosol(l)=.true.
2165 end do
2166 end do
2167 end do
2169 kh2o = ltot + 1
2170 ktemp = ltot + 2
2171 ltot2 = ktemp
2173 write( msg, '(a,4(1x,i4))' ) 'ltot, ltot2, lmaxd, l2maxd =', &
2174 ltot, ltot2, lmaxd, l2maxd
2175 call peg_message( lunout, msg )
2176 if ((ltot .gt. lmaxd) .or. (ltot2 .gt. l2maxd)) then
2177 msg = '*** subr init_data_mosaic_ptr - ltot/ltot2 too big'
2178 call peg_error_fatal( lunerr, msg )
2179 end if
2181 if (p_sulf .ge. p1st) name(kh2so4 ) = 'h2so4'
2182 if (p_hno3 .ge. p1st) name(khno3 ) = 'hno3'
2183 if (p_hcl .ge. p1st) name(khcl ) = 'hcl'
2184 if (p_nh3 .ge. p1st) name(knh3 ) = 'nh3'
2185 if (p_o3 .ge. p1st) name(ko3 ) = 'o3'
2186 if (p_so2 .ge. p1st) name(kso2 ) = 'so2'
2187 if (p_h2o2 .ge. p1st) name(kh2o2 ) = 'h2o2'
2188 if (p_hcho .ge. p1st) name(khcho ) = 'hcho'
2189 if (p_ora1 .ge. p1st) name(khcooh ) = 'hcooh'
2190 if (p_ho .ge. p1st) name(koh ) = 'oh'
2191 if (p_ho2 .ge. p1st) name(kho2 ) = 'ho2'
2192 if (p_no3 .ge. p1st) name(kno3 ) = 'no3'
2193 if (p_no .ge. p1st) name(kno ) = 'no'
2194 if (p_no2 .ge. p1st) name(kno2 ) = 'no2'
2195 if (p_hono .ge. p1st) name(khono ) = 'hono'
2196 if (p_pan .ge. p1st) name(kpan ) = 'pan'
2197 if (p_ch3o2 .ge. p1st) name(kch3o2 ) = 'ch3o2'
2198 if (p_ch3oh .ge. p1st) name(kch3oh ) = 'ch3oh'
2199 if (p_op1 .ge. p1st) name(kch3ooh) = 'ch3ooh'
2200 name(ktemp) = 'temp'
2201 name(kh2o) = 'h2o'
2203 call initwet( &
2204 ntype_aer, nsize_aer, ncomp_aer, &
2205 massptr_aer, dens_aer, numptr_aer, &
2206 maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, &
2207 dcen_sect, sigmag_aer, &
2208 waterptr_aer, dens_water_aer, &
2209 scavimptblvol, scavimptblnum, nimptblgrow_mind, &
2210 nimptblgrow_maxd, dlndg_nimptblgrow)
2212 return
2213 end subroutine init_data_mosaic_ptr
2216 !-----------------------------------------------------------------------
2217 subroutine aerchem_debug_dump( &
2218 iflag, iclm, jclm, dtchem )
2220 use module_data_mosaic_asect
2221 use module_data_mosaic_other
2222 implicit none
2224 ! include 'v33com'
2225 ! include 'v33com2'
2226 ! include 'v33com9a'
2228 integer iflag, iclm, jclm
2229 real dtchem
2231 ! local variables
2232 integer ientryno
2233 save ientryno
2234 integer iphase, itype, k, l, m, n
2236 real dtchem_sv1
2237 save dtchem_sv1
2238 real rsub_sv1(l2maxd,kmaxd,nsubareamaxd)
2240 data ientryno / -13579 /
2243 ! check for bypass based on some control variable ?
2246 ! do initial output when ientryno = -13579
2247 if (ientryno .ne. -13579) goto 1000
2249 ientryno = +1
2251 95010 format( a )
2252 95020 format( 8( 1x, i8 ) )
2253 95030 format( 4( 1pe18.10 ) )
2255 print 95010, 'aerchem_debug_dump start'
2256 print 95020, ltot, ltot2, itot, jtot, ktot
2257 print 95010, (name(l), l=1,ltot2)
2259 print 95020, maerocoag, maerchem, maeroptical
2260 print 95020, msectional, maerosolincw
2261 do iphase = 1, nphase_aer
2262 do itype=1,ntype_aer
2263 print 95020, iphase, itype, nsize_aer(itype), &
2264 ncomp_plustracer_aer(itype)
2266 do n = 1, ncomp_plustracer_aer(itype)
2267 print 95010, &
2268 name_aer(n,itype)
2269 print 95030, &
2270 dens_aer(n,itype), mw_aer(n,itype)
2271 end do
2273 do n = 1, nsize_aer(itype)
2274 print 95020, &
2275 ncomp_plustracer_aer(n), ncomp_aer(n), &
2276 waterptr_aer(n,itype), numptr_aer(n,itype,iphase), &
2277 mprognum_aer(n,itype,iphase)
2278 print 95020, &
2279 (mastercompptr_aer(l,itype), massptr_aer(l,n,itype,iphase), &
2280 l=1,ncomp_plustracer_aer(itype))
2281 print 95030, &
2282 volumcen_sect(n,itype), volumlo_sect(n,itype), &
2283 volumhi_sect(n,itype), dcen_sect(n,itype), &
2284 dlo_sect(n,itype), dhi_sect(n,itype)
2285 print 95020, &
2286 lptr_so4_aer(n,itype,iphase), lptr_msa_aer(n,itype,iphase), &
2287 lptr_no3_aer(n,itype,iphase), lptr_cl_aer(n,itype,iphase), &
2288 lptr_co3_aer(n,itype,iphase), lptr_nh4_aer(n,itype,iphase), &
2289 lptr_na_aer(n,itype,iphase), lptr_ca_aer(n,itype,iphase), &
2290 lptr_oin_aer(n,itype,iphase), lptr_oc_aer(n,itype,iphase), &
2291 lptr_bc_aer(n,itype,iphase), hyswptr_aer(n,itype)
2292 end do ! size
2293 end do ! type
2294 end do ! phase
2295 print 95010, 'aerchem_debug_dump end'
2297 !
2298 ! test iflag
2299 !
2300 1000 continue
2301 if (iflag .eq. 1) goto 1010
2302 if (iflag .eq. 2) goto 2000
2303 if (iflag .eq. 3) goto 3000
2304 return
2306 !
2307 ! iflag=1 -- save initial values
2308 ! AND FOR NOW do output too
2309 !
2310 1010 continue
2311 dtchem_sv1 = dtchem
2312 do m = 1, nsubareas
2313 do k = 1, ktot
2314 do l = 1, ltot2
2315 rsub_sv1(l,k,m) = rsub(l,k,m)
2316 end do
2317 end do
2318 end do
2320 print 95010, 'aerchem_debug_dump start'
2321 do m = 1, nsubareas
2322 do k = 1, ktot
2323 print 95020, iymdcur, ihmscur, &
2324 iclm, jclm, k, m, nsubareas, iflag
2325 print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), &
2326 ptotclm(k), afracsubarea(k,m)
2327 print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2)
2328 end do
2329 end do
2330 print 95010, 'aerchem_debug_dump end'
2332 return
2334 !
2335 ! iflag=2 -- save intermediate values before doing move_sections
2336 ! (this is deactivated for now)
2337 !
2338 2000 continue
2339 return
2342 !
2343 ! iflag=3 -- do output
2344 !
2345 3000 continue
2346 print 95010, 'aerchem_debug_dump start'
2347 do m = 1, nsubareas
2348 do k = 1, ktot
2349 print 95020, iymdcur, ihmscur, &
2350 iclm, jclm, k, m, nsubareas, iflag
2351 print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), &
2352 ptotclm(k), afracsubarea(k,m)
2353 print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2)
2354 end do
2355 end do
2356 print 95010, 'aerchem_debug_dump end'
2359 return
2360 end subroutine aerchem_debug_dump
2364 !-----------------------------------------------------------------------
2365 end module module_mosaic_driver