Line data Source code
1 : ! modal_aero_rename.F90
2 : !----------------------------------------------------------------------
3 : !BOP
4 : !
5 : ! !MODULE: modal_aero_rename --- modal aerosol mode merging (renaming)
6 : !
7 : ! !INTERFACE:
8 : module modal_aero_rename
9 :
10 : ! !USES:
11 : use shr_kind_mod, only: r8 => shr_kind_r8
12 : use cam_abortutils, only: endrun
13 : use cam_logfile, only: iulog
14 : use mo_constants, only: pi
15 : use chem_mods, only: gas_pcnst
16 : use ppgrid, only: pcols, pver
17 : use constituents, only: pcnst, cnst_name
18 : use spmd_utils, only: masterproc
19 : use modal_aero_data, only: maxspec_renamexf=>nspec_max, ntot_amode
20 : use modal_aero_data, only: alnsg_amode, voltonumblo_amode, voltonumbhi_amode, dgnum_amode, nspec_amode
21 : use modal_aero_data, only: specmw_amode, specdens_amode, lmassptr_amode, lmassptrcw_amode
22 : use modal_aero_data, only: numptr_amode, numptrcw_amode, modeptr_coarse, modeptr_accum
23 : use modal_aero_data, only: modeptr_stracoar
24 : use modal_aero_data, only: specmw_amode, specdens_amode, lmassptr_amode, lmassptrcw_amode, numptr_amode, numptrcw_amode
25 : use modal_aero_data, only: dgnumhi_amode, dgnumlo_amode, cnst_name_cw, modeptr_aitken
26 : use rad_constituents,only: rad_cnst_get_mode_idx
27 :
28 : implicit none
29 : private
30 : save
31 :
32 : ! !PUBLIC MEMBER FUNCTIONS:
33 : public modal_aero_rename_sub, modal_aero_rename_init
34 :
35 : ! !PUBLIC DATA MEMBERS:
36 : integer, parameter :: pcnstxx = gas_pcnst
37 :
38 : integer, parameter, public :: maxpair_renamexf = 3
39 :
40 : integer, protected, public :: ipair_select_renamexf(maxpair_renamexf)
41 : ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair
42 : ! 2001 = aitken --> accum
43 : ! 1003 = accum --> coarse
44 : ! 3001 = coarse --> accum
45 : ! 1005 = accum --> stracoar
46 : ! 5001 = stracoar --> accum
47 :
48 : integer, parameter, public :: method_optbb_renamexf = 2
49 :
50 : integer, public :: npair_renamexf = -123456789
51 : integer, protected, public :: modefrm_renamexf(maxpair_renamexf)
52 : integer, protected, public :: modetoo_renamexf(maxpair_renamexf)
53 : integer, protected, public :: nspecfrm_renamexf(maxpair_renamexf)
54 :
55 : integer, allocatable, protected, public :: lspecfrma_renamexf(:,:)
56 : integer, allocatable, protected, public :: lspecfrmc_renamexf(:,:)
57 : integer, allocatable, protected, public :: lspectooa_renamexf(:,:)
58 : integer, allocatable, protected, public :: lspectooc_renamexf(:,:)
59 :
60 : integer, protected, public :: igrow_shrink_renamexf(maxpair_renamexf)
61 : integer, protected, public :: ixferable_all_renamexf(maxpair_renamexf)
62 : integer, protected, public :: ixferable_all_needed_renamexf(maxpair_renamexf)
63 : integer, allocatable, protected, public :: ixferable_a_renamexf(:,:)
64 : integer, allocatable, protected, public :: ixferable_c_renamexf(:,:)
65 :
66 : logical, public :: strat_only_renamexf(maxpair_renamexf)
67 : ! strat_only_renamexf - when true for a particular renaming pair, renaming is only
68 : ! done in stratosphere (when k < troplev(icol) )
69 :
70 : ! !PRIVATE DATA MEMBERS:
71 : integer, allocatable :: ido_mode_calcaa(:)
72 : real (r8) :: dp_belowcut(maxpair_renamexf)
73 : real (r8) :: dp_cut(maxpair_renamexf)
74 : real (r8) :: dp_xferall_thresh(maxpair_renamexf)
75 : real (r8) :: dp_xfernone_threshaa(maxpair_renamexf)
76 : real (r8), allocatable :: dryvol_smallest(:)
77 : real (r8), allocatable :: factoraa(:)
78 : real (r8), allocatable :: factoryy(:)
79 : real (r8) :: lndp_cut(maxpair_renamexf)
80 : real (r8) :: factor_3alnsg2(maxpair_renamexf)
81 : real (r8), allocatable :: v2nhirlx(:), v2nlorlx(:)
82 :
83 : logical :: modal_accum_coarse_exch = .false.
84 :
85 : ! !DESCRIPTION: This module implements ...
86 : !
87 : ! !REVISION HISTORY:
88 : !
89 : ! RCE 07.04.13: Adapted from MIRAGE2 code
90 : !
91 : !EOP
92 : !----------------------------------------------------------------------
93 : !BOC
94 :
95 : ! list private module data here
96 :
97 : !EOC
98 : !----------------------------------------------------------------------
99 : contains
100 :
101 : !------------------------------------------------------------------
102 : !------------------------------------------------------------------
103 1536 : subroutine modal_aero_rename_init(modal_accum_coarse_exch_in)
104 : logical, optional, intent(in) :: modal_accum_coarse_exch_in
105 :
106 : ! ipair_select_renamexf defines the mode_from and mode_too for each renaming pair
107 : ! 2001 = aitken --> accum
108 : ! 1003 = accum --> coarse
109 : ! 3001 = coarse --> accum
110 : ! 1005 = accum --> stracoar
111 : ! 5001 = stracoar --> accum
112 1536 : if( rad_cnst_get_mode_idx(0,'coarse_strat') > 0 ) then
113 0 : ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1005, 5001 /)
114 : else
115 1536 : ipair_select_renamexf(1:maxpair_renamexf) = (/ 2001, 1003, 3001 /)
116 : endif
117 :
118 4608 : allocate( lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf) )
119 3072 : allocate( lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf) )
120 3072 : allocate( lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf) )
121 3072 : allocate( lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf) )
122 :
123 3072 : allocate( ixferable_a_renamexf(maxspec_renamexf,maxpair_renamexf) )
124 3072 : allocate( ixferable_c_renamexf(maxspec_renamexf,maxpair_renamexf) )
125 4608 : allocate( ido_mode_calcaa(ntot_amode) )
126 :
127 4608 : allocate( dryvol_smallest(ntot_amode) )
128 3072 : allocate( factoraa(ntot_amode) )
129 3072 : allocate( factoryy(ntot_amode) )
130 :
131 4608 : allocate( v2nhirlx(ntot_amode), v2nlorlx(ntot_amode) )
132 :
133 1536 : if (present(modal_accum_coarse_exch_in)) then
134 1536 : modal_accum_coarse_exch = modal_accum_coarse_exch_in
135 : endif
136 :
137 1536 : if (modal_accum_coarse_exch) then
138 1536 : call modal_aero_rename_acc_crs_init()
139 : else
140 0 : call modal_aero_rename_no_acc_crs_init()
141 : endif
142 :
143 1536 : end subroutine modal_aero_rename_init
144 :
145 : !------------------------------------------------------------------
146 : !------------------------------------------------------------------
147 58824 : subroutine modal_aero_rename_sub( &
148 : fromwhere, lchnk, &
149 : ncol, nstep, &
150 : loffset, deltat, &
151 : pdel, troplev, &
152 58824 : dotendrn, q, &
153 58824 : dqdt, dqdt_other, &
154 58824 : dotendqqcwrn, qqcw, &
155 58824 : dqqcwdt, dqqcwdt_other, &
156 58824 : is_dorename_atik, dorename_atik, &
157 : jsrflx_rename, nsrflx, &
158 58824 : qsrflx, qqcwsrflx, &
159 : dqdt_rnpos )
160 :
161 :
162 : ! !PARAMETERS:
163 : character(len=*), intent(in) :: fromwhere ! identifies which module
164 : ! is making the call
165 : integer, intent(in) :: lchnk ! chunk identifier
166 : integer, intent(in) :: ncol ! number of atmospheric column
167 : integer, intent(in) :: nstep ! model time-step number
168 : integer, intent(in) :: loffset ! offset applied to modal aero "ptrs"
169 : real(r8), intent(in) :: deltat ! time step (s)
170 : integer, intent(in) :: troplev(pcols)
171 :
172 : real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa)
173 : real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array
174 : ! *** MUST BE mol/mol-air or #/mol-air
175 : ! *** NOTE ncol and pcnstxx dimensions
176 : real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species
177 :
178 : real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array;
179 : ! incoming dqdt = tendencies for the
180 : ! "fromwhere" continuous growth process
181 : ! the renaming tendencies are added on
182 : ! *** NOTE ncol and pcnstxx dimensions
183 : real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx)
184 : real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx)
185 : ! tendencies for "other" continuous growth process
186 : ! currently in cam3
187 : ! dqdt is from gas (h2so4, nh3) condensation
188 : ! dqdt_other is from aqchem and soa
189 : ! *** NOTE ncol and pcnstxx dimensions
190 : real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx)
191 : logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which
192 : ! renaming dqdt is computed
193 : logical, intent(inout) :: dotendqqcwrn(pcnstxx)
194 :
195 : logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided
196 : logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should
197 : ! be done at i,k
198 : integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming
199 : integer, intent(in) :: nsrflx ! last dimension of qsrflx
200 :
201 : real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx)
202 : ! process-specific column tracer tendencies
203 : real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx)
204 : real(r8), optional, intent(out) &
205 : :: dqdt_rnpos(ncol,pver,pcnstxx)
206 : ! the positive (production) part of the renaming tendency
207 :
208 58824 : if (modal_accum_coarse_exch) then
209 : call modal_aero_rename_acc_crs_sub( &
210 : fromwhere, lchnk, &
211 : ncol, nstep, &
212 : loffset, deltat, &
213 : pdel, troplev, &
214 : dotendrn, q, &
215 : dqdt, dqdt_other, &
216 : dotendqqcwrn, qqcw, &
217 : dqqcwdt, dqqcwdt_other, &
218 : is_dorename_atik, dorename_atik, &
219 : jsrflx_rename, nsrflx, &
220 : qsrflx, qqcwsrflx, &
221 58824 : dqdt_rnpos )
222 : else
223 : call modal_aero_rename_no_acc_crs_sub( &
224 : fromwhere, lchnk, &
225 : ncol, nstep, &
226 : loffset, deltat, &
227 : pdel, &
228 : dotendrn, q, &
229 : dqdt, dqdt_other, &
230 : dotendqqcwrn, qqcw, &
231 : dqqcwdt, dqqcwdt_other, &
232 : is_dorename_atik, dorename_atik, &
233 : jsrflx_rename, nsrflx, &
234 0 : qsrflx, qqcwsrflx )
235 : endif
236 58824 : end subroutine modal_aero_rename_sub
237 :
238 : !----------------------------------------------------------------------
239 : !----------------------------------------------------------------------
240 : ! private methods
241 : !----------------------------------------------------------------------
242 : !BOP
243 : ! !ROUTINE: modal_aero_rename_no_acc_crs_sub --- ...
244 : !
245 : ! !INTERFACE:
246 0 : subroutine modal_aero_rename_no_acc_crs_sub( &
247 : fromwhere, lchnk, &
248 : ncol, nstep, &
249 : loffset, deltat, &
250 : pdel, &
251 0 : dotendrn, q, &
252 0 : dqdt, dqdt_other, &
253 0 : dotendqqcwrn, qqcw, &
254 0 : dqqcwdt, dqqcwdt_other, &
255 0 : is_dorename_atik, dorename_atik, &
256 : jsrflx_rename, nsrflx, &
257 0 : qsrflx, qqcwsrflx )
258 :
259 : ! !USES:
260 : use physconst, only: gravit, mwdry
261 : use shr_spfn_mod, only: erfc => shr_spfn_erfc
262 :
263 : implicit none
264 :
265 :
266 : ! !PARAMETERS:
267 : character(len=*), intent(in) :: fromwhere ! identifies which module
268 : ! is making the call
269 : integer, intent(in) :: lchnk ! chunk identifier
270 : integer, intent(in) :: ncol ! number of atmospheric column
271 : integer, intent(in) :: nstep ! model time-step number
272 : integer, intent(in) :: loffset ! offset applied to modal aero "ptrs"
273 : real(r8), intent(in) :: deltat ! time step (s)
274 :
275 : real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa)
276 : real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array
277 : ! *** MUST BE mol/mol-air or #/mol-air
278 : ! *** NOTE ncol and pcnstxx dimensions
279 : real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species
280 :
281 : real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array;
282 : ! incoming dqdt = tendencies for the
283 : ! "fromwhere" continuous growth process
284 : ! the renaming tendencies are added on
285 : ! *** NOTE ncol and pcnstxx dimensions
286 : real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx)
287 : real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx)
288 : ! tendencies for "other" continuous growth process
289 : ! currently in cam3
290 : ! dqdt is from gas (h2so4, nh3) condensation
291 : ! dqdt_other is from aqchem and soa
292 : ! *** NOTE ncol and pcnstxx dimensions
293 : real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx)
294 : logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which
295 : ! renaming dqdt is computed
296 : logical, intent(inout) :: dotendqqcwrn(pcnstxx)
297 :
298 : logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided
299 : logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should
300 : ! be done at i,k
301 : integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming
302 : integer, intent(in) :: nsrflx ! last dimension of qsrflx
303 :
304 : real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx)
305 : ! process-specific column tracer tendencies
306 : real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx)
307 :
308 : ! !DESCRIPTION:
309 : ! computes TMR (tracer mixing ratio) tendencies for "mode renaming"
310 : ! during a continuous growth process
311 : ! currently this transfers number and mass (and surface) from the aitken
312 : ! to accumulation mode after gas condensation or stratiform-cloud
313 : ! aqueous chemistry
314 : ! (convective cloud aqueous chemistry not yet implemented)
315 : !
316 : ! !REVISION HISTORY:
317 : ! RCE 07.04.13: Adapted from MIRAGE2 code
318 : !
319 : !EOP
320 : !----------------------------------------------------------------------
321 : !BOC
322 :
323 : ! local variables
324 : integer, parameter :: ldiag1=-1
325 : integer :: i, icol_diag, ipair, iq, j, k, l, l1, la, lc, lunout
326 : integer :: lsfrma, lsfrmc, lstooa, lstooc
327 : integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a
328 0 : integer :: idomode(ntot_amode)
329 :
330 0 : real (r8) :: deldryvol_a(ncol,pver,ntot_amode)
331 0 : real (r8) :: deldryvol_c(ncol,pver,ntot_amode)
332 : real (r8) :: deltatinv
333 : real (r8) :: dp_belowcut(maxpair_renamexf)
334 : real (r8) :: dp_cut(maxpair_renamexf)
335 : real (r8) :: dgn_aftr, dgn_xfer
336 : real (r8) :: dgn_t_new, dgn_t_old
337 : real (r8) :: dryvol_t_del, dryvol_t_new
338 : real (r8) :: dryvol_t_old, dryvol_t_oldbnd
339 0 : real (r8) :: dryvol_a(ncol,pver,ntot_amode)
340 0 : real (r8) :: dryvol_c(ncol,pver,ntot_amode)
341 0 : real (r8) :: dryvol_smallest(ntot_amode)
342 : real (r8) :: dum
343 : real (r8) :: dum3alnsg2(maxpair_renamexf)
344 : real (r8) :: dum_m2v, dum_m2vdt
345 0 : real (r8) :: factoraa(ntot_amode)
346 0 : real (r8) :: factoryy(ntot_amode)
347 : real (r8) :: frelax
348 : real (r8) :: lndp_cut(maxpair_renamexf)
349 : real (r8) :: lndgn_new, lndgn_old
350 : real (r8) :: lndgv_new, lndgv_old
351 : real (r8) :: num_t_old, num_t_oldbnd
352 : real (r8) :: onethird
353 : real (r8) :: pdel_fac
354 : real (r8) :: tailfr_volnew, tailfr_volold
355 : real (r8) :: tailfr_numnew, tailfr_numold
356 0 : real (r8) :: v2nhirlx(ntot_amode), v2nlorlx(ntot_amode)
357 : real (r8) :: xfercoef, xfertend
358 : real (r8) :: xferfrac_vol, xferfrac_num, xferfrac_max
359 :
360 : real (r8) :: yn_tail, yv_tail
361 :
362 : ! begin
363 0 : lunout = iulog
364 :
365 : !
366 : ! calculations done once on initial entry
367 : !
368 : ! "init" is now done through chem_init (and things under it)
369 : ! if (npair_renamexf .eq. -123456789) then
370 : ! npair_renamexf = 0
371 : ! call modal_aero_rename_init
372 : ! end if
373 :
374 : !
375 : ! check if any renaming pairs exist
376 : !
377 0 : if (npair_renamexf .le. 0) return
378 : ! if (ncol .ne. -123456789) return
379 : ! if (fromwhere .eq. 'aqchem') return
380 :
381 : !
382 : ! compute aerosol dry-volume for the "from mode" of each renaming pair
383 : ! also compute dry-volume change during the continuous growth process
384 : ! using the incoming dqdt*deltat
385 : !
386 0 : deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8))
387 0 : onethird = 1.0_r8/3.0_r8
388 0 : frelax = 27.0_r8
389 0 : xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps
390 :
391 0 : do n = 1, ntot_amode
392 0 : idomode(n) = 0
393 : end do
394 :
395 0 : do ipair = 1, npair_renamexf
396 0 : if (ipair .gt. 1) goto 8100
397 0 : idomode(modefrm_renamexf(ipair)) = 1
398 :
399 0 : mfrm = modefrm_renamexf(ipair)
400 0 : mtoo = modetoo_renamexf(ipair)
401 0 : factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2))
402 0 : factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2))
403 0 : factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(mfrm)
404 : ! dryvol_smallest is a very small volume mixing ratio (m3-AP/kmol-air)
405 : ! used for avoiding overflow. it corresponds to dp = 1 nm
406 : ! and number = 1e-5 #/mg-air ~= 1e-5 #/cm3-air
407 0 : dryvol_smallest(mfrm) = 1.0e-25_r8
408 0 : v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax
409 0 : v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax
410 :
411 0 : dum3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2)
412 : dp_cut(ipair) = sqrt( &
413 0 : dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * &
414 0 : dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) )
415 0 : lndp_cut(ipair) = log( dp_cut(ipair) )
416 0 : dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair)
417 : end do
418 :
419 0 : do n = 1, ntot_amode
420 0 : if (idomode(n) .gt. 0) then
421 0 : dryvol_a(1:ncol,:,n) = 0.0_r8
422 0 : dryvol_c(1:ncol,:,n) = 0.0_r8
423 0 : deldryvol_a(1:ncol,:,n) = 0.0_r8
424 0 : deldryvol_c(1:ncol,:,n) = 0.0_r8
425 0 : do l1 = 1, nspec_amode(n)
426 : ! dum_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air)
427 : ! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP]
428 0 : dum_m2v = specmw_amode(l1,n) / specdens_amode(l1,n)
429 0 : dum_m2vdt = dum_m2v*deltat
430 0 : la = lmassptr_amode(l1,n)-loffset
431 0 : if (la > 0) then
432 : dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n) &
433 : + dum_m2v*max( 0.0_r8, &
434 0 : q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) )
435 : deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n) &
436 0 : + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt
437 : end if
438 :
439 0 : lc = lmassptrcw_amode(l1,n)-loffset
440 0 : if (lc > 0) then
441 : dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n) &
442 : + dum_m2v*max( 0.0_r8, &
443 0 : qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) )
444 : deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n) &
445 : + (dqqcwdt_other(1:ncol,:,lc) + &
446 0 : dqqcwdt(1:ncol,:,lc))*dum_m2vdt
447 : end if
448 : end do
449 : end if
450 : end do
451 :
452 :
453 :
454 : !
455 : ! loop over levels and columns to calc the renaming
456 : !
457 0 : mainloop1_k: do k = 1, pver
458 0 : mainloop1_i: do i = 1, ncol
459 :
460 : ! if dorename_atik is provided, then check if renaming needed at this i,k
461 0 : if (is_dorename_atik) then
462 0 : if (.not. dorename_atik(i,k)) cycle mainloop1_i
463 : end if
464 0 : pdel_fac = pdel(i,k)/gravit
465 :
466 : !
467 : ! loop over renameing pairs
468 : !
469 0 : mainloop1_ipair: do ipair = 1, npair_renamexf
470 :
471 0 : mfrm = modefrm_renamexf(ipair)
472 0 : mtoo = modetoo_renamexf(ipair)
473 :
474 : ! dryvol_t_old is the old total (a+c) dry-volume for the "from" mode
475 : ! in m^3-AP/kmol-air
476 : ! dryvol_t_new is the new total dry-volume
477 : ! (old/new = before/after the continuous growth)
478 0 : dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm)
479 0 : dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm)
480 0 : dryvol_t_new = dryvol_t_old + dryvol_t_del
481 0 : dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
482 :
483 : ! no renaming if dryvol_t_new ~ 0 or dryvol_t_del ~ 0
484 0 : if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair
485 0 : if (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_ipair
486 :
487 : ! num_t_old is total number in particles/kmol-air
488 0 : num_t_old = q(i,k,numptr_amode(mfrm)-loffset)
489 0 : num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset)
490 0 : num_t_old = max( 0.0_r8, num_t_old )
491 0 : dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
492 0 : num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old )
493 0 : num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd )
494 :
495 : ! no renaming if dgnum < "base" dgnum,
496 0 : dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird
497 0 : if (dgn_t_new .le. dgnum_amode(mfrm)) cycle mainloop1_ipair
498 :
499 : ! compute new fraction of number and mass in the tail (dp > dp_cut)
500 0 : lndgn_new = log( dgn_t_new )
501 0 : lndgv_new = lndgn_new + dum3alnsg2(ipair)
502 0 : yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm)
503 0 : yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm)
504 0 : tailfr_numnew = 0.5_r8*erfc( yn_tail )
505 0 : tailfr_volnew = 0.5_r8*erfc( yv_tail )
506 :
507 : ! compute old fraction of number and mass in the tail (dp > dp_cut)
508 : dgn_t_old = &
509 0 : (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird
510 : ! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_old and
511 : ! dp_belowcut to guarantee some transfer
512 0 : if (dgn_t_new .ge. dp_cut(ipair)) then
513 0 : dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) )
514 : end if
515 0 : lndgn_old = log( dgn_t_old )
516 0 : lndgv_old = lndgn_old + dum3alnsg2(ipair)
517 0 : yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm)
518 0 : yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm)
519 0 : tailfr_numold = 0.5_r8*erfc( yn_tail )
520 0 : tailfr_volold = 0.5_r8*erfc( yv_tail )
521 :
522 : ! transfer fraction is difference between new and old tail-fractions
523 : ! transfer fraction for number cannot exceed that of mass
524 0 : dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old
525 0 : if (dum .le. 0.0_r8) cycle mainloop1_ipair
526 :
527 0 : xferfrac_vol = min( dum, dryvol_t_new )/dryvol_t_new
528 0 : xferfrac_vol = min( xferfrac_vol, xferfrac_max )
529 0 : xferfrac_num = tailfr_numnew - tailfr_numold
530 0 : xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) )
531 :
532 : !
533 : ! compute tendencies for the renaming transfer
534 : !
535 0 : j = jsrflx_rename
536 0 : do iq = 1, nspecfrm_renamexf(ipair)
537 0 : xfercoef = xferfrac_vol*deltatinv
538 0 : if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv
539 :
540 0 : lsfrma = lspecfrma_renamexf(iq,ipair)-loffset
541 0 : lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset
542 0 : lstooa = lspectooa_renamexf(iq,ipair)-loffset
543 0 : lstooc = lspectooc_renamexf(iq,ipair)-loffset
544 :
545 0 : if (lsfrma .gt. 0) then
546 : xfertend = xfercoef*max( 0.0_r8, &
547 0 : (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) )
548 :
549 : ! diagnostic output start ----------------------------------------
550 : if (ldiag1 > 0) then
551 : if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
552 : if (lstooa .gt. 0) then
553 : write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
554 : cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
555 : deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend), &
556 : deltat*dqdt(i,k,lstooa), deltat*(dqdt(i,k,lstooa) + xfertend)
557 : else
558 : write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
559 : cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
560 : deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend)
561 : end if
562 : end if
563 : end if
564 : ! diagnostic output end ------------------------------------------
565 :
566 :
567 0 : dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend
568 0 : qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac
569 0 : if (lstooa .gt. 0) then
570 0 : dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend
571 0 : qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac
572 : end if
573 : end if
574 :
575 0 : if (lsfrmc .gt. 0) then
576 : xfertend = xfercoef*max( 0.0_r8, &
577 0 : (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) )
578 0 : dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend
579 0 : qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac
580 0 : if (lstooc .gt. 0) then
581 0 : dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend
582 0 : qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac
583 : end if
584 : end if
585 :
586 : end do ! "iq = 1, nspecfrm_renamexf(ipair)"
587 :
588 :
589 : end do mainloop1_ipair
590 :
591 :
592 : end do mainloop1_i
593 : end do mainloop1_k
594 :
595 : !
596 : ! set dotend's
597 : !
598 0 : dotendrn(:) = .false.
599 0 : dotendqqcwrn(:) = .false.
600 0 : do ipair = 1, npair_renamexf
601 0 : do iq = 1, nspecfrm_renamexf(ipair)
602 0 : lsfrma = lspecfrma_renamexf(iq,ipair) - loffset
603 0 : lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset
604 0 : lstooa = lspectooa_renamexf(iq,ipair) - loffset
605 0 : lstooc = lspectooc_renamexf(iq,ipair) - loffset
606 0 : if (lsfrma .gt. 0) then
607 0 : dotendrn(lsfrma) = .true.
608 0 : if (lstooa .gt. 0) dotendrn(lstooa) = .true.
609 : end if
610 0 : if (lsfrmc .gt. 0) then
611 0 : dotendqqcwrn(lsfrmc) = .true.
612 0 : if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true.
613 : end if
614 : end do
615 : end do
616 :
617 :
618 0 : return
619 :
620 :
621 : !
622 : ! error -- renaming currently just works for 1 pair
623 : !
624 0 : 8100 write(lunout,9050) ipair
625 0 : call endrun( 'modal_aero_rename_no_acc_crs_sub error' )
626 : 9050 format( / '*** subr. modal_aero_rename_no_acc_crs_sub ***' / &
627 : 4x, 'aerosol renaming not implemented for ipair =', i5 )
628 :
629 : !EOC
630 : end subroutine modal_aero_rename_no_acc_crs_sub
631 :
632 :
633 :
634 : !-------------------------------------------------------------------------
635 0 : subroutine modal_aero_rename_no_acc_crs_init
636 : !
637 : ! computes pointers for species transfer during aerosol renaming
638 : ! (a2 --> a1 transfer)
639 : ! transfers include number_a, number_c, mass_a, mass_c and
640 : ! water_a
641 : !
642 :
643 : implicit none
644 :
645 : ! local variables
646 : integer :: ipair, iq, iqfrm, iqtoo
647 : integer :: lsfrma, lsfrmc, lstooa, lstooc, lunout
648 : integer :: mfrm, mtoo
649 : integer :: n1, n2, nspec
650 : integer :: nchfrma, nchfrmc, nchfrmskip, nchtooa, nchtooc, nchtooskip
651 :
652 0 : lunout = iulog
653 : !
654 : ! define "from mode" and "to mode" for each tail-xfer pairing
655 : ! currently just a2-->a1
656 : !
657 0 : n1 = modeptr_accum
658 0 : n2 = modeptr_aitken
659 0 : if ((n1 .gt. 0) .and. (n2 .gt. 0)) then
660 0 : npair_renamexf = 1
661 0 : modefrm_renamexf(1) = n2
662 0 : modetoo_renamexf(1) = n1
663 : else
664 0 : npair_renamexf = 0
665 0 : return
666 : end if
667 :
668 : !
669 : ! define species involved in each tail-xfer pairing
670 : ! (include aerosol water)
671 : !
672 0 : aa_ipair: do ipair = 1, npair_renamexf
673 0 : mfrm = modefrm_renamexf(ipair)
674 0 : mtoo = modetoo_renamexf(ipair)
675 0 : if (mfrm < 10) then
676 : nchfrmskip = 1
677 0 : else if (mfrm < 100) then
678 : nchfrmskip = 2
679 : else
680 0 : nchfrmskip = 3
681 : end if
682 0 : if (mtoo < 10) then
683 : nchtooskip = 1
684 0 : else if (mtoo < 100) then
685 : nchtooskip = 2
686 : else
687 0 : nchtooskip = 3
688 : end if
689 0 : nspec = 0
690 0 : aa_iqfrm: do iqfrm = -1, nspec_amode(mfrm)
691 0 : if (iqfrm == -1) then
692 0 : lsfrma = numptr_amode(mfrm)
693 0 : lstooa = numptr_amode(mtoo)
694 0 : lsfrmc = numptrcw_amode(mfrm)
695 0 : lstooc = numptrcw_amode(mtoo)
696 0 : else if (iqfrm == 0) then
697 : ! bypass transfer of aerosol water due to renaming
698 : cycle aa_iqfrm
699 : ! lsfrma = lwaterptr_amode(mfrm)
700 : ! lsfrmc = 0
701 : ! lstooa = lwaterptr_amode(mtoo)
702 : ! lstooc = 0
703 : else
704 0 : lsfrma = lmassptr_amode(iqfrm,mfrm)
705 0 : lsfrmc = lmassptrcw_amode(iqfrm,mfrm)
706 0 : lstooa = 0
707 0 : lstooc = 0
708 : end if
709 :
710 :
711 0 : if ((lsfrma < 1) .or. (lsfrma > pcnst)) then
712 0 : write(lunout,9100) mfrm, iqfrm, lsfrma
713 0 : call endrun( 'modal_aero_rename_init error aa' )
714 : end if
715 0 : if ((lsfrmc < 1) .or. (lsfrmc > pcnst)) then
716 0 : write(lunout,9102) mfrm, iqfrm, lsfrmc
717 0 : call endrun( 'modal_aero_rename_init error bb' )
718 : end if
719 :
720 :
721 0 : if (iqfrm > 0) then
722 0 : nchfrma = len( trim( cnst_name(lsfrma) ) ) - nchfrmskip
723 :
724 : ! find "too" species having same lspectype_amode as the "frm" species
725 : ! AND same cnst_name (except for last 1/2/3 characters which are the mode index)
726 0 : do iqtoo = 1, nspec_amode(mtoo)
727 : ! if ( lspectype_amode(iqtoo,mtoo) .eq. &
728 : ! lspectype_amode(iqfrm,mfrm) ) then
729 0 : lstooa = lmassptr_amode(iqtoo,mtoo)
730 0 : nchtooa = len( trim( cnst_name(lstooa) ) ) - nchtooskip
731 0 : if (cnst_name(lsfrma)(1:nchfrma) == cnst_name(lstooa)(1:nchtooa)) then
732 : ! interstitial names match, so check cloudborne names too
733 0 : nchfrmc = len( trim( cnst_name_cw(lsfrmc) ) ) - nchfrmskip
734 0 : lstooc = lmassptrcw_amode(iqtoo,mtoo)
735 0 : nchtooc = len( trim( cnst_name_cw(lstooc) ) ) - nchtooskip
736 0 : if (cnst_name_cw(lsfrmc)(1:nchfrmc) /= &
737 0 : cnst_name_cw(lstooc)(1:nchtooc)) lstooc = 0
738 : exit
739 : else
740 0 : lstooa = 0
741 : end if
742 : ! end if
743 : end do
744 : end if ! (iqfrm > 0)
745 :
746 0 : if ((lstooc < 1) .or. (lstooc > pcnst)) lstooc = 0
747 0 : if ((lstooa < 1) .or. (lstooa > pcnst)) lstooa = 0
748 0 : if (lstooa == 0) then
749 0 : write(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa
750 0 : call endrun( 'modal_aero_rename_init error cc' )
751 : end if
752 0 : if ((lstooc == 0) .and. (iqfrm /= 0)) then
753 0 : write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc
754 0 : call endrun( 'modal_aero_rename_init error dd' )
755 : end if
756 :
757 0 : nspec = nspec + 1
758 0 : lspecfrma_renamexf(nspec,ipair) = lsfrma
759 0 : lspectooa_renamexf(nspec,ipair) = lstooa
760 0 : lspecfrmc_renamexf(nspec,ipair) = lsfrmc
761 0 : lspectooc_renamexf(nspec,ipair) = lstooc
762 : end do aa_iqfrm
763 :
764 0 : nspecfrm_renamexf(ipair) = nspec
765 : end do aa_ipair
766 :
767 : 9100 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / &
768 : 'lspecfrma out of range' / &
769 : 'modefrm, ispecfrm, lspecfrma =', 3i6 / )
770 : 9102 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / &
771 : 'lspecfrmc out of range' / &
772 : 'modefrm, ispecfrm, lspecfrmc =', 3i6 / )
773 : 9104 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / &
774 : 'lspectooa out of range' / &
775 : 'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / )
776 : 9106 format( / '*** subr. modal_aero_rename_no_acc_crs_init' / &
777 : 'lspectooc out of range' / &
778 : 'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / )
779 :
780 : !
781 : ! output results
782 : !
783 0 : if ( masterproc ) then
784 :
785 0 : write(lunout,9310)
786 :
787 0 : do 2900 ipair = 1, npair_renamexf
788 0 : mfrm = modefrm_renamexf(ipair)
789 0 : mtoo = modetoo_renamexf(ipair)
790 0 : write(lunout,9320) ipair, mfrm, mtoo
791 :
792 0 : do iq = 1, nspecfrm_renamexf(ipair)
793 0 : lsfrma = lspecfrma_renamexf(iq,ipair)
794 0 : lstooa = lspectooa_renamexf(iq,ipair)
795 0 : lsfrmc = lspecfrmc_renamexf(iq,ipair)
796 0 : lstooc = lspectooc_renamexf(iq,ipair)
797 0 : if (lstooa .gt. 0) then
798 0 : write(lunout,9330) lsfrma, cnst_name(lsfrma), &
799 0 : lstooa, cnst_name(lstooa)
800 : else
801 0 : write(lunout,9340) lsfrma, cnst_name(lsfrma)
802 : end if
803 0 : if (lstooc .gt. 0) then
804 0 : write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), &
805 0 : lstooc, cnst_name_cw(lstooc)
806 0 : else if (lsfrmc .gt. 0) then
807 0 : write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc)
808 : else
809 0 : write(lunout,9350)
810 : end if
811 : end do
812 :
813 0 : 2900 continue
814 0 : write(lunout,*)
815 :
816 : end if ! ( masterproc )
817 :
818 : 9310 format( / 'subr. modal_aero_rename_no_acc_crs_init' )
819 : 9320 format( 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3 )
820 : 9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a )
821 : 9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' )
822 : 9350 format( 5x, 'no corresponding activated species' )
823 :
824 : return
825 : end subroutine modal_aero_rename_no_acc_crs_init
826 :
827 : !----------------------------------------------------------------------
828 : ! code for troposphere and stratosphere
829 : ! -- allows accumulation to coarse mode exchange
830 : !----------------------------------------------------------------------
831 : !BOP
832 : ! !ROUTINE: modal_aero_rename_acc_crs_sub --- ...
833 : !
834 : ! !INTERFACE:
835 58824 : subroutine modal_aero_rename_acc_crs_sub( &
836 : fromwhere, lchnk, &
837 : ncol, nstep, &
838 : loffset, deltat, &
839 : pdel, troplev, &
840 58824 : dotendrn, q, &
841 58824 : dqdt, dqdt_other, &
842 58824 : dotendqqcwrn, qqcw, &
843 58824 : dqqcwdt, dqqcwdt_other, &
844 58824 : is_dorename_atik, dorename_atik, &
845 : jsrflx_rename, nsrflx, &
846 58824 : qsrflx, qqcwsrflx, &
847 0 : dqdt_rnpos )
848 :
849 : ! !USES:
850 :
851 : use physconst, only: gravit, mwdry
852 : use shr_spfn_mod, only: erfc => shr_spfn_erfc
853 :
854 : implicit none
855 :
856 :
857 : ! !PARAMETERS:
858 : character(len=*), intent(in) :: fromwhere ! identifies which module
859 : ! is making the call
860 : integer, intent(in) :: lchnk ! chunk identifier
861 : integer, intent(in) :: ncol ! number of atmospheric column
862 : integer, intent(in) :: nstep ! model time-step number
863 : integer, intent(in) :: loffset ! offset applied to modal aero "ptrs"
864 : real(r8), intent(in) :: deltat ! time step (s)
865 : integer, intent(in) :: troplev(pcols)
866 :
867 : real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness of levels (Pa)
868 : real(r8), intent(in) :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array
869 : ! *** MUST BE mol/mol-air or #/mol-air
870 : ! *** NOTE ncol and pcnstxx dimensions
871 : real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species
872 :
873 : real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx) ! TMR tendency array;
874 : ! incoming dqdt = tendencies for the
875 : ! "fromwhere" continuous growth process
876 : ! the renaming tendencies are added on
877 : ! *** NOTE ncol and pcnstxx dimensions
878 : real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx)
879 : real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx)
880 : ! tendencies for "other" continuous growth process
881 : ! currently in cam3
882 : ! dqdt is from gas (h2so4, nh3) condensation
883 : ! dqdt_other is from aqchem and soa
884 : ! *** NOTE ncol and pcnstxx dimensions
885 : real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx)
886 : logical, intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which
887 : ! renaming dqdt is computed
888 : logical, intent(inout) :: dotendqqcwrn(pcnstxx)
889 :
890 : logical, intent(in) :: is_dorename_atik ! true if dorename_atik is provided
891 : logical, intent(in) :: dorename_atik(ncol,pver) ! true if renaming should
892 : ! be done at i,k
893 : integer, intent(in) :: jsrflx_rename ! qsrflx index for renaming
894 : integer, intent(in) :: nsrflx ! last dimension of qsrflx
895 :
896 : real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx)
897 : ! process-specific column tracer tendencies
898 : real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx)
899 : real(r8), optional, intent(out) &
900 : :: dqdt_rnpos(ncol,pver,pcnstxx)
901 : ! the positive (production) part of the renaming tendency
902 :
903 : ! !DESCRIPTION:
904 : ! computes TMR (tracer mixing ratio) tendencies for "mode renaming"
905 : ! during a continuous growth process
906 : ! currently this transfers number and mass (and surface) from the aitken
907 : ! to accumulation mode after gas condensation or stratiform-cloud
908 : ! aqueous chemistry
909 : ! (convective cloud aqueous chemistry not yet implemented)
910 : !
911 : ! !REVISION HISTORY:
912 : ! RCE 07.04.13: Adapted from MIRAGE2 code
913 : !
914 : !EOP
915 : !----------------------------------------------------------------------
916 : !BOC
917 :
918 : ! local variables
919 : integer, parameter :: ldiag1 = -1
920 : integer :: i, icol_diag, ipair, iq
921 : integer :: j, k
922 : integer :: l, l1, la, lc, lunout
923 : integer :: lsfrma, lsfrmc, lstooa, lstooc
924 : integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a
925 :
926 : logical :: l_dqdt_rnpos
927 : logical :: flagaa_shrink, flagbb_shrink
928 :
929 117648 : real (r8) :: deldryvol_a(ncol,pver)
930 117648 : real (r8) :: deldryvol_c(ncol,pver)
931 : real (r8) :: deltatinv
932 : real (r8) :: dgn_aftr, dgn_xfer
933 : real (r8) :: dgn_t_new, dgn_t_old, dgn_t_oldb
934 : real (r8) :: dryvol_t_del, dryvol_t_new, dryvol_t_new_xfab
935 : real (r8) :: dryvol_t_old, dryvol_t_oldb, dryvol_t_oldbnd
936 117648 : real (r8) :: dryvol_a(ncol,pver)
937 117648 : real (r8) :: dryvol_c(ncol,pver)
938 117648 : real (r8) :: dryvol_a_xfab(ncol,pver)
939 117648 : real (r8) :: dryvol_c_xfab(ncol,pver)
940 : real (r8) :: dryvol_xferamt
941 : real (r8) :: lndgn_new, lndgn_old
942 : real (r8) :: lndgv_new, lndgv_old
943 : real (r8) :: num_t_old, num_t_oldbnd
944 : real (r8) :: onethird
945 : real (r8) :: pdel_fac
946 : real (r8) :: tailfr_volnew, tailfr_volold
947 : real (r8) :: tailfr_numnew, tailfr_numold
948 : real (r8) :: tmpa, tmpf
949 : real (r8) :: tmp_m2v, tmp_m2vdt
950 : real (r8) :: xfercoef, xfertend
951 : real (r8) :: xferfrac_vol, xferfrac_num, xferfrac_max
952 :
953 : real (r8) :: yn_tail, yv_tail
954 :
955 : ! begin
956 58824 : lunout = iulog
957 :
958 : !
959 : ! calculations done once on initial entry
960 : !
961 : ! "init" is now done through chem_init (and things under it)
962 : ! if (npair_renamexf .eq. -123456789) then
963 : ! npair_renamexf = 0
964 : ! call modal_aero_rename_init
965 : ! end if
966 :
967 : !
968 : ! check if any renaming pairs exist
969 : !
970 58824 : if (npair_renamexf .le. 0) return
971 : ! if (ncol .ne. -123456789) return
972 : ! if (fromwhere .eq. 'aqchem') return
973 :
974 :
975 58824 : deltatinv = 1.0_r8/(deltat*(1.0_r8 + 1.0e-15_r8))
976 58824 : onethird = 1.0_r8/3.0_r8
977 58824 : xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8) ! 1-eps
978 :
979 58824 : if ( present( dqdt_rnpos ) ) then
980 0 : l_dqdt_rnpos = .true.
981 0 : dqdt_rnpos(:,:,:) = 0.0_r8
982 : else
983 : l_dqdt_rnpos = .false.
984 : end if
985 :
986 :
987 :
988 : !
989 : ! loop over renaming pairs
990 : !
991 235296 : mainloop1_ipair: do ipair = 1, npair_renamexf
992 :
993 176472 : mfrm = modefrm_renamexf(ipair)
994 176472 : mtoo = modetoo_renamexf(ipair)
995 :
996 : flagaa_shrink = &
997 : ((mfrm==modeptr_coarse) .and. (mtoo==modeptr_accum)) .or. &
998 176472 : ((mfrm==modeptr_stracoar) .and. (mtoo==modeptr_accum))
999 :
1000 : !
1001 : ! compute aerosol dry-volume for the "from mode" of each renaming pair
1002 : ! also compute dry-volume change during the continuous growth process
1003 : ! using the incoming dqdt*deltat
1004 : !
1005 274216968 : dryvol_a(:,:) = 0.0_r8
1006 274216968 : dryvol_c(:,:) = 0.0_r8
1007 274216968 : deldryvol_a(:,:) = 0.0_r8
1008 274216968 : deldryvol_c(:,:) = 0.0_r8
1009 176472 : if (ixferable_all_renamexf(ipair) <= 0) then
1010 91405656 : dryvol_a_xfab(:,:) = 0.0_r8
1011 91405656 : dryvol_c_xfab(:,:) = 0.0_r8
1012 : end if
1013 :
1014 176472 : n = mfrm
1015 941184 : do l1 = 1, nspec_amode(n)
1016 : ! tmp_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air)
1017 : ! [m3-AP/kmol-AP]= [kg-AP/kmol-AP] / [kg-AP/m3-AP]
1018 764712 : tmp_m2v = specmw_amode(l1,n) / specdens_amode(l1,n)
1019 764712 : tmp_m2vdt = tmp_m2v*deltat
1020 764712 : la = lmassptr_amode(l1,n)-loffset
1021 764712 : if (la > 0) then
1022 764712 : dryvol_a(1:ncol,:) = dryvol_a(1:ncol,:) &
1023 : + tmp_m2v*max( 0.0_r8, &
1024 1189038240 : q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) )
1025 : deldryvol_a(1:ncol,:) = deldryvol_a(1:ncol,:) &
1026 1188273528 : + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*tmp_m2vdt
1027 764712 : if ( (ixferable_all_renamexf(ipair) <= 0) .and. &
1028 764712 : (ixferable_a_renamexf(l1,ipair) > 0) ) then
1029 : dryvol_a_xfab(1:ncol,:) = dryvol_a_xfab(1:ncol,:) &
1030 : + tmp_m2v*max( 0.0_r8, &
1031 274216968 : q(1:ncol,:,la)+deltat*dqdt(1:ncol,:,la) )
1032 : end if
1033 : end if
1034 :
1035 764712 : lc = lmassptrcw_amode(l1,n)-loffset
1036 941184 : if (lc > 0) then
1037 764712 : dryvol_c(1:ncol,:) = dryvol_c(1:ncol,:) &
1038 : + tmp_m2v*max( 0.0_r8, &
1039 1189038240 : qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) )
1040 : deldryvol_c(1:ncol,:) = deldryvol_c(1:ncol,:) &
1041 : + (dqqcwdt_other(1:ncol,:,lc) + &
1042 1188273528 : dqqcwdt(1:ncol,:,lc))*tmp_m2vdt
1043 764712 : if ( (ixferable_all_renamexf(ipair) <= 0) .and. &
1044 764712 : (ixferable_c_renamexf(l1,ipair) > 0) ) then
1045 : dryvol_c_xfab(1:ncol,:) = dryvol_c_xfab(1:ncol,:) &
1046 : + tmp_m2v*max( 0.0_r8, &
1047 274216968 : qqcw(1:ncol,:,lc)+deltat*dqqcwdt(1:ncol,:,lc) )
1048 : end if
1049 : end if
1050 : end do
1051 :
1052 : !
1053 : !
1054 : ! loop over levels and columns to calc the renaming
1055 : !
1056 : !
1057 16647192 : mainloop1_k: do k = 1, pver
1058 274216968 : mainloop1_i: do i = 1, ncol
1059 :
1060 : ! if dorename_atik is provided, then check if renaming needed at this i,k
1061 257628600 : if (is_dorename_atik) then
1062 257628600 : if (.not. dorename_atik(i,k)) cycle mainloop1_i
1063 : end if
1064 :
1065 : ! if strat_only_renamexf is true, then cycle when at or below the tropopause level
1066 257628600 : if ( strat_only_renamexf(ipair) ) then
1067 171752400 : if ( k >= troplev(i) ) cycle mainloop1_i
1068 : end if
1069 :
1070 :
1071 : ! dryvol_t_old is the old total (a+c) dry-volume for the "from" mode
1072 : ! in m^3-AP/kmol-air
1073 : ! dryvol_t_new is the new total dry-volume
1074 : ! (old/new = before/after the continuous growth)
1075 180201076 : dryvol_t_old = dryvol_a(i,k) + dryvol_c(i,k)
1076 180201076 : dryvol_t_del = deldryvol_a(i,k) + deldryvol_c(i,k)
1077 180201076 : dryvol_t_new = dryvol_t_old + dryvol_t_del
1078 180201076 : dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
1079 :
1080 : grow_shrink_conditional1: &
1081 180201076 : if (igrow_shrink_renamexf(ipair) > 0) then
1082 : ! do renaming for growing particles
1083 :
1084 : ! no renaming if dryvol_t_new ~ 0
1085 133038638 : if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_i
1086 : ! no renaming if delta_dryvol is very small or negative
1087 : if ( (method_optbb_renamexf /= 2) .and. &
1088 : (dryvol_t_del .le. 1.0e-6_r8*dryvol_t_oldbnd) ) cycle mainloop1_i
1089 :
1090 : ! num_t_old is total number in particles/kmol-air
1091 133038638 : num_t_old = q(i,k,numptr_amode(mfrm)-loffset)
1092 133038638 : num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset)
1093 133038638 : num_t_old = max( 0.0_r8, num_t_old )
1094 133038638 : dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
1095 133038638 : num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old )
1096 133038638 : num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd )
1097 :
1098 : ! compute new dgnum
1099 133038638 : dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird
1100 : ! no renaming if dgn_t_new < threshold value
1101 133038638 : if (dgn_t_new .le. dp_xfernone_threshaa(ipair)) cycle mainloop1_i
1102 :
1103 : ! compute old dgnum and possibly a smaller value to get more renaming transfer
1104 : dgn_t_old = &
1105 70719038 : (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird
1106 70719038 : dgn_t_oldb = dgn_t_old
1107 70719038 : dryvol_t_oldb = dryvol_t_old
1108 : if ( method_optbb_renamexf == 2) then
1109 70719038 : if (dgn_t_old .ge. dp_cut(ipair)) then
1110 : ! this revised volume corresponds to dgn_t_old == dp_belowcut, and same number conc
1111 2680 : dryvol_t_oldb = dryvol_t_old * (dp_belowcut(ipair)/dgn_t_old)**3
1112 : dgn_t_oldb = dp_belowcut(ipair)
1113 : end if
1114 70719038 : if (dgn_t_new .lt. dp_xferall_thresh(ipair)) then
1115 : ! no renaming if delta_dryvol is very small or negative
1116 70571468 : if ((dryvol_t_new-dryvol_t_oldb) .le. 1.0e-6_r8*dryvol_t_oldbnd) cycle mainloop1_i
1117 : end if
1118 :
1119 : else if (dgn_t_new .ge. dp_cut(ipair)) then
1120 : ! if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_oldb and
1121 : ! dp_belowcut to guarantee some transfer
1122 : dgn_t_oldb = min( dgn_t_oldb, dp_belowcut(ipair) )
1123 : end if
1124 :
1125 : ! compute new fraction of number and mass in the tail (dp > dp_cut)
1126 36896154 : lndgn_new = log( dgn_t_new )
1127 36896154 : lndgv_new = lndgn_new + factor_3alnsg2(ipair)
1128 36896154 : yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm)
1129 36896154 : yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm)
1130 36896154 : tailfr_numnew = 0.5_r8*erfc( yn_tail )
1131 36896154 : tailfr_volnew = 0.5_r8*erfc( yv_tail )
1132 :
1133 : ! compute old fraction of number and mass in the tail (dp > dp_cut)
1134 36896154 : lndgn_old = log( dgn_t_oldb )
1135 36896154 : lndgv_old = lndgn_old + factor_3alnsg2(ipair)
1136 36896154 : yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm)
1137 36896154 : yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm)
1138 36896154 : tailfr_numold = 0.5_r8*erfc( yn_tail )
1139 36896154 : tailfr_volold = 0.5_r8*erfc( yv_tail )
1140 :
1141 : ! transfer fraction is difference between new and old tail-fractions
1142 : ! transfer fraction for number cannot exceed that of mass
1143 36896154 : if ( (method_optbb_renamexf == 2) .and. &
1144 : (dgn_t_new .ge. dp_xferall_thresh(ipair)) ) then
1145 : dryvol_xferamt = dryvol_t_new
1146 : else
1147 36748584 : dryvol_xferamt = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_oldb
1148 : end if
1149 36896154 : if (dryvol_xferamt .le. 0.0_r8) cycle mainloop1_i
1150 :
1151 36896154 : xferfrac_vol = max( 0.0_r8, (dryvol_xferamt/dryvol_t_new) )
1152 36896154 : if ( method_optbb_renamexf == 2 .and. &
1153 : (xferfrac_vol >= xferfrac_max) ) then
1154 : ! transfer entire contents of mode
1155 : xferfrac_vol = 1.0_r8
1156 : xferfrac_num = 1.0_r8
1157 : else
1158 36748584 : xferfrac_vol = min( xferfrac_vol, xferfrac_max )
1159 36748584 : xferfrac_num = tailfr_numnew - tailfr_numold
1160 36748584 : xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) )
1161 : end if
1162 :
1163 36896154 : if (ixferable_all_renamexf(ipair) <= 0) then
1164 : ! not all species are xferable
1165 289063 : dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) )
1166 289063 : dryvol_xferamt = xferfrac_vol*dryvol_t_new
1167 289063 : if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then
1168 : ! xferable dryvol can supply the needed dryvol_xferamt
1169 : ! but xferfrac_vol must be increased
1170 148295 : xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) )
1171 140768 : else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then
1172 : ! xferable dryvol cannot supply the needed dryvol_xferamt
1173 : ! so transfer all of it, and reduce the number transfer
1174 140768 : xferfrac_vol = 1.0_r8
1175 140768 : xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt)
1176 : else
1177 : ! xferable dryvol << needed dryvol_xferamt
1178 : cycle mainloop1_i
1179 : end if
1180 : end if
1181 :
1182 : else grow_shrink_conditional1
1183 : ! do renaming for shrinking particles
1184 :
1185 : ! no renaming if (dryvol_t_old ~ 0)
1186 47162438 : if (dryvol_t_old .le. dryvol_smallest(mfrm)) cycle mainloop1_i
1187 :
1188 : ! when (delta_dryvol is very small or positive),
1189 : ! which means particles are not evaporating,
1190 : ! only do renaming if [(flagaa_shrink true) and (in stratosphere)]],
1191 : ! and set flagbb_shrink true to identify this special case
1192 41296937 : if (dryvol_t_del .ge. -1.0e-6_r8*dryvol_t_oldbnd) then
1193 41296937 : if ( ( flagaa_shrink ) .and. ( k < troplev(i) ) ) then
1194 : flagbb_shrink = .true.
1195 : else
1196 : cycle mainloop1_i
1197 : end if
1198 : else
1199 : flagbb_shrink = .false.
1200 : end if
1201 :
1202 : ! num_t_old is total number in particles/kmol-air
1203 41296937 : num_t_old = q(i,k,numptr_amode(mfrm)-loffset)
1204 41296937 : num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset)
1205 41296937 : num_t_old = max( 0.0_r8, num_t_old )
1206 41296937 : dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
1207 41296937 : num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old )
1208 41296937 : num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd )
1209 :
1210 : ! compute new dgnum
1211 41296937 : dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird
1212 : ! no renaming if (dgn_t_new > xfernone threshold value)
1213 41296937 : if (dgn_t_new .ge. dp_xfernone_threshaa(ipair)) cycle mainloop1_i
1214 : ! if (flagbb_shrink true), renaming only when (dgn_t_new <= dp_cut value)
1215 20 : if ( flagbb_shrink ) then
1216 20 : if (dgn_t_new .gt. dp_cut(ipair)) cycle mainloop1_i
1217 : end if
1218 :
1219 20 : if ( dgn_t_new .le. dp_xferall_thresh(ipair) ) then
1220 : ! special case of (dgn_t_new <= xferall threshold value)
1221 : tailfr_numnew = 1.0_r8
1222 : tailfr_volnew = 1.0_r8
1223 : else
1224 : ! compute new fraction of number and mass in the tail (dp < dp_cut)
1225 3 : lndgn_new = log( dgn_t_new )
1226 3 : lndgv_new = lndgn_new + factor_3alnsg2(ipair)
1227 3 : yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm)
1228 3 : yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm)
1229 3 : tailfr_numnew = 1.0_r8 - 0.5_r8*erfc( yn_tail )
1230 3 : tailfr_volnew = 1.0_r8 - 0.5_r8*erfc( yv_tail )
1231 : end if
1232 :
1233 : ! compute old dgnum
1234 : dgn_t_old = &
1235 20 : (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird
1236 20 : dgn_t_oldb = dgn_t_old
1237 20 : dryvol_t_oldb = dryvol_t_old
1238 :
1239 : ! no need to compute old fraction of number and mass in the tail
1240 20 : tailfr_numold = 0.0_r8
1241 20 : tailfr_volold = 0.0_r8
1242 :
1243 : ! transfer fraction is new tail-fraction
1244 20 : xferfrac_vol = tailfr_volnew
1245 20 : if (xferfrac_vol .le. 0.0_r8) cycle mainloop1_i
1246 20 : xferfrac_num = tailfr_numnew
1247 :
1248 20 : if (xferfrac_vol >= xferfrac_max) then
1249 : ! transfer entire contents of mode
1250 : xferfrac_vol = 1.0_r8
1251 : xferfrac_num = 1.0_r8
1252 : else
1253 3 : xferfrac_vol = min( xferfrac_vol, xferfrac_max )
1254 : ! transfer fraction for number cannot be less than that of volume
1255 3 : xferfrac_num = max( xferfrac_num, xferfrac_vol )
1256 3 : xferfrac_num = min( xferfrac_max, xferfrac_num )
1257 : end if
1258 :
1259 20 : if (ixferable_all_renamexf(ipair) <= 0) then
1260 : ! not all species are xferable
1261 0 : dryvol_t_new_xfab = max( 0.0_r8, (dryvol_a_xfab(i,k) + dryvol_c_xfab(i,k)) )
1262 0 : dryvol_xferamt = xferfrac_vol*dryvol_t_new
1263 0 : if (dryvol_t_new_xfab >= 0.999999_r8*dryvol_xferamt) then
1264 : ! xferable dryvol can supply the needed dryvol_xferamt
1265 : ! but xferfrac_vol must be increased
1266 0 : xferfrac_vol = min( 1.0_r8, (dryvol_xferamt/dryvol_t_new_xfab) )
1267 0 : else if (dryvol_t_new_xfab >= 1.0e-7_r8*dryvol_xferamt) then
1268 : ! xferable dryvol cannot supply the needed dryvol_xferamt
1269 : ! so transfer all of it, and reduce the number transfer
1270 0 : xferfrac_vol = 1.0_r8
1271 0 : xferfrac_num = xferfrac_num*(dryvol_t_new_xfab/dryvol_xferamt)
1272 : else
1273 : ! xferable dryvol << needed dryvol_xferamt
1274 : cycle mainloop1_i
1275 : end if
1276 : end if
1277 :
1278 : endif grow_shrink_conditional1
1279 :
1280 : !
1281 : ! compute tendencies for the renaming transfer
1282 : !
1283 36896174 : pdel_fac = pdel(i,k)/gravit
1284 36896174 : j = jsrflx_rename
1285 237499857 : do iq = 1, nspecfrm_renamexf(ipair)
1286 184191787 : xfercoef = xferfrac_vol*deltatinv
1287 184191787 : if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv
1288 :
1289 184191787 : lsfrma = lspecfrma_renamexf(iq,ipair)-loffset
1290 184191787 : lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset
1291 184191787 : lstooa = lspectooa_renamexf(iq,ipair)-loffset
1292 184191787 : lstooc = lspectooc_renamexf(iq,ipair)-loffset
1293 :
1294 184191787 : if (lsfrma .gt. 0) then
1295 : xfertend = xfercoef*max( 0.0_r8, &
1296 184191787 : (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) )
1297 :
1298 : ! diagnostic output start ----------------------------------------
1299 : if (ldiag1 > 0) then
1300 : if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
1301 : if (lstooa .gt. 0) then
1302 : write(iulog,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
1303 : cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
1304 : deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend), &
1305 : deltat*dqdt(i,k,lstooa), deltat*(dqdt(i,k,lstooa) + xfertend)
1306 : else
1307 : write(iulog,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
1308 : cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
1309 : deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend)
1310 : end if
1311 : end if
1312 : end if
1313 : ! diagnostic output end ------------------------------------------
1314 :
1315 :
1316 184191787 : dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend
1317 184191787 : qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac
1318 184191787 : if (lstooa .gt. 0) then
1319 184191787 : dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend
1320 184191787 : qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac
1321 184191787 : if ( l_dqdt_rnpos ) &
1322 0 : dqdt_rnpos(i,k,lstooa) = dqdt_rnpos(i,k,lstooa) + xfertend
1323 : end if
1324 : end if
1325 :
1326 441820387 : if (lsfrmc .gt. 0) then
1327 : xfertend = xfercoef*max( 0.0_r8, &
1328 184191787 : (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) )
1329 184191787 : dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend
1330 184191787 : qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac
1331 184191787 : if (lstooc .gt. 0) then
1332 184191787 : dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend
1333 184191787 : qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac
1334 : end if
1335 : end if
1336 :
1337 : end do ! "iq = 1, nspecfrm_renamexf(ipair)"
1338 :
1339 :
1340 : end do mainloop1_i
1341 : end do mainloop1_k
1342 :
1343 :
1344 : end do mainloop1_ipair
1345 :
1346 : !
1347 : ! set dotend's
1348 : !
1349 58824 : dotendrn(:) = .false.
1350 58824 : dotendqqcwrn(:) = .false.
1351 235296 : do ipair = 1, npair_renamexf
1352 1000008 : do iq = 1, nspecfrm_renamexf(ipair)
1353 764712 : lsfrma = lspecfrma_renamexf(iq,ipair) - loffset
1354 764712 : lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset
1355 764712 : lstooa = lspectooa_renamexf(iq,ipair) - loffset
1356 764712 : lstooc = lspectooc_renamexf(iq,ipair) - loffset
1357 764712 : if (lsfrma .gt. 0) then
1358 764712 : dotendrn(lsfrma) = .true.
1359 764712 : if (lstooa .gt. 0) dotendrn(lstooa) = .true.
1360 : end if
1361 941184 : if (lsfrmc .gt. 0) then
1362 764712 : dotendqqcwrn(lsfrmc) = .true.
1363 764712 : if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true.
1364 : end if
1365 : end do
1366 : end do
1367 :
1368 :
1369 : return
1370 :
1371 :
1372 : !
1373 : ! error -- renaming currently just works for 1 pair
1374 : !
1375 : 8100 write(lunout,9050) ipair
1376 : call endrun( 'modal_aero_rename_acc_crs_sub error' )
1377 : 9050 format( / '*** subr. modal_aero_rename_acc_crs_sub ***' / &
1378 : 4x, 'aerosol renaming not implemented for ipair =', i5 )
1379 :
1380 : !EOC
1381 58824 : end subroutine modal_aero_rename_acc_crs_sub
1382 :
1383 :
1384 :
1385 : !-------------------------------------------------------------------------
1386 : ! for modal aerosols in the troposphere and stratophere
1387 : ! -- allows accumulation to coarse mode exchange
1388 : !-------------------------------------------------------------------------
1389 1536 : subroutine modal_aero_rename_acc_crs_init
1390 : !
1391 : ! computes pointers for species transfer during aerosol renaming
1392 : ! (a2 --> a1 transfer)
1393 : ! transfers include number_a, number_c, mass_a, mass_c and
1394 : ! water_a
1395 : !
1396 :
1397 : implicit none
1398 :
1399 : ! local variables
1400 : integer :: i, ipair, iq, iqfrm, iqtooa, iqtooc, itmpa
1401 : integer :: l, lsfrma, lsfrmc, lstooa, lstooc, lunout
1402 : integer :: mfrm, mtoo
1403 : integer :: n1, n2, nspec
1404 : integer :: nch_lfrm, nch_ltoo, nch_mfrmid, nch_mtooid
1405 :
1406 : real (r8) :: frelax
1407 :
1408 1536 : lunout = iulog
1409 :
1410 : !
1411 : ! define "from mode" and "to mode" for each tail-xfer pairing
1412 : ! using the values in ipair_select_renamexf(:)
1413 : !
1414 1536 : npair_renamexf = 0
1415 6144 : do ipair = 1, maxpair_renamexf
1416 4608 : itmpa = ipair_select_renamexf(ipair)
1417 4608 : if (itmpa == 0) then
1418 : exit
1419 4608 : else if (itmpa == 2001) then !both mam4 and mam5
1420 1536 : mfrm = modeptr_aitken
1421 1536 : mtoo = modeptr_accum
1422 1536 : igrow_shrink_renamexf(ipair) = 1
1423 1536 : ixferable_all_needed_renamexf(ipair) = 1
1424 1536 : strat_only_renamexf(ipair) = .false.
1425 3072 : else if (itmpa == 1003) then
1426 1536 : mfrm = modeptr_accum
1427 1536 : mtoo = modeptr_coarse
1428 1536 : igrow_shrink_renamexf(ipair) = 1
1429 1536 : ixferable_all_needed_renamexf(ipair) = 0
1430 1536 : strat_only_renamexf(ipair) = .true.
1431 1536 : else if (itmpa == 1005) then
1432 0 : mfrm = modeptr_accum
1433 0 : mtoo = modeptr_stracoar
1434 0 : igrow_shrink_renamexf(ipair) = 1
1435 0 : ixferable_all_needed_renamexf(ipair) = 0
1436 0 : strat_only_renamexf(ipair) = .true.
1437 1536 : else if (itmpa == 3001) then
1438 1536 : mfrm = modeptr_coarse
1439 1536 : mtoo = modeptr_accum
1440 1536 : igrow_shrink_renamexf(ipair) = -1
1441 1536 : ixferable_all_needed_renamexf(ipair) = 0
1442 1536 : strat_only_renamexf(ipair) = .true.
1443 0 : else if (itmpa == 5001) then
1444 0 : mfrm = modeptr_stracoar
1445 0 : mtoo = modeptr_accum
1446 0 : igrow_shrink_renamexf(ipair) = -1
1447 0 : ixferable_all_needed_renamexf(ipair) = 0
1448 0 : strat_only_renamexf(ipair) = .true.
1449 : else
1450 : write(lunout,'(/2a,3(1x,i12))') &
1451 0 : '*** subr. modal_aero_rename_acc_crs_init', &
1452 0 : 'bad ipair_select_renamexf', ipair, itmpa
1453 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1454 : end if
1455 :
1456 9216 : do i = 1, ipair-1
1457 9216 : if (itmpa .eq. ipair_select_renamexf(i)) then
1458 : write(lunout,'(/2a/10(1x,i12))') &
1459 0 : '*** subr. modal_aero_rename_acc_crs_init', &
1460 0 : 'duplicates in ipair_select_renamexf', &
1461 0 : ipair_select_renamexf(1:ipair)
1462 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1463 : end if
1464 : end do
1465 :
1466 : if ( (mfrm .ge. 1) .and. (mfrm .le. ntot_amode) .and. &
1467 6144 : (mtoo .ge. 1) .and. (mtoo .le. ntot_amode) ) then
1468 4608 : npair_renamexf = ipair
1469 4608 : modefrm_renamexf(ipair) = mfrm
1470 4608 : modetoo_renamexf(ipair) = mtoo
1471 : else
1472 : write(lunout,'(/2a,3(1x,i12))') &
1473 0 : '*** subr. modal_aero_rename_acc_crs_init', &
1474 0 : 'bad mfrm or mtoo', ipair, mfrm, mtoo
1475 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1476 : end if
1477 : end do ! ipair
1478 :
1479 1536 : if (npair_renamexf .le. 0) then
1480 : write(lunout,'(/a/a,3(1x,i12))') &
1481 0 : '*** subr. modal_aero_rename_acc_crs_init -- npair_renamexf = 0'
1482 0 : return
1483 : end if
1484 :
1485 :
1486 : !
1487 : ! define species involved in each tail-xfer pairing
1488 : ! (include aerosol water)
1489 : !
1490 6144 : do 1900 ipair = 1, npair_renamexf
1491 4608 : mfrm = modefrm_renamexf(ipair)
1492 4608 : mtoo = modetoo_renamexf(ipair)
1493 4608 : ixferable_all_renamexf(ipair) = 1
1494 :
1495 4608 : if (mfrm < 10) then
1496 : nch_mfrmid = 1
1497 0 : else if (mfrm < 100) then
1498 : nch_mfrmid = 2
1499 : else
1500 0 : nch_mfrmid = 3
1501 : end if
1502 4608 : if (mtoo < 10) then
1503 : nch_mtooid = 1
1504 0 : else if (mtoo < 100) then
1505 : nch_mtooid = 2
1506 : else
1507 0 : nch_mtooid = 3
1508 : end if
1509 :
1510 4608 : nspec = 0
1511 33792 : do 1490 iqfrm = -1, nspec_amode(mfrm)
1512 29184 : if (iqfrm .eq. -1) then
1513 4608 : lsfrma = numptr_amode(mfrm)
1514 4608 : lstooa = numptr_amode(mtoo)
1515 4608 : lsfrmc = numptrcw_amode(mfrm)
1516 4608 : lstooc = numptrcw_amode(mtoo)
1517 24576 : else if (iqfrm .eq. 0) then
1518 : ! bypass transfer of aerosol water due to renaming
1519 : goto 1490
1520 : ! lsfrma = lwaterptr_amode(mfrm)
1521 : ! lsfrmc = 0
1522 : ! lstooa = lwaterptr_amode(mtoo)
1523 : ! lstooc = 0
1524 : else
1525 19968 : lsfrma = lmassptr_amode(iqfrm,mfrm)
1526 19968 : lsfrmc = lmassptrcw_amode(iqfrm,mfrm)
1527 19968 : lstooa = 0
1528 19968 : lstooc = 0
1529 : end if
1530 :
1531 24576 : if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then
1532 0 : write(lunout,9100) ipair, mfrm, iqfrm, lsfrma
1533 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1534 : end if
1535 24576 : if (iqfrm .le. 0) goto 1430
1536 :
1537 19968 : if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then
1538 0 : write(lunout,9102) ipair, mfrm, iqfrm, lsfrmc
1539 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1540 : end if
1541 :
1542 : ! find "too" species having same name (except for mode number) as the "frm" species
1543 19968 : nch_lfrm = len(trim(cnst_name(lsfrma))) - nch_mfrmid
1544 19968 : iqtooa = -99
1545 69120 : do iq = 1, nspec_amode(mtoo)
1546 64512 : l = lmassptr_amode(iq,mtoo)
1547 64512 : if ((l .lt. 1) .or. (l .gt. pcnst)) cycle
1548 64512 : nch_ltoo = len(trim(cnst_name(l))) - nch_mtooid
1549 64512 : if ( cnst_name(lsfrma)(1:nch_lfrm) == &
1550 4608 : cnst_name(l )(1:nch_ltoo) ) then
1551 15360 : lstooa = l
1552 15360 : iqtooa = iq
1553 15360 : exit
1554 : end if
1555 : end do
1556 :
1557 19968 : nch_lfrm = len(trim(cnst_name_cw(lsfrmc))) - nch_mfrmid
1558 19968 : iqtooc = -99
1559 69120 : do iq = 1, nspec_amode(mtoo)
1560 64512 : l = lmassptrcw_amode(iq,mtoo)
1561 64512 : if ((l .lt. 1) .or. (l .gt. pcnst)) cycle
1562 64512 : nch_ltoo = len(trim(cnst_name_cw(l))) - nch_mtooid
1563 64512 : if ( cnst_name_cw(lsfrmc)(1:nch_lfrm) == &
1564 9216 : cnst_name_cw(l )(1:nch_ltoo) ) then
1565 15360 : lstooc = l
1566 15360 : iqtooc = iq
1567 15360 : exit
1568 : end if
1569 : end do
1570 :
1571 24576 : 1430 if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0
1572 24576 : if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0
1573 :
1574 24576 : if ((lstooa .eq. 0) .or. (lstooc .eq. 0)) then
1575 : if ( ( masterproc ) .or. &
1576 4608 : ( (lstooa .ne. 0) .or. (lstooc .ne. 0) ) .or. &
1577 4608 : ( ixferable_all_needed_renamexf(ipair) .gt. 0 ) ) then
1578 6 : if (lstooa .eq. 0) &
1579 6 : write(lunout,9104) trim(cnst_name(lsfrma)), &
1580 12 : ipair, mfrm, iqfrm, lsfrma, iqtooa, lstooa
1581 6 : if (lstooc .eq. 0) &
1582 6 : write(lunout,9106) trim(cnst_name_cw(lsfrmc)), &
1583 12 : ipair, mfrm, iqfrm, lsfrmc, iqtooc, lstooc
1584 : end if
1585 4608 : if ((lstooa .ne. 0) .or. (lstooc .ne. 0)) then
1586 0 : write(lunout,9108)
1587 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1588 : end if
1589 4608 : if (ixferable_all_needed_renamexf(ipair) .gt. 0) then
1590 0 : write(lunout,9109)
1591 0 : call endrun( 'modal_aero_rename_acc_crs_init error' )
1592 : end if
1593 4608 : ixferable_all_renamexf(ipair) = 0
1594 4608 : if (iqfrm .gt. 0) then
1595 4608 : ixferable_a_renamexf(iqfrm,ipair) = 0
1596 4608 : ixferable_c_renamexf(iqfrm,ipair) = 0
1597 : end if
1598 : else
1599 19968 : nspec = nspec + 1
1600 19968 : lspecfrma_renamexf(nspec,ipair) = lsfrma
1601 19968 : lspectooa_renamexf(nspec,ipair) = lstooa
1602 19968 : lspecfrmc_renamexf(nspec,ipair) = lsfrmc
1603 19968 : lspectooc_renamexf(nspec,ipair) = lstooc
1604 19968 : if (iqfrm .gt. 0) then
1605 15360 : ixferable_a_renamexf(iqfrm,ipair) = 1
1606 15360 : ixferable_c_renamexf(iqfrm,ipair) = 1
1607 : end if
1608 : end if
1609 4608 : 1490 continue
1610 :
1611 4608 : nspecfrm_renamexf(ipair) = nspec
1612 1536 : 1900 continue
1613 :
1614 : 9100 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1615 : 'lspecfrma out of range' / &
1616 : 'ipair, modefrm, ispecfrm, lspecfrma =', 4i6 )
1617 : 9102 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1618 : 'lspecfrmc out of range' / &
1619 : 'ipair, modefrm, ispecfrm, lspecfrmc =', 4i6 )
1620 : 9104 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1621 : 'lspectooa out of range for', 2x, a / &
1622 : 'ipair, modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 6i6 )
1623 : 9106 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1624 : 'lspectooc out of range for', 2x, a / &
1625 : 'ipair, modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 6i6 )
1626 : 9108 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1627 : 'only one of lspectooa and lspectooc is out of range' )
1628 : 9109 format( / '*** subr. modal_aero_rename_acc_crs_init' / &
1629 : 'all species must be xferable for this pair' )
1630 :
1631 :
1632 : !
1633 : !
1634 : ! initialize some working variables
1635 : !
1636 : !
1637 7680 : ido_mode_calcaa(:) = 0
1638 1536 : frelax = 27.0_r8
1639 :
1640 6144 : do ipair = 1, npair_renamexf
1641 4608 : mfrm = modefrm_renamexf(ipair)
1642 4608 : mtoo = modetoo_renamexf(ipair)
1643 4608 : ido_mode_calcaa(mfrm) = 1
1644 :
1645 4608 : factoraa(mfrm) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mfrm)**2))
1646 4608 : factoraa(mtoo) = (pi/6._r8)*exp(4.5_r8*(alnsg_amode(mtoo)**2))
1647 4608 : factoryy(mfrm) = sqrt( 0.5_r8 )/alnsg_amode(mfrm)
1648 :
1649 : ! dryvol_smallest is a very small volume mixing ratio (m3-AP/kmol-air)
1650 : ! used for avoiding overflow. it corresponds to dp = 1 nm
1651 : ! and number = 1e-5 #/mg-air ~= 1e-5 #/cm3-air
1652 4608 : dryvol_smallest(mfrm) = 1.0e-25_r8
1653 4608 : v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax
1654 4608 : v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax
1655 :
1656 4608 : factor_3alnsg2(ipair) = 3.0_r8 * (alnsg_amode(mfrm)**2)
1657 :
1658 : dp_cut(ipair) = sqrt( &
1659 0 : dgnum_amode(mfrm)*exp(1.5_r8*(alnsg_amode(mfrm)**2)) * &
1660 4608 : dgnum_amode(mtoo)*exp(1.5_r8*(alnsg_amode(mtoo)**2)) )
1661 4608 : dp_xferall_thresh(ipair) = dgnum_amode(mtoo)
1662 4608 : dp_xfernone_threshaa(ipair) = dgnum_amode(mfrm)
1663 4608 : if (((mfrm == modeptr_accum) .and. (mtoo == modeptr_coarse)).or.&
1664 : ((mfrm == modeptr_accum) .and. (mtoo == modeptr_stracoar))) then
1665 1536 : dp_cut(ipair) = 4.4e-7_r8
1666 1536 : dp_xfernone_threshaa(ipair) = 1.6e-7_r8
1667 1536 : dp_xferall_thresh(ipair) = 4.7e-7_r8
1668 3072 : else if (((mfrm == modeptr_coarse) .and. (mtoo == modeptr_accum)).or.&
1669 : ((mfrm == modeptr_stracoar) .and. (mtoo == modeptr_accum))) then
1670 1536 : dp_cut(ipair) = 4.4e-7_r8
1671 1536 : dp_xfernone_threshaa(ipair) = 4.4e-7_r8
1672 1536 : dp_xferall_thresh(ipair) = 4.1e-7_r8
1673 : end if
1674 :
1675 4608 : lndp_cut(ipair) = log( dp_cut(ipair) )
1676 6144 : dp_belowcut(ipair) = 0.99_r8*dp_cut(ipair)
1677 : end do
1678 :
1679 :
1680 : !
1681 : ! output results
1682 : !
1683 1536 : if ( masterproc ) then
1684 :
1685 2 : write(lunout,9310)
1686 2 : write(lunout,'(a,1x,i12)') 'method_optbb_renamexf', method_optbb_renamexf
1687 :
1688 8 : do 2900 ipair = 1, npair_renamexf
1689 6 : mfrm = modefrm_renamexf(ipair)
1690 6 : mtoo = modetoo_renamexf(ipair)
1691 12 : write(lunout,9320) ipair, mfrm, mtoo, &
1692 18 : igrow_shrink_renamexf(ipair), ixferable_all_renamexf(ipair)
1693 :
1694 32 : do iq = 1, nspecfrm_renamexf(ipair)
1695 26 : lsfrma = lspecfrma_renamexf(iq,ipair)
1696 26 : lstooa = lspectooa_renamexf(iq,ipair)
1697 26 : lsfrmc = lspecfrmc_renamexf(iq,ipair)
1698 26 : lstooc = lspectooc_renamexf(iq,ipair)
1699 26 : if (lstooa .gt. 0) then
1700 26 : write(lunout,9330) lsfrma, cnst_name(lsfrma), &
1701 52 : lstooa, cnst_name(lstooa)
1702 : else
1703 0 : write(lunout,9340) lsfrma, cnst_name(lsfrma)
1704 : end if
1705 32 : if (lstooc .gt. 0) then
1706 26 : write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), &
1707 52 : lstooc, cnst_name_cw(lstooc)
1708 0 : else if (lsfrmc .gt. 0) then
1709 0 : write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc)
1710 : else
1711 0 : write(lunout,9350)
1712 : end if
1713 : end do
1714 :
1715 6 : if (igrow_shrink_renamexf(ipair) > 0) then
1716 4 : write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumhi ', &
1717 8 : dgnum_amode(mfrm), dgnumhi_amode(mfrm)
1718 4 : write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumlo ', &
1719 8 : dgnum_amode(mtoo), dgnumlo_amode(mtoo)
1720 : else
1721 2 : write(lunout,'(5x,a,1p,2e12.3)') 'mfrm dgnum, dgnumlo ', &
1722 4 : dgnum_amode(mfrm), dgnumlo_amode(mfrm)
1723 2 : write(lunout,'(5x,a,1p,2e12.3)') 'mtoo dgnum, dgnumhi ', &
1724 4 : dgnum_amode(mtoo), dgnumhi_amode(mtoo)
1725 : end if
1726 :
1727 12 : write(lunout,'(5x,a,1p,2e12.3)') 'dp_cut ', &
1728 18 : dp_cut(ipair)
1729 12 : write(lunout,'(5x,a,1p,2e12.3)') 'dp_xfernone_threshaa', &
1730 18 : dp_xfernone_threshaa(ipair)
1731 12 : write(lunout,'(5x,a,1p,2e12.3)') 'dp_xferall_thresh ', &
1732 18 : dp_xferall_thresh(ipair)
1733 :
1734 2 : 2900 continue
1735 2 : write(lunout,*)
1736 :
1737 : end if ! ( masterproc )
1738 :
1739 : 9310 format( / 'subr. modal_aero_rename_acc_crs_init' )
1740 : 9320 format( / 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3, &
1741 : 5x, 'igrow_shrink', i3, 5x, 'ixferable_all', i3 )
1742 : 9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a )
1743 : 9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' )
1744 : 9350 format( 5x, 'no corresponding activated species' )
1745 :
1746 :
1747 : return
1748 : end subroutine modal_aero_rename_acc_crs_init
1749 :
1750 : !----------------------------------------------------------------------
1751 :
1752 : end module modal_aero_rename
|
