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