chem/module_cam_mam_rename.F

   1 #define WRF_PORT
   2 #define MODAL_AERO
   3 ! module_cam_mam_rename.F
   4 ! adapted from cam3 modal_aero_rename.F90 by r.c.easter, june 2010
   5 ! Updated to CESM1.0.3 (CAM5.1.01) by Balwinder.Singh@pnnl.gov
   6 ! 2010-07-03 rce notes
   7 !    pcnstxx
   8 !       in cam, pcnstxx = gas_pcnst is a constant,
   9 !          but it is only used for dimensions of subr arguments in this file,
  10 !          so it does not have to be a constant for this file
  11 !       in wrf-chem, pcnstxx => gas_pcnst_modal_aero is a variable
  12 !--------------------------------------------------------------
  13 ! modal_aero_rename.F90
  14
  15
  16 !----------------------------------------------------------------------
  17 !BOP
  18 !
  19 ! !MODULE: modal_aero_rename --- modal aerosol mode merging (renaming)
  20 !
  21 ! !INTERFACE:
  22   module modal_aero_rename
  23
  24 ! !USES:
  25   use shr_kind_mod, only : r8 => shr_kind_r8
  26 #ifndef WRF_PORT
  27   use abortutils, only : endrun
  28 #endif
  29   use modal_aero_data, only:  maxd_aspectype
  30 #ifndef WRF_PORT
  31   use chem_mods,    only:  gas_pcnst
  32 #else
  33   use module_cam_support, only: &
  34         pcnstxx => gas_pcnst_modal_aero, &
  35         endrun
  36 #endif
  37
  38   implicit none
  39   private
  40   save
  41
  42 ! !PUBLIC MEMBER FUNCTIONS:
  43   public modal_aero_rename_sub, modal_aero_rename_init
  44
  45 ! !PUBLIC DATA MEMBERS:
  46 #ifndef WRF_PORT
  47   integer, parameter :: pcnstxx = gas_pcnst
  48 #endif
  49   integer, parameter, public :: maxpair_renamexf = 1
  50   integer, parameter, public :: maxspec_renamexf = maxd_aspectype
  51
  52   integer, public :: npair_renamexf = -123456789
  53   integer, public :: modefrm_renamexf(maxpair_renamexf)
  54   integer, public :: modetoo_renamexf(maxpair_renamexf)
  55   integer, public :: nspecfrm_renamexf(maxpair_renamexf)
  56   integer, public :: lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf)
  57   integer, public :: lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf)
  58   integer, public :: lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf)
  59   integer, public :: lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf)
  60
  61 ! !DESCRIPTION: This module implements ...
  62 !
  63 ! !REVISION HISTORY:
  64 !
  65 !   RCE 07.04.13:  Adapted from MIRAGE2 code
  66 !
  67 !EOP
  68 !----------------------------------------------------------------------
  69 !BOC
  70
  71 ! list private module data here
  72
  73 !EOC
  74 !----------------------------------------------------------------------
  75
  76
  77   contains
  78
  79 !----------------------------------------------------------------------
  80 !BOP
  81 ! !ROUTINE:  modal_aero_rename_sub --- ...
  82 !
  83 ! !INTERFACE:
  84         subroutine modal_aero_rename_sub(                       &
  85                         fromwhere,         lchnk,               &
  86                         ncol,              nstep,               &
  87                         loffset,           deltat,              &
  88                         latndx,            lonndx,              &
  89                         pdel,                                   &
  90                         dotendrn,          q,                   &
  91                         dqdt,              dqdt_other,          &
  92                         dotendqqcwrn,      qqcw,                &
  93                         dqqcwdt,           dqqcwdt_other,       &
  94                         is_dorename_atik,  dorename_atik,       &
  95                         jsrflx_rename,     nsrflx,              &
  96                         qsrflx,            qqcwsrflx            )
  97
  98 ! !USES:
  99    use shr_kind_mod, only : r4 => shr_kind_r4
 100    use modal_aero_data
 101 #ifndef WRF_PORT
 102    use ppgrid, only:  pcols, pver
 103    use constituents, only: pcnst, cnst_name
 104    use mo_constants,  only:  pi
 105 #endif
 106    use physconst, only: gravit, mwdry
 107 #ifndef WRF_PORT
 108    use units, only: getunit
 109 #else
 110    use module_cam_support, only: &
 111         pcnst => pcnst_runtime, &
 112         pcols, pver
 113    use constituents, only: cnst_name
 114    use physconst, only: pi
 115 #endif
 116
 117    implicit none
 118
 119
 120 ! !PARAMETERS:
 121    character(len=*), intent(in) :: fromwhere    ! identifies which module
 122                                                 ! is making the call
 123    integer,  intent(in)    :: lchnk                ! chunk identifier
 124    integer,  intent(in)    :: ncol                 ! number of atmospheric column
 125    integer,  intent(in)    :: nstep                ! model time-step number
 126    integer,  intent(in)    :: loffset              ! offset applied to modal aero "ptrs"
 127    real(r8), intent(in)    :: deltat               ! time step (s)
 128    integer,  intent(in)    :: latndx(pcols), lonndx(pcols)
 129
 130    real(r8), intent(in)    :: pdel(pcols,pver)     ! pressure thickness of levels (Pa)
 131    real(r8), intent(in)    :: q(ncol,pver,pcnstxx) ! tracer mixing ratio array
 132                                                    ! *** MUST BE mol/mol-air or #/mol-air
 133                                                    ! *** NOTE ncol and pcnstxx dimensions
 134    real(r8), intent(in)    :: qqcw(ncol,pver,pcnstxx) ! like q but for cloud-borne species
 135
 136    real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx)  ! TMR tendency array;
 137                               ! incoming dqdt = tendencies for the
 138                               !     "fromwhere" continuous growth process
 139                               ! the renaming tendencies are added on
 140                               ! *** NOTE ncol and pcnstxx dimensions
 141    real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx)
 142    real(r8), intent(in)    :: dqdt_other(ncol,pver,pcnstxx)
 143                               ! tendencies for "other" continuous growth process
 144                               ! currently in cam3
 145                               !     dqdt is from gas (h2so4, nh3) condensation
 146                               !     dqdt_other is from aqchem and soa
 147                               ! *** NOTE ncol and pcnstxx dimensions
 148    real(r8), intent(in)    :: dqqcwdt_other(ncol,pver,pcnstxx)
 149    logical,  intent(inout) :: dotendrn(pcnstxx) ! identifies the species for which
 150                               !     renaming dqdt is computed
 151    logical,  intent(inout) :: dotendqqcwrn(pcnstxx)
 152
 153    logical,  intent(in)    :: is_dorename_atik          ! true if dorename_atik is provided
 154    logical,  intent(in)    :: dorename_atik(ncol,pver) ! true if renaming should
 155                                                         ! be done at i,k
 156    integer,  intent(in)    :: jsrflx_rename        ! qsrflx index for renaming
 157    integer,  intent(in)    :: nsrflx               ! last dimension of qsrflx
 158
 159    real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx)
 160                               ! process-specific column tracer tendencies
 161    real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx)
 162
 163 ! !DESCRIPTION:
 164 ! computes TMR (tracer mixing ratio) tendencies for "mode renaming"
 165 !    during a continuous growth process
 166 ! currently this transfers number and mass (and surface) from the aitken
 167 !    to accumulation mode after gas condensation or stratiform-cloud
 168 !    aqueous chemistry
 169 ! (convective cloud aqueous chemistry not yet implemented)
 170 !
 171 ! !REVISION HISTORY:
 172 !   RCE 07.04.13:  Adapted from MIRAGE2 code
 173 !
 174 !EOP
 175 !----------------------------------------------------------------------
 176 !BOC
 177
 178 ! local variables
 179    integer, parameter :: ldiag1=-1
 180    integer :: i, icol_diag, ipair, iq, j, k, l, l1, l2, la, lc, lunout
 181    integer :: lsfrma, lsfrmc, lstooa, lstooc
 182    integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a
 183    integer :: idomode(ntot_amode)
 184    integer, save :: lun = -1  ! logical unit for diagnostics (6, or other
 185                               ! if a special diagnostics file is opened)
 186
 187
 188    real (r8) :: deldryvol_a(ncol,pver,ntot_amode)
 189    real (r8) :: deldryvol_c(ncol,pver,ntot_amode)
 190    real (r8) :: deltatinv
 191    real (r8) :: dp_belowcut(maxpair_renamexf)
 192    real (r8) :: dp_cut(maxpair_renamexf)
 193    real (r8) :: dgn_aftr, dgn_xfer
 194    real (r8) :: dgn_t_new, dgn_t_old
 195    real (r8) :: dryvol_t_del, dryvol_t_new
 196    real (r8) :: dryvol_t_old, dryvol_t_oldbnd
 197    real (r8) :: dryvol_a(ncol,pver,ntot_amode)
 198    real (r8) :: dryvol_c(ncol,pver,ntot_amode)
 199    real (r8) :: dryvol_smallest(ntot_amode)
 200    real (r8) :: dum
 201    real (r8) :: dum3alnsg2(maxpair_renamexf)
 202    real (r8) :: dum_m2v, dum_m2vdt
 203    real (r8) :: factoraa(ntot_amode)
 204    real (r8) :: factoryy(ntot_amode)
 205    real (r8) :: frelax
 206    real (r8) :: lndp_cut(maxpair_renamexf)
 207    real (r8) :: lndgn_new, lndgn_old
 208    real (r8) :: lndgv_new, lndgv_old
 209    real (r8) :: num_t_old, num_t_oldbnd
 210    real (r8) :: onethird
 211    real (r8) :: pdel_fac
 212    real (r8) :: tailfr_volnew, tailfr_volold
 213    real (r8) :: tailfr_numnew, tailfr_numold
 214    real (r8) :: v2nhirlx(ntot_amode), v2nlorlx(ntot_amode)
 215    real (r8) :: xfercoef, xfertend
 216    real (r8) :: xferfrac_vol, xferfrac_num, xferfrac_max
 217
 218    real (r4) :: yn_tail, yv_tail
 219    real (r4) :: erfc
 220
 221
 222 ! begin
 223         lunout = 6
 224
 225 !   get logical unit (for output to dumpconv, deactivate the "lun = 6")
 226         lun = 6
 227 #ifndef WRF_PORT
 228         if (lun < 1) then
 229            lun = getunit()
 230            open( unit=lun, file='dump.rename',   &
 231                         status='unknown', form='formatted' )
 232         end if
 233 #endif
 234
 235
 236 !
 237 !   calculations done once on initial entry
 238 !
 239 !   "init" is now done through chem_init (and things under it)
 240 !       if (npair_renamexf .eq. -123456789) then
 241 !           npair_renamexf = 0
 242 !           call modal_aero_rename_init
 243 !       end if
 244
 245 !
 246 !   check if any renaming pairs exist
 247 !
 248         if (npair_renamexf .le. 0) return
 249 !       if (ncol .ne. -123456789) return
 250 !       if (fromwhere .eq. 'aqchem') return
 251
 252 !
 253 !   compute aerosol dry-volume for the "from mode" of each renaming pair
 254 !   also compute dry-volume change during the continuous growth process
 255 !       using the incoming dqdt*deltat
 256 !
 257         deltatinv = 1.0/(deltat*(1.0d0 + 1.0d-15))
 258         onethird = 1.0/3.0
 259         frelax = 27.0
 260         xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8)   ! 1-eps
 261
 262         do n = 1, ntot_amode
 263             idomode(n) = 0
 264         end do
 265
 266         do ipair = 1, npair_renamexf
 267             if (ipair .gt. 1) goto 8100
 268             idomode(modefrm_renamexf(ipair)) = 1
 269
 270             mfrm = modefrm_renamexf(ipair)
 271             mtoo = modetoo_renamexf(ipair)
 272             factoraa(mfrm) = (pi/6.)*exp(4.5*(alnsg_amode(mfrm)**2))
 273             factoraa(mtoo) = (pi/6.)*exp(4.5*(alnsg_amode(mtoo)**2))
 274             factoryy(mfrm) = sqrt( 0.5 )/alnsg_amode(mfrm)
 275 !   dryvol_smallest is a very small volume mixing ratio (m3-AP/kmol-air)
 276 !   used for avoiding overflow.  it corresponds to dp = 1 nm
 277 !   and number = 1e-5 #/mg-air ~= 1e-5 #/cm3-air
 278             dryvol_smallest(mfrm) = 1.0e-25
 279             v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax
 280             v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax
 281
 282             dum3alnsg2(ipair) = 3.0 * (alnsg_amode(mfrm)**2)
 283             dp_cut(ipair) = sqrt(   &
 284                 dgnum_amode(mfrm)*exp(1.5*(alnsg_amode(mfrm)**2)) *   &
 285                 dgnum_amode(mtoo)*exp(1.5*(alnsg_amode(mtoo)**2)) )
 286             lndp_cut(ipair) = log( dp_cut(ipair) )
 287             dp_belowcut(ipair) = 0.99*dp_cut(ipair)
 288         end do
 289
 290         do n = 1, ntot_amode
 291             if (idomode(n) .gt. 0) then
 292                 dryvol_a(1:ncol,:,n) = 0.0_r8
 293                 dryvol_c(1:ncol,:,n) = 0.0_r8
 294                 deldryvol_a(1:ncol,:,n) = 0.0_r8
 295                 deldryvol_c(1:ncol,:,n) = 0.0_r8
 296                 do l1 = 1, nspec_amode(n)
 297                     l2 = lspectype_amode(l1,n)
 298 !   dum_m2v converts (kmol-AP/kmol-air) to (m3-AP/kmol-air)
 299 !            [m3-AP/kmol-AP]= [kg-AP/kmol-AP]  / [kg-AP/m3-AP]
 300                     dum_m2v = specmw_amode(l2) / specdens_amode(l2)
 301                     dum_m2vdt = dum_m2v*deltat
 302                     la = lmassptr_amode(l1,n)-loffset
 303                     if (la > 0) then
 304                     dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n)    &
 305                         + dum_m2v*max( 0.0_r8,   &
 306                           q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) )
 307                     deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n)    &
 308                         + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt
 309                     end if
 310
 311                     lc = lmassptrcw_amode(l1,n)-loffset
 312                     if (lc > 0) then
 313                     dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n)    &
 314                         + dum_m2v*max( 0.0_r8,   &
 315                           qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) )
 316                     deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n)    &
 317                         + (dqqcwdt_other(1:ncol,:,lc) +   &
 318                                  dqqcwdt(1:ncol,:,lc))*dum_m2vdt
 319                     end if
 320                 end do
 321             end if
 322         end do
 323
 324
 325
 326 !
 327 !   loop over levels and columns to calc the renaming
 328 !
 329 mainloop1_k:  do k = 1, pver
 330 mainloop1_i:  do i = 1, ncol
 331
 332 !   if dorename_atik is provided, then check if renaming needed at this i,k
 333         if (is_dorename_atik) then
 334             if (.not. dorename_atik(i,k)) cycle mainloop1_i
 335         end if
 336         pdel_fac = pdel(i,k)/gravit
 337
 338 !
 339 !   loop over renameing pairs
 340 !
 341 mainloop1_ipair:  do ipair = 1, npair_renamexf
 342
 343         mfrm = modefrm_renamexf(ipair)
 344         mtoo = modetoo_renamexf(ipair)
 345
 346 !   dryvol_t_old is the old total (a+c) dry-volume for the "from" mode
 347 !       in m^3-AP/kmol-air
 348 !   dryvol_t_new is the new total dry-volume
 349 !       (old/new = before/after the continuous growth)
 350         dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm)
 351         dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm)
 352         dryvol_t_new = dryvol_t_old + dryvol_t_del
 353         dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
 354
 355 !   no renaming if dryvol_t_new ~ 0 or dryvol_t_del ~ 0
 356         if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair
 357         if (dryvol_t_del .le. 1.0e-6*dryvol_t_oldbnd) cycle mainloop1_ipair
 358
 359 !   num_t_old is total number in particles/kmol-air
 360         num_t_old = q(i,k,numptr_amode(mfrm)-loffset)
 361         num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset)
 362         num_t_old = max( 0.0_r8, num_t_old )
 363         dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
 364         num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old )
 365         num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd )
 366
 367 !   no renaming if dgnum < "base" dgnum,
 368         dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird
 369         if (dgn_t_new .le. dgnum_amode(mfrm)) cycle mainloop1_ipair
 370
 371 !   compute new fraction of number and mass in the tail (dp > dp_cut)
 372         lndgn_new = log( dgn_t_new )
 373         lndgv_new = lndgn_new + dum3alnsg2(ipair)
 374         yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm)
 375         yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm)
 376         tailfr_numnew = 0.5*erfc( yn_tail )
 377         tailfr_volnew = 0.5*erfc( yv_tail )
 378
 379 !   compute old fraction of number and mass in the tail (dp > dp_cut)
 380         dgn_t_old =   &
 381                 (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird
 382 !   if dgn_t_new exceeds dp_cut, use the minimum of dgn_t_old and
 383 !   dp_belowcut to guarantee some transfer
 384         if (dgn_t_new .ge. dp_cut(ipair)) then
 385             dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) )
 386         end if
 387         lndgn_old = log( dgn_t_old )
 388         lndgv_old = lndgn_old + dum3alnsg2(ipair)
 389         yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm)
 390         yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm)
 391         tailfr_numold = 0.5*erfc( yn_tail )
 392         tailfr_volold = 0.5*erfc( yv_tail )
 393
 394 !   transfer fraction is difference between new and old tail-fractions
 395 !   transfer fraction for number cannot exceed that of mass
 396         dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old
 397         if (dum .le. 0.0_r8) cycle mainloop1_ipair
 398
 399         xferfrac_vol = min( dum, dryvol_t_new )/dryvol_t_new
 400         xferfrac_vol = min( xferfrac_vol, xferfrac_max )
 401         xferfrac_num = tailfr_numnew - tailfr_numold
 402         xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) )
 403
 404 !   diagnostic output start ----------------------------------------
 405         if (ldiag1 > 0) then
 406         icol_diag = -1
 407         if ((lonndx(i) == 37) .and. (latndx(i) == 23)) icol_diag = i
 408         if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
 409  !      write(lun,97010) fromwhere, nstep, lchnk, i, k, ipair
 410         write(lun,97010) fromwhere, nstep, latndx(i), lonndx(i), k, ipair
 411         write(lun,97020) 'drv old/oldbnd/new/del     ',   &
 412                 dryvol_t_old, dryvol_t_oldbnd, dryvol_t_new, dryvol_t_del
 413         write(lun,97020) 'num old/oldbnd, dgnold/new ',   &
 414                 num_t_old, num_t_oldbnd, dgn_t_old, dgn_t_new
 415         write(lun,97020) 'tailfr v_old/new, n_old/new',   &
 416                 tailfr_volold, tailfr_volnew, tailfr_numold, tailfr_numnew
 417         dum = max(1.0d-10,xferfrac_vol) / max(1.0d-10,xferfrac_num)
 418         dgn_xfer = dgn_t_new * dum**onethird
 419         dum = max(1.0d-10,(1.0d0-xferfrac_vol)) /   &
 420                max(1.0d-10,(1.0d0-xferfrac_num))
 421         dgn_aftr = dgn_t_new * dum**onethird
 422         write(lun,97020) 'xferfrac_v/n; dgn_xfer/aftr',   &
 423                 xferfrac_vol, xferfrac_num, dgn_xfer, dgn_aftr
 424  !97010 format( / 'RENAME ', a, '  nx,lc,i,k,ip', i8, 4i4 )
 425  97010  format( / 'RENAME ', a, '  nx,lat,lon,k,ip', i8, 4i4 )
 426  97020  format( a, 6(1pe15.7) )
 427         end if
 428         end if
 429 !   diagnostic output end   ------------------------------------------
 430
 431
 432 !
 433 !   compute tendencies for the renaming transfer
 434 !
 435         j = jsrflx_rename
 436         do iq = 1, nspecfrm_renamexf(ipair)
 437             xfercoef = xferfrac_vol*deltatinv
 438             if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv
 439
 440             lsfrma = lspecfrma_renamexf(iq,ipair)-loffset
 441             lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset
 442             lstooa = lspectooa_renamexf(iq,ipair)-loffset
 443             lstooc = lspectooc_renamexf(iq,ipair)-loffset
 444
 445             if (lsfrma .gt. 0) then
 446                 xfertend = xfercoef*max( 0.0_r8,   &
 447                             (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) )
 448
 449 !   diagnostic output start ----------------------------------------
 450                 if (ldiag1 > 0) then
 451                 if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
 452                   if (lstooa .gt. 0) then
 453                     write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq,   &
 454                         cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset),   &
 455                         deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend),   &
 456                         deltat*dqdt(i,k,lstooa), deltat*(dqdt(i,k,lstooa) + xfertend)
 457                   else
 458                     write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq,   &
 459                         cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset),   &
 460                         deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend)
 461                   end if
 462                 end if
 463                 end if
 464 !   diagnostic output end   ------------------------------------------
 465
 466
 467                 dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend
 468                 qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac
 469                 if (lstooa .gt. 0) then
 470                     dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend
 471                     qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac
 472                 end if
 473             end if
 474
 475             if (lsfrmc .gt. 0) then
 476                 xfertend = xfercoef*max( 0.0_r8,   &
 477                             (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) )
 478                 dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend
 479                 qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac
 480                 if (lstooc .gt. 0) then
 481                     dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend
 482                     qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac
 483                 end if
 484             end if
 485
 486         end do   ! "iq = 1, nspecfrm_renamexf(ipair)"
 487
 488
 489         end do mainloop1_ipair
 490
 491
 492         end do mainloop1_i
 493         end do mainloop1_k
 494
 495 !
 496 !   set dotend's
 497 !
 498         dotendrn(:) = .false.
 499         dotendqqcwrn(:) = .false.
 500         do ipair = 1, npair_renamexf
 501         do iq = 1, nspecfrm_renamexf(ipair)
 502             lsfrma = lspecfrma_renamexf(iq,ipair) - loffset
 503             lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset
 504             lstooa = lspectooa_renamexf(iq,ipair) - loffset
 505             lstooc = lspectooc_renamexf(iq,ipair) - loffset
 506             if (lsfrma .gt. 0) then
 507                 dotendrn(lsfrma) = .true.
 508                 if (lstooa .gt. 0) dotendrn(lstooa) = .true.
 509             end if
 510             if (lsfrmc .gt. 0) then
 511                 dotendqqcwrn(lsfrmc) = .true.
 512                 if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true.
 513             end if
 514         end do
 515         end do
 516
 517
 518         return
 519
 520
 521 !
 522 !   error -- renaming currently just works for 1 pair
 523 !
 524 8100    write(lunout,9050) ipair
 525         call endrun( 'modal_aero_rename_sub error' )
 526 9050    format( / '*** subr. modal_aero_rename_sub ***' /   &
 527             4x, 'aerosol renaming not implemented for ipair =', i5 )
 528
 529 !EOC
 530         end subroutine modal_aero_rename_sub
 531
 532
 533
 534 !-------------------------------------------------------------------------
 535         subroutine modal_aero_rename_init
 536 !
 537 !   computes pointers for species transfer during aerosol renaming
 538 !       (a2 --> a1 transfer)
 539 !   transfers include number_a, number_c, mass_a, mass_c and
 540 !       water_a
 541 !
 542         use modal_aero_data
 543 #ifndef WRF_PORT
 544         use constituents, only: pcnst, cnst_name
 545         use spmd_utils,   only: masterproc
 546 #else
 547         use module_cam_support, only: &
 548                 pcnst => pcnst_runtime, &
 549                 masterproc
 550         use constituents, only: cnst_name
 551 #endif
 552
 553         implicit none
 554
 555 !   local variables
 556         integer ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa,   &
 557           lsfrma, lsfrmc, lstooa, lstooc, lunout,   &
 558           mfrm, mtoo, n1, n2, nsamefrm, nsametoo, nspec
 559
 560
 561         lunout = 6
 562 !
 563 !   define "from mode" and "to mode" for each tail-xfer pairing
 564 !       currently just a2-->a1
 565 !
 566         n1 = modeptr_accum
 567         n2 = modeptr_aitken
 568         if ((n1 .gt. 0) .and. (n2 .gt. 0)) then
 569             npair_renamexf = 1
 570             modefrm_renamexf(1) = n2
 571             modetoo_renamexf(1) = n1
 572         else
 573             npair_renamexf = 0
 574             return
 575         end if
 576
 577 !
 578 !   define species involved in each tail-xfer pairing
 579 !       (include aerosol water)
 580 !
 581         do 1900 ipair = 1, npair_renamexf
 582         mfrm = modefrm_renamexf(ipair)
 583         mtoo = modetoo_renamexf(ipair)
 584
 585         nspec = 0
 586         do 1490 iqfrm = -1, nspec_amode(mfrm)
 587             iqtoo = iqfrm
 588             if (iqfrm .eq. -1) then
 589                 lsfrma = numptr_amode(mfrm)
 590                 lstooa = numptr_amode(mtoo)
 591                 lsfrmc = numptrcw_amode(mfrm)
 592                 lstooc = numptrcw_amode(mtoo)
 593             else if (iqfrm .eq. 0) then
 594 !   bypass transfer of aerosol water due to renaming
 595                 goto 1490
 596 !               lsfrma = lwaterptr_amode(mfrm)
 597 !               lsfrmc = 0
 598 !               lstooa = lwaterptr_amode(mtoo)
 599 !               lstooc = 0
 600             else
 601                 lsfrma = lmassptr_amode(iqfrm,mfrm)
 602                 lsfrmc = lmassptrcw_amode(iqfrm,mfrm)
 603                 lstooa = 0
 604                 lstooc = 0
 605             end if
 606
 607             if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then
 608                 write(lunout,9100) mfrm, iqfrm, lsfrma
 609                 call endrun( 'modal_aero_rename_init error' )
 610             end if
 611             if (iqfrm .le. 0) goto 1430
 612
 613             if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then
 614                 write(lunout,9102) mfrm, iqfrm, lsfrmc
 615                 call endrun( 'modal_aero_rename_init error' )
 616             end if
 617
 618 ! find "too" species having same lspectype_amode as the "frm" species
 619 ! several species in a mode may have the same lspectype_amode, so also
 620 !    use the ordering as a criterion (e.g., 1st <--> 1st, 2nd <--> 2nd)
 621             iqfrm_aa = 1
 622             iqtoo_aa = 1
 623             if (iqfrm .gt. nspec_amode(mfrm)) then
 624                 iqfrm_aa = nspec_amode(mfrm) + 1
 625                 iqtoo_aa = nspec_amode(mtoo) + 1
 626             end if
 627             nsamefrm = 0
 628             do iq = iqfrm_aa, iqfrm
 629                 if ( lspectype_amode(iq   ,mfrm) .eq.   &
 630                      lspectype_amode(iqfrm,mfrm) ) then
 631                     nsamefrm = nsamefrm + 1
 632                 end if
 633             end do
 634             nsametoo = 0
 635             do iqtoo = iqtoo_aa, nspec_amode(mtoo)
 636                 if ( lspectype_amode(iqtoo,mtoo) .eq.   &
 637                      lspectype_amode(iqfrm,mfrm) ) then
 638                     nsametoo = nsametoo + 1
 639                     if (nsametoo .eq. nsamefrm) then
 640                         lstooc = lmassptrcw_amode(iqtoo,mtoo)
 641                         lstooa = lmassptr_amode(iqtoo,mtoo)
 642                         goto 1430
 643                     end if
 644                 end if
 645             end do
 646
 647 1430        nspec = nspec + 1
 648             if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0
 649             if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0
 650             if (lstooa .eq. 0) then
 651                 write(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa
 652                 call endrun( 'modal_aero_rename_init error' )
 653             end if
 654             if ((lstooc .eq. 0) .and. (iqfrm .ne. 0)) then
 655                 write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc
 656                 call endrun( 'modal_aero_rename_init error' )
 657             end if
 658             lspecfrma_renamexf(nspec,ipair) = lsfrma
 659             lspectooa_renamexf(nspec,ipair) = lstooa
 660             lspecfrmc_renamexf(nspec,ipair) = lsfrmc
 661             lspectooc_renamexf(nspec,ipair) = lstooc
 662 1490    continue
 663
 664         nspecfrm_renamexf(ipair) = nspec
 665 1900    continue
 666
 667 9100    format( / '*** subr. modal_aero_rename_init' /   &
 668         'lspecfrma out of range' /   &
 669         'modefrm, ispecfrm, lspecfrma =', 3i6 / )
 670 9102    format( / '*** subr. modal_aero_rename_init' /   &
 671         'lspecfrmc out of range' /   &
 672         'modefrm, ispecfrm, lspecfrmc =', 3i6 / )
 673 9104    format( / '*** subr. modal_aero_rename_init' /   &
 674         'lspectooa out of range' /   &
 675         'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / )
 676 9106    format( / '*** subr. modal_aero_rename_init' /   &
 677         'lspectooc out of range' /   &
 678         'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / )
 679
 680 !
 681 !   output results
 682 !
 683         if ( masterproc ) then
 684
 685         write(lunout,9310)
 686
 687         do 2900 ipair = 1, npair_renamexf
 688         mfrm = modefrm_renamexf(ipair)
 689         mtoo = modetoo_renamexf(ipair)
 690         write(lunout,9320) ipair, mfrm, mtoo
 691
 692         do iq = 1, nspecfrm_renamexf(ipair)
 693             lsfrma = lspecfrma_renamexf(iq,ipair)
 694             lstooa = lspectooa_renamexf(iq,ipair)
 695             lsfrmc = lspecfrmc_renamexf(iq,ipair)
 696             lstooc = lspectooc_renamexf(iq,ipair)
 697             if (lstooa .gt. 0) then
 698                 write(lunout,9330) lsfrma, cnst_name(lsfrma),   &
 699                                    lstooa, cnst_name(lstooa)
 700             else
 701                 write(lunout,9340) lsfrma, cnst_name(lsfrma)
 702             end if
 703             if (lstooc .gt. 0) then
 704                 write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc),   &
 705                                    lstooc, cnst_name_cw(lstooc)
 706             else if (lsfrmc .gt. 0) then
 707                 write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc)
 708             else
 709                 write(lunout,9350)
 710             end if
 711         end do
 712
 713 2900    continue
 714         write(lunout,*)
 715
 716         end if ! ( masterproc )
 717
 718 9310    format( / 'subr. modal_aero_rename_init' )
 719 9320    format( 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3 )
 720 9330    format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a )
 721 9340    format( 5x, 'spec', i3, '=', a, ' ---> LOSS' )
 722 9350    format( 5x, 'no corresponding activated species' )
 723
 724         return
 725         end subroutine modal_aero_rename_init
 726
 727 !----------------------------------------------------------------------
 728
 729    end module modal_aero_rename