chem/module_mosaic_movesect.F

   1 !**********************************************************************************
   2 ! This computer software was prepared by Battelle Memorial Institute, hereinafter
   3 ! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of
   4 ! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY,
   5 ! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
   6 !
   7 ! MOSAIC module: see module_mosaic_driver.F for references and terms of use
   8 !**********************************************************************************
   9         module module_mosaic_movesect
  10
  11
  12         use module_data_mosaic_asect
  13         use module_data_mosaic_other
  14         use module_peg_util
  15
  16
  17 !
  18 !   if apply_n1_inflow = 1, then subr move_sections_apply_n1_inflow
  19 !       applies an ad_hoc correction to bin 1 to account for growth of
  20 !       smaller particles (which are not simulated when aernucnew_onoff=0)
  21 !       growing into bin 1
  22 !   if apply_n1_inflow = other, this correction is not applied
  23 !
  24         integer, parameter :: apply_n1_inflow = 0
  25
  26         contains
  27
  28
  29
  30 !-----------------------------------------------------------------------
  31 !
  32 !   zz08movesect.f - created 24-nov-01 from scm movebin code
  33 !   04-dec-01 rce - added code to treat bins that had state="no_aerosol"
  34 !   10-dec-01 rce - diagnostic writes to fort.96 deleted
  35 !   08-aug-02 rce - this is latest version from freshair scaqs-aerosol code
  36 !   03-aug-02 rce - bypass this routine when msectional=701
  37 !       output nnewsave values to lunout when msectional=702
  38 !   29-aug-03 rce - use nspec_amode_nontracer in first "do ll" loop
  39 !   12-nov-03 rce - two approaches now available
  40 !       jacobson moving-center (old)        - when msectional=10
  41 !       tzivion mass-number advection (new) - when msectional=20
  42 !   28-jan-04 rce - eliminated the move_sections_old code
  43 !       (no reason to keep it)
  44 !
  45 ! rce 2004-dec-03 - many changes associated with the new aerosol "pointer"
  46 !     variables in module_data_mosaic_asect
  47 ! rce 2005-feb-17 - fixes involving drydens_pre/aftgrow, drymass_...,
  48 !       & mw_aer.  All are dimensioned (isize,itype) but were being used
  49 !       as (itype).  In old compiler, this was OK, and treated as (itype,1).
  50 !       In new compiler, this caused an error.
  51 !       Also, in subr test_move_sections, set iphase based on iflag.
  52 !-----------------------------------------------------------------------
  53
  54
  55 !-----------------------------------------------------------------------
  56         subroutine move_sections( iflag, iclm, jclm, k, m)
  57 !
  58 !   routine transfers aerosol number and mass between sections
  59 !       to account for continuous aerosol growth
  60 !   this routine is called after the gas condensation module (MOSAIC) or
  61 !       aqueous chemistry module has increased the mass within sections
  62 !
  63 !   moving-center algorithm or mass-number advection algorithm is used,
  64 !   depending on value of mod(msectional,100)
  65 !       section mean diameter is given by
  66 !           vtot = ntot * (pi/6) * (dmean**3)
  67 !       where vtot and ntot are total dry-volume and number for the section
  68 !       if dmean is outside the section boundaries (dlo_sect & dhi_sect), then
  69 !           all the mass and number in the section are transfered to the
  70 !           section with dlo_sect(nnew) < dmean < dhi_sect(nnew)
  71 !
  72 !   mass mixing ratios (mole/mole-air or g/mole-air) are in
  73 !       rsub(massptr_aer(ll,n,itype,iphase),k,m)
  74 !   number mixing ratios (particles/mole-air) are in
  75 !       rsub(numptr_aer(n,itype,iphase),k,m)
  76 !   these values are over-written with new values
  77 !   the following are also updated:
  78 !       adrydens_sub(n,itype,k,m), admeandry_sub(n,itype,k,m),
  79 !       awetdens_sub(n,itype,k,m), admeanwet_sub(n,itype,k,m)
  80 !
  81 !   particle sizes are in cm
  82 !
  83 !   input parameters
  84 !       iflag = 1 - do transfer after trace-gas condensation/evaporation
  85 !             = 2 - do transfer after aqueous chemistry
  86 !             = -1/-2 - do some "first entry" tasks for the iflag=+1/+2 cases
  87 !       iclm, jclm, k = current i,j,k indices
  88 !       m = current subarea index
  89 !       drymass_pregrow(n,itype) = dry-mass (g/mole-air) for section n
  90 !                       before the growth
  91 !       drymass_aftgrow(n,itype) = dry-mass (g/mole-air) for section n
  92 !                       after the growth but before inter-section transfer
  93 !       drydens_pregrow(n,itype) = dry-density (g/cm3) for section n
  94 !                       before the growth
  95 !       drydens_aftgrow(n,itype) = dry-density (g/cm3) for section n
  96 !                       after the growth but before inter-section transfer
  97 !       (drymass_pregrow and drydens_pregrow are not used by the moving-center
  98 !       algorithm, but would be needed for other sectional algorithms)
  99 !
 100 !   this routine is the top level module for the post-october-2003 code
 101 !       and will do either moving-center or mass-number advection
 102 !
 103         implicit none
 104
 105 !       include 'v33com'
 106 !       include 'v33com2'
 107 !       include 'v33com3'
 108 !       include 'v33com9a'
 109 !       include 'v33com9b'
 110
 111 !   subr arguments
 112         integer iflag, iclm, jclm, k, m
 113
 114 !   local variables
 115         integer idiag_movesect, iphase, itype,   &
 116           l, ll, llhysw, llwater, lnew, lold, l3,   &
 117           method_movesect, n, nnew, nold
 118         integer nnewsave(2,maxd_asize)
 119
 120         real densdefault, densh2o, smallmassaa, smallmassbb
 121         real delta_water_conform1, delta_numb_conform1
 122
 123         real drydenspp(maxd_asize), drydensxx0(maxd_asize),   &
 124              drydensxx(maxd_asize), drydensyy(maxd_asize)
 125         real drymasspp(maxd_asize), drymassxx0(maxd_asize),   &
 126              drymassxx(maxd_asize), drymassyy(maxd_asize)
 127         real dryvolxx(maxd_asize), dryvolyy(maxd_asize)
 128         real rmassxx(maxd_acomp+2,maxd_asize),   &
 129              rmassyy(maxd_acomp+2,maxd_asize)
 130         real rnumbpp(maxd_asize), rnumbxx0(maxd_asize),   &
 131              rnumbxx(maxd_asize), rnumbyy(maxd_asize)
 132         real specdensxx(maxd_acomp), specmwxx(maxd_acomp)
 133         real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize)
 134         real wetvolxx(maxd_asize), wetvolyy(maxd_asize)
 135         real wetmassxx(maxd_asize), wetmassyy(maxd_asize)
 136
 137         character*160 msg
 138
 139
 140 !
 141 !   check for valid inputs
 142 !
 143         if (msectional .le. 0) return
 144         if (ntype_aer .le. 0) return
 145         if (nphase_aer .le. 0) return
 146
 147
 148 !
 149 !   run diagnostic tests
 150 !   (these will only be run for certain values of idiag_movesect
 151 !   rce 2004-nov-29 - to avoid recursion, test_move_sections
 152 !       is now called from mosaic_driver
 153 !
 154 !       call test_move_sections( iflag, iclm, jclm, k, m )
 155
 156
 157 !   get "method_movesect" from digits 1-2 of msectional (treat 1-9 as 10)
 158         method_movesect = mod( msectional, 100 )
 159         if (method_movesect .le. 10) method_movesect = 10
 160
 161 !   get "idiag_movesect"  from digits 3-4 of msectional
 162         idiag_movesect  = mod( msectional, 10000 )/100
 163
 164         if      ((method_movesect .eq. 10) .or.   &
 165                  (method_movesect .eq. 11) .or.   &
 166                  (method_movesect .eq. 20) .or.   &
 167                  (method_movesect .eq. 21) .or.   &
 168                  (method_movesect .eq. 30) .or.   &
 169                  (method_movesect .eq. 31)) then
 170             continue
 171         else if ((method_movesect .eq. 19) .or.   &
 172                  (method_movesect .eq. 29) .or.   &
 173                  (method_movesect .eq. 39)) then
 174             return
 175         else
 176             msg = '*** subr move_sections error - ' //   &
 177                 'illegal value for msectional'
 178             call peg_error_fatal( lunerr, msg )
 179         end if
 180
 181         if (iabs(iflag) .eq. 1) then
 182             iphase = ai_phase
 183         else if (iabs(iflag) .eq. 2) then
 184             iphase = cw_phase
 185             if (nphase_aer .lt. 2) then
 186                 msg = '*** subr move_sections error - ' //   &
 187                     'iflag=2 (after aqueous chemistry) but nphase_aer < 2'
 188                 call peg_error_fatal( lunerr, msg )
 189             else if (cw_phase .ne. 2) then
 190                 msg = '*** subr move_sections error - ' //   &
 191                     'iflag=2 (after aqueous chemistry) but cw_phase .ne. 2'
 192                 call peg_error_fatal( lunerr, msg )
 193             end if
 194         else
 195             msg = '*** subr move_sections error - ' //   &
 196                 'iabs(iflag) must be 1 or 2'
 197             call peg_error_fatal( lunerr, msg )
 198         end if
 199
 200
 201 !   when iflag=-1/-2, call move_sections_checkptrs then return
 202 !       if ((ncorecnt .le. 0) .and. (k .le. 1)) then
 203         if (iflag .le. 0) then
 204             write(msg,9040) 'method', method_movesect
 205             call peg_message( lunout, msg )
 206             write(msg,9040) 'idiag ', idiag_movesect
 207             call peg_message( lunout, msg )
 208             call move_sections_checkptrs( iflag, iclm, jclm, k, m )
 209             return
 210         end if
 211 9040    format( '*** subr move_sections - ', a, ' =', i6 )
 212
 213 !   diagnostics
 214         if (idiag_movesect .eq. 70) then
 215             msg = ' '
 216             call peg_message( lunout, msg )
 217             write(msg,9060) iclm, jclm, k, m, msectional
 218             call peg_message( lunout, msg )
 219         end if
 220 9060    format( '*** subr move_sections diagnostics i,j,k,m,msect =', 4i4, i6 )
 221
 222
 223         densdefault = 2.0
 224         densh2o = 1.0
 225
 226 !   if bin mass mixrat < smallmassaa (1.e-20 g/mol), then assume no growth
 227 !   AND no water AND conform number so that size is within bin limits
 228         smallmassaa = 1.0e-20
 229 !   if bin mass OR volume mixrat < smallmassbb (1.e-30 g/mol), then
 230 !   assume default density to avoid divide by zero
 231         smallmassbb = 1.0e-30
 232
 233
 234 !   process each type, one at a time
 235         do 1900 itype = 1, ntype_aer
 236
 237         if (nsize_aer(itype) .le. 0) goto 1900
 238
 239         call move_sections_initial_conform(   &
 240           iflag, iclm, jclm, k, m, iphase, itype,   &
 241           method_movesect, idiag_movesect, llhysw, llwater,   &
 242           densdefault, densh2o, smallmassaa, smallmassbb,   &
 243           delta_water_conform1, delta_numb_conform1,   &
 244           drydenspp, drymasspp, rnumbpp,   &
 245           drydensxx0, drymassxx0, rnumbxx0,   &
 246           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 247           wetmassxx, wetvolxx,   &
 248           specmwxx, specdensxx )
 249
 250         if (method_movesect .le. 19) then
 251         call move_sections_calc_movingcenter(   &
 252           iflag, iclm, jclm, k, m, iphase, itype,   &
 253           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 254           densdefault, densh2o, smallmassaa, smallmassbb,   &
 255           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 256           wetmassxx, wetvolxx,   &
 257           xferfracvol, xferfracnum )
 258         else
 259         call move_sections_calc_masnumadvect(   &
 260           iflag, iclm, jclm, k, m, iphase, itype,   &
 261           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 262           densdefault, densh2o, smallmassaa, smallmassbb,   &
 263           drydenspp, drymasspp, rnumbpp,   &
 264           drydensxx0, drymassxx0, rnumbxx0,   &
 265           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 266           wetmassxx, wetvolxx,   &
 267           xferfracvol, xferfracnum )
 268         end if
 269
 270         call move_sections_apply_moves(   &
 271           iflag, iclm, jclm, k, m, iphase, itype,   &
 272           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 273           densdefault, densh2o, smallmassaa, smallmassbb,   &
 274           delta_water_conform1, delta_numb_conform1,   &
 275           drydenspp, drymasspp, rnumbpp,   &
 276           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
 277           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy,   &
 278           xferfracvol, xferfracnum )
 279
 280 ! rce 08-nov-2004 - this call is new (and perhaps temporary)
 281 ! rce 05-jul-2005 - do n1_inflow for aerchem growth but not for cldchem
 282         if ((apply_n1_inflow .eq. 1) .and.   &
 283             (iphase .eq. ai_phase)) then
 284         call move_sections_apply_n1_inflow(   &
 285           iflag, iclm, jclm, k, m, iphase, itype,   &
 286           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 287           densdefault, densh2o, smallmassaa, smallmassbb,   &
 288           delta_water_conform1, delta_numb_conform1,   &
 289           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
 290           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy,   &
 291           xferfracvol, xferfracnum,   &
 292           specmwxx, specdensxx )
 293         end if
 294
 295 !       call move_sections_final_conform(   &
 296 !         iflag, iclm, jclm, k, m, iphase, itype )
 297
 298 1900    continue
 299
 300         return
 301         end subroutine move_sections
 302
 303
 304 !-----------------------------------------------------------------------
 305         subroutine move_sections_initial_conform(   &
 306           iflag, iclm, jclm, k, m, iphase, itype,   &
 307           method_movesect, idiag_movesect, llhysw, llwater,   &
 308           densdefault, densh2o, smallmassaa, smallmassbb,   &
 309           delta_water_conform1, delta_numb_conform1,   &
 310           drydenspp, drymasspp, rnumbpp,   &
 311           drydensxx0, drymassxx0, rnumbxx0,   &
 312           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 313           wetmassxx, wetvolxx,   &
 314           specmwxx, specdensxx )
 315
 316 !
 317 !   routine does some initial tasks for the section movement
 318 !       load rmassxx & rnumbxx from rsub
 319 !       load specmwxx & specdensxx
 320 !       set drymassxx & dryvolxx from drymass_aftgrow & drydens_aftgrow,
 321 !           OR compute them from rmassxx, specmwxx, specdensxx if need be
 322 !       set wetmassxx & wetvolxx from dry values & water mass
 323 !       conform rnumbxx so that the mean particle size of each section
 324 !           (= dryvolxx/rnumbxx) is within the section limits
 325 !
 326         implicit none
 327
 328 !       include 'v33com'
 329 !       include 'v33com2'
 330 !       include 'v33com3'
 331 !       include 'v33com9a'
 332 !       include 'v33com9b'
 333
 334 !   subr arguments
 335         integer iflag, iclm, jclm, iphase, itype, k,   &
 336           m, method_movesect, idiag_movesect, llhysw, llwater
 337         real densdefault, densh2o, smallmassaa, smallmassbb
 338         real delta_water_conform1, delta_numb_conform1
 339         real drydenspp(maxd_asize), drydensxx0(maxd_asize),   &
 340              drydensxx(maxd_asize)
 341         real drymasspp(maxd_asize), drymassxx0(maxd_asize),   &
 342              drymassxx(maxd_asize)
 343         real dryvolxx(maxd_asize)
 344         real rmassxx(maxd_acomp+2,maxd_asize)
 345         real rnumbpp(maxd_asize), rnumbxx0(maxd_asize),   &
 346              rnumbxx(maxd_asize)
 347         real specdensxx(maxd_acomp), specmwxx(maxd_acomp)
 348         real wetvolxx(maxd_asize)
 349         real wetmassxx(maxd_asize)
 350
 351
 352 !   local variables
 353         integer l, ll, lnew, lold, l3, n, nnew, nold
 354
 355         real dummass, dumnum, dumnum_at_dhi, dumnum_at_dlo, dumr,   &
 356           dumvol, dumvol1p, dumwatrmass
 357
 358
 359 !   assure positive definite
 360         do l = 1, ltot2
 361             rsub(l,k,m) = max( 0., rsub(l,k,m) )
 362         end do
 363
 364 !   load mixrats into working arrays and assure positive definite
 365         llhysw = ncomp_plustracer_aer(itype) + 1
 366         llwater = ncomp_plustracer_aer(itype) + 2
 367         do n = 1, nsize_aer(itype)
 368             do ll = 1, ncomp_plustracer_aer(itype)
 369                 l = massptr_aer(ll,n,itype,iphase)
 370                 rmassxx(ll,n) = rsub(l,k,m)
 371             end do
 372             rmassxx(llhysw,n) = 0.
 373             l = 0
 374             if (iphase .eq. ai_phase) l = hyswptr_aer(n,itype)
 375             if (l .gt. 0) rmassxx(llhysw,n) = rsub(l,k,m)
 376             rmassxx(llwater,n) = 0.
 377             l = 0
 378             if (iphase .eq. ai_phase) l = waterptr_aer(n,itype)
 379             if (l .gt. 0) rmassxx(llwater,n) = rsub(l,k,m)
 380
 381             rnumbxx(n)  = rsub(numptr_aer(n,itype,iphase),k,m)
 382             rnumbxx0(n) = rnumbxx(n)
 383             rnumbpp(n)  = rnumbxx(n)
 384
 385             drydenspp(n) = drydens_pregrow(n,itype)
 386             drymasspp(n) = drymass_pregrow(n,itype)
 387
 388             drydensxx(n) = drydens_aftgrow(n,itype)
 389             drymassxx(n) = drymass_aftgrow(n,itype)
 390             drydensxx0(n) = drydensxx(n)
 391             drymassxx0(n) = drymassxx(n)
 392         end do
 393
 394 !   load specmw and specdens also
 395         do ll = 1, ncomp_plustracer_aer(itype)
 396             specmwxx(ll) = mw_aer(ll,itype)
 397             specdensxx(ll) = dens_aer(ll,itype)
 398         end do
 399
 400         delta_water_conform1 = 0.0
 401         delta_numb_conform1 = 0.0
 402
 403
 404         do 1390 n = 1, nsize_aer(itype)
 405
 406 !
 407 !   if drydens_aftgrow < 0.1, then bin had state="no_aerosol"
 408 !   compute volume using default dry-densities, set water=0,
 409 !       and conform the number
 410 !   also do this if mass is extremely small (below smallmassaa)
 411 !       OR if drydens_aftgrow > 20 (which is unrealistic)
 412 !
 413         if ( (drydensxx(n) .lt.  0.1) .or.   &
 414              (drydensxx(n) .gt. 20.0) .or.   &
 415              (drymassxx(n) .le. smallmassaa) ) then
 416             dummass = 0.
 417             dumvol = 0.
 418             do ll = 1, ncomp_aer(itype)
 419                 dumr = rmassxx(ll,n)*specmwxx(ll)
 420                 dummass = dummass + dumr
 421                 dumvol  = dumvol  + dumr/specdensxx(ll)
 422             end do
 423             drymassxx(n) = dummass
 424             if (min(dummass,dumvol) .le. smallmassbb) then
 425                 drydensxx(n) = densdefault
 426                 dumvol = dummass/densdefault
 427                 dumnum = dummass/(volumcen_sect(n,itype)*densdefault)
 428             else
 429                 drydensxx(n) = dummass/dumvol
 430                 dumnum = rnumbxx(n)
 431                 dumnum_at_dhi = dumvol/volumhi_sect(n,itype)
 432                 dumnum_at_dlo = dumvol/volumlo_sect(n,itype)
 433                 dumnum = max( dumnum_at_dhi, min( dumnum_at_dlo, dumnum ) )
 434             end if
 435             delta_numb_conform1 = delta_numb_conform1 + dumnum - rnumbxx(n)
 436             rnumbxx(n) = dumnum
 437             rnumbpp(n) = rnumbxx(n)
 438             delta_water_conform1 = delta_water_conform1 - rmassxx(llwater,n)
 439             rmassxx(llwater,n) = 0.
 440         end if
 441
 442 !   load dry/wet mass and volume into "xx" arrays
 443 !   which hold values before inter-mode transferring
 444         dryvolxx(n) = drymassxx(n)/drydensxx(n)
 445         dumwatrmass = rmassxx(llwater,n)*mw_water_aer
 446         wetmassxx(n) = drymassxx(n) + dumwatrmass
 447         wetvolxx(n) = dryvolxx(n) + dumwatrmass/densh2o
 448
 449 1390    continue
 450
 451         return
 452         end subroutine move_sections_initial_conform
 453
 454
 455 !-----------------------------------------------------------------------
 456         subroutine move_sections_calc_movingcenter(   &
 457           iflag, iclm, jclm, k, m, iphase, itype,   &
 458           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 459           densdefault, densh2o, smallmassaa, smallmassbb,   &
 460           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 461           wetmassxx, wetvolxx,   &
 462           xferfracvol, xferfracnum )
 463 !
 464 !   routine calculates section movements for the moving-center approach
 465 !
 466 !   material in section n will be transfered to section nnewsave(1,n)
 467 !
 468 !   the nnewsave are calculated here
 469 !   the actual transfer is done in another routine
 470 !
 471         implicit none
 472
 473 !       include 'v33com'
 474 !       include 'v33com2'
 475 !       include 'v33com3'
 476 !       include 'v33com9a'
 477 !       include 'v33com9b'
 478
 479 !   subr arguments
 480         integer iflag, iclm, jclm, iphase, itype, k,   &
 481           m, method_movesect, idiag_movesect, llhysw, llwater
 482         integer nnewsave(2,maxd_asize)
 483         real densdefault, densh2o, smallmassaa, smallmassbb
 484         real drydensxx(maxd_asize)
 485         real drymassxx(maxd_asize)
 486         real dryvolxx(maxd_asize)
 487         real rmassxx(maxd_acomp+2,maxd_asize)
 488         real rnumbxx(maxd_asize)
 489         real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize)
 490         real wetmassxx(maxd_asize)
 491         real wetvolxx(maxd_asize)
 492
 493 !   local variables
 494         integer ll, n, ndum, nnew, nold
 495         real dumnum, dumvol, dumvol1p, sixoverpi, third
 496         character*160 msg
 497
 498
 499         sixoverpi = 6.0/pi
 500         third = 1.0/3.0
 501
 502 !
 503 !   compute mean size after growth (and corresponding section)
 504 !   particles in section n will be transferred to section nnewsave(1,n)
 505 !
 506         do 1390 n = 1, nsize_aer(itype)
 507
 508         nnew = n
 509
 510 !   don't bother to transfer bins whose mass is extremely small
 511         if (drymassxx(n) .le. smallmassaa) goto 1290
 512
 513         dumvol = dryvolxx(n)
 514         dumnum = rnumbxx(n)
 515
 516 !   check for number so small that particle volume is
 517 !   above that of largest section
 518         if (dumnum .le. dumvol/volumhi_sect(nsize_aer(itype),itype)) then
 519             nnew = nsize_aer(itype)
 520             goto 1290
 521 !   or below that of smallest section
 522         else if (dumnum .ge. dumvol/volumlo_sect(1,itype)) then
 523             nnew = 1
 524             goto 1290
 525         end if
 526
 527 !   dumvol1p is mean particle volume (cm3) for the section
 528         dumvol1p = dumvol/dumnum
 529         if (dumvol1p .gt. volumhi_sect(n,itype)) then
 530             do while ( (nnew .lt. nsize_aer(itype)) .and.   &
 531                        (dumvol1p .gt. volumhi_sect(nnew,itype)) )
 532                 nnew = nnew + 1
 533             end do
 534
 535         else if (dumvol1p .lt. volumlo_sect(n,itype)) then
 536             do while ( (nnew .gt. 1) .and.   &
 537                        (dumvol1p .lt. volumlo_sect(nnew,itype)) )
 538                 nnew = nnew - 1
 539             end do
 540
 541         end if
 542
 543 1290    nnewsave(1,n) = nnew
 544         nnewsave(2,n) = 0
 545
 546         xferfracvol(1,n) = 1.0
 547         xferfracvol(2,n) = 0.0
 548         xferfracnum(1,n) = 1.0
 549         xferfracnum(2,n) = 0.0
 550
 551 1390    continue
 552
 553
 554 !   diagnostic output
 555 !   output nnewsave values when msectional=7xxx
 556         if (idiag_movesect .eq. 70) then
 557             ndum = 0
 558             do n = 1, nsize_aer(itype)
 559                 if (nnewsave(1,n) .ne. n) ndum = ndum + 1
 560             end do
 561             if (ndum .gt. 0) then
 562                 write(msg,97751) 'YES', iclm, jclm, k, m,   &
 563                 ndum, (nnewsave(1,n), n=1,nsize_aer(itype))
 564                 call peg_message( lunout, msg )
 565             else
 566                 write(msg,97751) 'NO ', iclm, jclm, k, m,   &
 567                 ndum, (nnewsave(1,n), n=1,nsize_aer(itype))
 568                 call peg_message( lunout, msg )
 569             end if
 570         end if
 571 97751   format( 'movesect', a, 4i3, 3x, i3, 3x, 14i3 )
 572
 573         return
 574         end subroutine move_sections_calc_movingcenter
 575
 576
 577 !-----------------------------------------------------------------------
 578         subroutine move_sections_calc_masnumadvect(   &
 579           iflag, iclm, jclm, k, m, iphase, itype,   &
 580           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 581           densdefault, densh2o, smallmassaa, smallmassbb,   &
 582           drydenspp, drymasspp, rnumbpp,   &
 583           drydensxx0, drymassxx0, rnumbxx0,   &
 584           drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx,   &
 585           wetmassxx, wetvolxx,   &
 586           xferfracvol, xferfracnum )
 587 !
 588 !   routine calculates section movements for the mass-number-advection approach
 589 !
 590 !   material in section n will be transfered to sections
 591 !       nnewsave(1,n) and nnewsave(2,n)
 592 !   the fractions of mass/volume transfered to each are
 593 !       xferfracvol(1,n) and xferfracvol(2,n)
 594 !   the fractions of number transfered to each are
 595 !       xferfracnum(1,n) and xferfracnum(2,n)
 596 !
 597 !   the nnewsave, xferfracvol, and xferfracnum are calculated here
 598 !   the actual transfer is done in another routine
 599 !
 600         implicit none
 601
 602 !       include 'v33com'
 603 !       include 'v33com2'
 604 !       include 'v33com3'
 605 !       include 'v33com9a'
 606 !       include 'v33com9b'
 607
 608 !   subr arguments
 609         integer iflag, iclm, jclm, iphase, itype, k,   &
 610           m, method_movesect, idiag_movesect, llhysw, llwater
 611         integer nnewsave(2,maxd_asize)
 612
 613         real densdefault, densh2o, smallmassaa, smallmassbb
 614         real drydenspp(maxd_asize), drydensxx0(maxd_asize),   &
 615              drydensxx(maxd_asize)
 616         real drymasspp(maxd_asize), drymassxx0(maxd_asize),   &
 617              drymassxx(maxd_asize)
 618         real dryvolxx(maxd_asize)
 619         real rmassxx(maxd_acomp+2,maxd_asize)
 620         real rnumbpp(maxd_asize), rnumbxx0(maxd_asize),   &
 621              rnumbxx(maxd_asize)
 622         real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize)
 623         real wetvolxx(maxd_asize)
 624         real wetmassxx(maxd_asize)
 625
 626 !   local variables
 627         integer ierr, n, nnew, nnew2
 628         integer iforce_movecenter(maxd_asize)
 629
 630         real dum1, dum2, dum3
 631         real dumaa, dumbb, dumgamma, dumratio
 632         real dumfracnum, dumfracvol
 633         real dumntot
 634         real dumv
 635         real dumvbar_aft, dumvbar_pre
 636         real dumvcutlo_nnew_pre, dumvcuthi_nnew_pre
 637         real dumvlo_pre, dumvhi_pre, dumvdel_pre
 638         real dumvtot_aft, dumvtot_pre
 639         real dumzlo, dumzhi
 640         real sixoverpi, third
 641
 642         character*4 dumch4
 643         character*1 dumch1
 644         character*160 msg
 645
 646
 647         sixoverpi = 6.0/pi
 648         third = 1.0/3.0
 649
 650 !
 651 !   compute mean size after growth (and corresponding section)
 652 !   some of the particles in section n will be transferred to section nnewsave(1,n)
 653 !
 654 !   if the aftgrow mass is extremely small,
 655 !   OR if the aftgrow mean size is outside of
 656 !       [dlo_sect(1,itype), dhi_sect(nsize_aer(itype),itype)]
 657 !   then use the moving-center method_movesect for this bin
 658 !   (don't try to compute the pregrow within-bin distribution)
 659 !
 660         do 3900 n = 1, nsize_aer(itype)
 661
 662         nnew = n
 663         iforce_movecenter(n) = 0
 664
 665         xferfracvol(1,n) = 1.0
 666         xferfracvol(2,n) = 0.0
 667         xferfracnum(1,n) = 1.0
 668         xferfracnum(2,n) = 0.0
 669
 670         dumvtot_aft = -1.0
 671         dumvtot_pre = -1.0
 672         dumvbar_aft = -1.0
 673         dumvbar_pre = -1.0
 674         dumvlo_pre = -1.0
 675         dumvhi_pre = -1.0
 676         dumgamma = -1.0
 677         dumratio = -1.0
 678         dumvcutlo_nnew_pre = volumlo_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft)
 679         dumvcuthi_nnew_pre = volumhi_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft)
 680         dumfracvol = -1.0
 681         dumfracnum = -1.0
 682
 683 !   don't bother to transfer bins whose mass is extremely small
 684         if (drymassxx(n) .le. smallmassaa) then
 685             iforce_movecenter(n) = 1
 686             goto 1290
 687         end if
 688
 689         dumvtot_aft = dryvolxx(n)
 690         dumntot = rnumbxx(n)
 691
 692 !   check for particle volume above that of largest section
 693 !   or below that of smallest section
 694         if (dumntot .le. dumvtot_aft/volumhi_sect(nsize_aer(itype),itype)) then
 695             nnew = nsize_aer(itype)
 696             iforce_movecenter(n) = 2
 697             goto 1290
 698         else if (dumntot .ge. dumvtot_aft/volumlo_sect(1,itype)) then
 699             nnew = 1
 700             iforce_movecenter(n) = 3
 701             goto 1290
 702         end if
 703
 704 !   dumvbar_aft is mean particle volume (cm3) for the section
 705 !   find the section that encloses this volume
 706         dumvbar_aft = dumvtot_aft/dumntot
 707         if (dumvbar_aft .gt. volumhi_sect(n,itype)) then
 708             do while ( (nnew .lt. nsize_aer(itype)) .and.   &
 709                        (dumvbar_aft .gt. volumhi_sect(nnew,itype)) )
 710                 nnew = nnew + 1
 711             end do
 712
 713         else if (dumvbar_aft .lt. volumlo_sect(n,itype)) then
 714             do while ( (nnew .gt. 1) .and.   &
 715                        (dumvbar_aft .lt. volumlo_sect(nnew,itype)) )
 716                 nnew = nnew - 1
 717             end do
 718
 719         end if
 720
 721 1290    nnewsave(1,n) = nnew
 722         nnewsave(2,n) = 0
 723
 724         if (iforce_movecenter(n) .gt. 0) goto 3700
 725
 726
 727 !   if drydenspp (pregrow) < 0.1 (because bin had state="no_aerosol" before
 728 !       growth was computed, so its initial mass was very small)
 729 !   then use the moving-center method_movesect for this bin
 730 !   (don't try to compute the pregrow within-bin distribution)
 731 !   also do this if pregrow mass is extremely small (below smallmassaa)
 732 !       OR if drydenspp > 20 (unphysical)
 733         if ( (drydenspp(n) .lt.  0.1) .or.   &
 734              (drydenspp(n) .gt. 20.0) .or.   &
 735              (drymasspp(n) .le. smallmassaa) ) then
 736             iforce_movecenter(n) = 11
 737             goto 3700
 738         end if
 739
 740         dumvtot_pre = drymasspp(n)/drydenspp(n)
 741
 742         dumvlo_pre = volumlo_sect(n,itype)
 743         dumvhi_pre = volumhi_sect(n,itype)
 744         dumvdel_pre = dumvhi_pre - dumvlo_pre
 745
 746 !   if the pregrow mean size is outside of OR very close to the bin limits,
 747 !   then use moving-center approach for this bin
 748         dumv = dumvhi_pre - 0.01*dumvdel_pre
 749         if (dumntot .le. dumvtot_pre/dumv) then
 750             iforce_movecenter(n) = 12
 751             goto 3700
 752         end if
 753         dumv = dumvlo_pre + 0.01*dumvdel_pre
 754         if (dumntot .ge. dumvtot_pre/dumv) then
 755             iforce_movecenter(n) = 13
 756             goto 3700
 757         end if
 758
 759 !   calculate the pregrow within-section size distribution
 760         dumvbar_pre = dumvtot_pre/dumntot
 761         dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0
 762         dumratio = dumvbar_pre/dumvlo_pre
 763
 764         if (dumratio .le. (1.0001 + dumgamma/3.0)) then
 765             dumv = dumvlo_pre + 3.0*(dumvbar_pre-dumvlo_pre)
 766             dumvhi_pre = min( dumvhi_pre, dumv )
 767             dumvdel_pre = dumvhi_pre - dumvlo_pre
 768             dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0
 769             dumratio = dumvbar_pre/dumvlo_pre
 770         else if (dumratio .ge. (0.9999 + dumgamma*2.0/3.0)) then
 771             dumv = dumvhi_pre + 3.0*(dumvbar_pre-dumvhi_pre)
 772             dumvlo_pre = max( dumvlo_pre, dumv )
 773             dumvdel_pre = dumvhi_pre - dumvlo_pre
 774             dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0
 775             dumratio = dumvbar_pre/dumvlo_pre
 776         end if
 777
 778         dumbb = (dumratio - 1.0 - 0.5*dumgamma)*12.0/dumgamma
 779         dumaa = 1.0 - 0.5*dumbb
 780
 781 !   calculate pregrow volumes corresponding to the nnew
 782 !   section boundaries
 783         dumvcutlo_nnew_pre = volumlo_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft)
 784         dumvcuthi_nnew_pre = volumhi_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft)
 785
 786 !   if the [dumvlo_pre, dumvhi_pre] falls completely within
 787 !   the [dumvcutlo_nnew_pre, dumvcuthi_nnew_pre] interval,
 788 !   then all mass and number go to nnew
 789         if (nnew .eq. 1) then
 790             if (dumvhi_pre .le. dumvcuthi_nnew_pre) then
 791                 iforce_movecenter(n) = 21
 792             else
 793                 nnew2 = nnew + 1
 794             end if
 795         else if (nnew .eq. nsize_aer(itype)) then
 796             if (dumvlo_pre .ge. dumvcutlo_nnew_pre) then
 797                 iforce_movecenter(n) = 22
 798             else
 799                 nnew2 = nnew - 1
 800             end if
 801         else
 802             if ((dumvlo_pre .ge. dumvcutlo_nnew_pre) .and.   &
 803                 (dumvhi_pre .le. dumvcuthi_nnew_pre)) then
 804                 iforce_movecenter(n) = 23
 805             else if (dumvlo_pre .lt. dumvcutlo_nnew_pre) then
 806                 nnew2 = nnew - 1
 807             else
 808                 nnew2 = nnew + 1
 809             end if
 810         end if
 811         if (iforce_movecenter(n) .gt. 0) goto 3700
 812
 813 !   calculate the fraction of ntot and vtot that are within
 814 !   the [dumvcutlo_nnew_pre, dumvcuthi_nnew_pre] interval
 815         dumzlo = (dumvcutlo_nnew_pre - dumvlo_pre)/dumvdel_pre
 816         dumzhi = (dumvcuthi_nnew_pre - dumvlo_pre)/dumvdel_pre
 817         dumzlo = max( dumzlo, 0.0 )
 818         dumzhi = min( dumzhi, 1.0 )
 819         dum1 =  dumzhi    - dumzlo
 820         dum2 = (dumzhi**2 - dumzlo**2)*0.5
 821         dum3 = (dumzhi**3 - dumzlo**3)/3.0
 822         dumfracnum = dumaa*dum1 + dumbb*dum2
 823         dumfracvol = (dumvlo_pre/dumvbar_pre) * (dumaa*dum1 +   &
 824                 (dumaa*dumgamma + dumbb)*dum2 + (dumbb*dumgamma)*dum3)
 825
 826         if ((dumfracnum .le. 0.0) .or. (dumfracvol .le. 0.0)) then
 827             iforce_movecenter(n) = 31
 828             nnewsave(1,n) = nnew2
 829         else if ((dumfracnum .ge. 1.0) .or. (dumfracvol .ge. 1.0)) then
 830             iforce_movecenter(n) = 32
 831         end if
 832         if (iforce_movecenter(n) .gt. 0) goto 3700
 833
 834         nnewsave(2,n) = nnew2
 835
 836         xferfracvol(1,n) = dumfracvol
 837         xferfracvol(2,n) = 1.0 - dumfracvol
 838         xferfracnum(1,n) = dumfracnum
 839         xferfracnum(2,n) = 1.0 - dumfracnum
 840
 841 3700    continue
 842
 843 !   output nnewsave values when msectional=7xxx
 844         if (idiag_movesect .ne. 70) goto 3800
 845
 846         if (nnewsave(2,n) .eq. 0) then
 847             if (nnewsave(1,n) .eq. 0) then
 848                 dumch4 = 'NO X'
 849             else if (nnewsave(1,n) .eq. n) then
 850                 dumch4 = 'NO A'
 851             else
 852                 dumch4 = 'YESA'
 853             end if
 854         else if (nnewsave(1,n) .eq. 0) then
 855             if (nnewsave(2,n) .eq. n) then
 856                 dumch4 = 'NO B'
 857             else
 858                 dumch4 = 'YESB'
 859             end if
 860         else if (nnewsave(2,n) .eq. n) then
 861             if (nnewsave(1,n) .eq. n) then
 862                 dumch4 = 'NO Y'
 863             else
 864                 dumch4 = 'YESC'
 865             end if
 866         else if (nnewsave(1,n) .eq. n) then
 867             dumch4 = 'YESD'
 868         else
 869             dumch4 = 'YESE'
 870         end if
 871
 872         dumch1 = '+'
 873         if (drymasspp(n) .gt. drymassxx(n)) dumch1 = '-'
 874
 875         msg = ' '
 876         call peg_message( lunout, msg )
 877         write(msg,97010) dumch1, dumch4, iclm, jclm, k, m,   &
 878                 n, nnewsave(1,n), nnewsave(2,n), iforce_movecenter(n)
 879         call peg_message( lunout, msg )
 880         write(msg,97020) 'pre mass, dens      ',   &
 881                 drymasspp(n), drydenspp(n)
 882         call peg_message( lunout, msg )
 883         write(msg,97020) 'aft mass, dens, numb',   &
 884                 drymassxx(n), drydensxx(n), rnumbxx(n)
 885         call peg_message( lunout, msg )
 886         if ((drydensxx(n) .ne. drydensxx0(n)) .or.   &
 887             (drymassxx(n) .ne. drymassxx0(n)) .or.   &
 888             (rnumbxx(n)   .ne. rnumbxx0(n)  )) then
 889             write(msg,97020) 'aft0 mas, dens, numb',   &
 890                 drymassxx0(n), drydensxx0(n), rnumbxx0(n)
 891             call peg_message( lunout, msg )
 892         end if
 893         write(msg,97020) 'vlop0, vbarp,  vhip0',   &
 894                 volumlo_sect(n,itype), dumvbar_pre, volumhi_sect(n,itype)
 895         call peg_message( lunout, msg )
 896         write(msg,97020) 'vlop , vbarp,  vhip ',   &
 897                 dumvlo_pre, dumvbar_pre, dumvhi_pre
 898         call peg_message( lunout, msg )
 899         write(msg,97020) 'vloax, vbarax, vhiax',   &
 900                 dumvcutlo_nnew_pre, dumvbar_pre, dumvcuthi_nnew_pre
 901         call peg_message( lunout, msg )
 902         write(msg,97020) 'vloa0, vbara,  vhia0',   &
 903                 volumlo_sect(nnew,itype), dumvbar_aft, volumhi_sect(nnew,itype)
 904         call peg_message( lunout, msg )
 905         write(msg,97020) 'dumfrvol, num, ratio',   &
 906                 dumfracvol, dumfracnum, dumratio
 907         call peg_message( lunout, msg )
 908         write(msg,97020) 'frvol,num1; vol,num2',   &
 909                 xferfracvol(1,n), xferfracnum(1,n),   &
 910                 xferfracvol(2,n), xferfracnum(2,n)
 911         call peg_message( lunout, msg )
 912
 913 97010   format( 'movesect', 2a, 7x, 4i3, 4x,   &
 914                 'n,nnews', 3i3, 4x, 'iforce', i3.2 )
 915 97020   format( a, 1p, 4e13.4 )
 916
 917 3800    continue
 918
 919 !
 920 !   check for legal combinations of nnewsave(1,n) & nnewsave(2,n)
 921 !   error if
 922 !     nnew1 == nnew2
 923 !     both are non-zero AND iabs(nnew1-nnew2) != 1
 924         ierr = 0
 925         if (nnewsave(1,n) .eq. nnewsave(2,n)) then
 926             ierr = 1
 927         else if (nnewsave(1,n)*nnewsave(2,n) .ne. 0) then
 928             if (iabs(nnewsave(1,n)-nnewsave(2,n)) .ne. 1) ierr = 1
 929         end if
 930         if (ierr .gt. 0) then
 931             write(msg,97010) 'E', 'RROR', iclm, jclm, k, m,   &
 932                 n, nnewsave(1,n), nnewsave(2,n), iforce_movecenter(n)
 933             call peg_message( lunout, msg )
 934         end if
 935
 936
 937 !   if method_movesect == 30-31 then force moving center
 938 !   this is just for testing purposes
 939         if ((method_movesect .ge. 30) .and. (method_movesect .le. 39)) then
 940             nnewsave(1,n) = nnew
 941             nnewsave(2,n) = 0
 942             xferfracvol(1,n) = 1.0
 943             xferfracvol(2,n) = 0.0
 944             xferfracnum(1,n) = 1.0
 945             xferfracnum(2,n) = 0.0
 946         end if
 947
 948 3900    continue
 949
 950         return
 951         end subroutine move_sections_calc_masnumadvect
 952
 953
 954 !-----------------------------------------------------------------------
 955         subroutine move_sections_apply_moves(   &
 956           iflag, iclm, jclm, k, m, iphase, itype,   &
 957           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
 958           densdefault, densh2o, smallmassaa, smallmassbb,   &
 959           delta_water_conform1, delta_numb_conform1,   &
 960           drydenspp, drymasspp, rnumbpp,   &
 961           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
 962           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy,   &
 963           xferfracvol, xferfracnum )
 964 !
 965 !   routine performs the actual transfer of aerosol number and mass
 966 !       between sections
 967 !
 968         implicit none
 969
 970 !       include 'v33com'
 971 !       include 'v33com2'
 972 !       include 'v33com3'
 973 !       include 'v33com9a'
 974 !       include 'v33com9b'
 975
 976 !   subr arguments
 977         integer iflag, iclm, jclm, iphase, itype, k,   &
 978           m, method_movesect, idiag_movesect, llhysw, llwater
 979         integer nnewsave(2,maxd_asize)
 980
 981         real densdefault, densh2o, smallmassaa, smallmassbb
 982         real delta_water_conform1, delta_numb_conform1
 983         real drydenspp(maxd_asize)
 984         real drymasspp(maxd_asize)
 985         real drymassxx(maxd_asize), drymassyy(maxd_asize)
 986         real dryvolxx(maxd_asize), dryvolyy(maxd_asize)
 987         real rmassxx(maxd_acomp+2,maxd_asize),   &
 988              rmassyy(maxd_acomp+2,maxd_asize)
 989         real rnumbpp(maxd_asize)
 990         real rnumbxx(maxd_asize), rnumbyy(maxd_asize)
 991         real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize)
 992         real wetvolxx(maxd_asize), wetvolyy(maxd_asize)
 993         real wetmassxx(maxd_asize), wetmassyy(maxd_asize)
 994
 995 !   local variables
 996         integer jj, l, ll, n, ndum, nnew, nold
 997         integer jja, jjb, jjc
 998
 999         real delta_numb_conform2,   &
1000           dumbot, dumnum, dumnum_at_dhi, dumnum_at_dlo,   &
1001           dumvol, dumvol1p, dumxfvol, dumxfnum, sixoverpi, third
1002         real dumpp(maxd_asize), dumxx(maxd_asize), dumyy(maxd_asize),   &
1003           dumout(maxd_asize)
1004
1005         character*160 msg
1006         character*8 dumch8
1007         character*4 dumch4
1008
1009
1010         sixoverpi = 6.0/pi
1011         third = 1.0/3.0
1012
1013 !
1014 !   initialize "yy" arrays that hold values after inter-mode transferring
1015 !       "yy" = "xx" for sections that do not move at all
1016 !       "yy" = 0.0  for sections that do move (partially or completely)
1017 !
1018         do 1900 n = 1, nsize_aer(itype)
1019
1020         if ( (nnewsave(1,n) .eq. n) .and.   &
1021              (nnewsave(2,n) .eq. 0) ) then
1022 !   if nnew == n, then material in section n will not be transferred, and
1023 !       section n will contain its initial material plus any material
1024 !       transferred from other sections
1025 !   so initialize "yy" arrays with "xx" values
1026             drymassyy(n) = drymassxx(n)
1027             dryvolyy(n) = dryvolxx(n)
1028             wetmassyy(n) = wetmassxx(n)
1029             wetvolyy(n) = wetvolxx(n)
1030             rnumbyy(n) = rnumbxx(n)
1031             do ll = 1, ncomp_plustracer_aer(itype) + 2
1032                 rmassyy(ll,n) = rmassxx(ll,n)
1033             end do
1034
1035         else
1036 !   if nnew .ne. n, then material in section n will be transferred, and
1037 !       section n will only contain material that is transferred from
1038 !       other sections
1039 !   so initialize "yy" arrays to zero
1040             drymassyy(n) = 0.0
1041             dryvolyy(n) = 0.0
1042             wetmassyy(n) = 0.0
1043             wetvolyy(n) = 0.0
1044             rnumbyy(n) = 0.0
1045             do ll = 1, ncomp_plustracer_aer(itype) + 2
1046                 rmassyy(ll,n) = 0.0
1047             end do
1048
1049         end if
1050
1051 1900    continue
1052
1053 !
1054 !   do the transfer of mass and number
1055 !
1056         do 2900 nold = 1, nsize_aer(itype)
1057
1058         if ( (nnewsave(1,nold) .eq. nold) .and.   &
1059              (nnewsave(2,nold) .eq. 0   ) ) goto 2900
1060
1061         do 2800 jj = 1, 2
1062
1063         nnew = nnewsave(jj,nold)
1064         if (nnew .le. 0) goto 2800
1065
1066         dumxfvol = xferfracvol(jj,nold)
1067         dumxfnum = xferfracnum(jj,nold)
1068
1069         do ll = 1, ncomp_plustracer_aer(itype) + 2
1070             rmassyy(ll,nnew) = rmassyy(ll,nnew) + rmassxx(ll,nold)*dumxfvol
1071         end do
1072         rnumbyy(nnew) = rnumbyy(nnew) + rnumbxx(nold)*dumxfnum
1073
1074         drymassyy(nnew) = drymassyy(nnew) + drymassxx(nold)*dumxfvol
1075         dryvolyy(nnew)  = dryvolyy(nnew)  + dryvolxx(nold)*dumxfvol
1076         wetmassyy(nnew) = wetmassyy(nnew) + wetmassxx(nold)*dumxfvol
1077         wetvolyy(nnew)  = wetvolyy(nnew)  + wetvolxx(nold)*dumxfvol
1078
1079 2800    continue
1080
1081 2900    continue
1082
1083 !
1084 !   transfer among sections is completed
1085 !   - check for conservation of mass/volume/number
1086 !   - conform number again
1087 !   - compute/store densities and mean sizes
1088 !   - if k=1, save values for use by dry deposition routine
1089 !   - copy new mixrats back to rsub array
1090 !
1091         call move_sections_conserve_check(   &
1092           1, iflag, iclm, jclm, k, m, iphase, itype,   &
1093           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
1094           densdefault, densh2o, smallmassaa, smallmassbb,   &
1095           delta_water_conform1, delta_numb_conform1,   &
1096           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
1097           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy )
1098
1099         delta_numb_conform2 = 0.0
1100
1101         do 3900 n = 1, nsize_aer(itype)
1102
1103         dumvol = dryvolyy(n)
1104         if (min(drymassyy(n),dumvol) .le. smallmassbb) then
1105             dumvol = drymassyy(n)/densdefault
1106             dumnum = drymassyy(n)/(volumlo_sect(n,itype)*densdefault)
1107             delta_numb_conform2 = delta_numb_conform2 + dumnum - rnumbyy(n)
1108             rnumbyy(n) = dumnum
1109             adrydens_sub(n,itype,k,m) = densdefault
1110             awetdens_sub(n,itype,k,m) = densdefault
1111             admeandry_sub(n,itype,k,m) = dcen_sect(n,itype)
1112             admeanwet_sub(n,itype,k,m) = dcen_sect(n,itype)
1113         else
1114             dumnum = rnumbyy(n)
1115             dumnum_at_dhi = dumvol/volumhi_sect(n,itype)
1116             dumnum_at_dlo = dumvol/volumlo_sect(n,itype)
1117             dumnum = max( dumnum_at_dhi, min( dumnum_at_dlo, dumnum ) )
1118             delta_numb_conform2 = delta_numb_conform2 + dumnum - rnumbyy(n)
1119             rnumbyy(n) = dumnum
1120             adrydens_sub(n,itype,k,m) = drymassyy(n)/dumvol
1121             dumvol1p = dumvol/dumnum
1122             admeandry_sub(n,itype,k,m) = (dumvol1p*sixoverpi)**third
1123             awetdens_sub(n,itype,k,m) = wetmassyy(n)/wetvolyy(n)
1124             dumvol1p = wetvolyy(n)/dumnum
1125             admeanwet_sub(n,itype,k,m) = min( 100.*dcen_sect(n,itype),   &
1126                         (dumvol1p*sixoverpi)**third )
1127         end if
1128         aqvoldry_sub(n,itype,k,m) = dumvol
1129         aqmassdry_sub(n,itype,k,m) = drymassyy(n)
1130
1131 !       if (k .eq. 1) then
1132 !           awetdens_sfc(n,itype,iclm,jclm) = awetdens_sub(n,itype,k,m)
1133 !           admeanwet_sfc(n,itype,iclm,jclm) = admeanwet_sub(n,itype,k,m)
1134 !       end if
1135
1136         do ll = 1, ncomp_plustracer_aer(itype)
1137             l = massptr_aer(ll,n,itype,iphase)
1138             rsub(l,k,m) = rmassyy(ll,n)
1139         end do
1140         l = 0
1141         if (iphase .eq. ai_phase) then
1142             l = waterptr_aer(n,itype)
1143             if (l .gt. 0) rsub(l,k,m) = rmassyy(llwater,n)
1144             l = hyswptr_aer(n,itype)
1145             if (l .gt. 0) rsub(l,k,m) = rmassyy(llhysw,n)
1146         end if
1147         rsub(numptr_aer(n,itype,iphase),k,m) = rnumbyy(n)
1148
1149 3900    continue
1150
1151         delta_numb_conform1 = delta_numb_conform1 + delta_numb_conform2
1152
1153         call move_sections_conserve_check(   &
1154           2, iflag, iclm, jclm, k, m, iphase, itype,   &
1155           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
1156           densdefault, densh2o, smallmassaa, smallmassbb,   &
1157           delta_water_conform1, delta_numb_conform1,   &
1158           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
1159           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy )
1160
1161
1162 !   diagnostic output
1163 !   output nnewsave values when msectional=7xxx
1164         if (idiag_movesect .ne. 70) goto 4900
1165
1166         ndum = 0
1167         do n = 1, nsize_aer(itype)
1168             if (nnewsave(1,n)+nnewsave(2,n) .ne. n) ndum = ndum + 1
1169         end do
1170 !       if (ndum .gt. 0) then
1171 !           write(msg,97010) 'SOME', iclm, jclm, k, m,   &
1172 !               ndum, (nnewsave(1,n), nnewsave(2,n), n=1,nsize_aer(itype))
1173 !           call peg_message( lunout, msg )
1174 !       else
1175 !           write(msg,97010) 'NONE', iclm, jclm, k, m,   &
1176 !               ndum, (nnewsave(1,n), nnewsave(2,n), n=1,nsize_aer(itype))
1177 !           call peg_message( lunout, msg )
1178 !       end if
1179
1180         dumch4 = 'NONE'
1181         if (ndum .gt. 0) dumch4 = 'SOME'
1182         msg = ' '
1183         call peg_message( lunout, msg )
1184         write(msg,97010) dumch4, iclm, jclm, k, m, ndum
1185         call peg_message( lunout, msg )
1186         do jjb = 1, nsize_aer(itype), 10
1187             jjc = min( jjb+9, nsize_aer(itype) )
1188             write(msg,97011) (nnewsave(1,n), nnewsave(2,n), n=jjb,jjc)
1189             call peg_message( lunout, msg )
1190         end do
1191
1192 !       write(msg,97020) 'rnumbold', (rnumbxx(n), n=1,nsize_aer(itype))
1193 !       call peg_message( lunout, msg )
1194 !       write(msg,97020) 'rnumbnew', (rnumbyy(n), n=1,nsize_aer(itype))
1195 !       call peg_message( lunout, msg )
1196
1197 !       write(msg,97020) 'drvolold', (dryvolxx(n), n=1,nsize_aer(itype))
1198 !       call peg_message( lunout, msg )
1199 !       write(msg,97020) 'drvolnew', (dryvolyy(n), n=1,nsize_aer(itype))
1200 !       call peg_message( lunout, msg )
1201
1202         dumbot = log( volumhi_sect(1,itype)/volumlo_sect(1,itype) )
1203         do n = 1, nsize_aer(itype)
1204             dumpp(n) = -9.99
1205             dumxx(n) = -9.99
1206             dumyy(n) = -9.99
1207             if ( (drydenspp(n) .gt. 0.5) .and.   &
1208                  (drymasspp(n) .gt. smallmassaa) ) then
1209                 dumvol = drymasspp(n)/drydenspp(n)
1210                 if ((rnumbpp(n) .ge. 1.0e-35) .and.   &
1211                     (dumvol .ge. 1.0e-35)) then
1212                     dumvol1p = dumvol/rnumbpp(n)
1213                     dumpp(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot
1214                 end if
1215             end if
1216             if ((rnumbxx(n) .ge. 1.0e-35) .and.   &
1217                 (dryvolxx(n) .ge. 1.0e-35)) then
1218                 dumvol1p = dryvolxx(n)/rnumbxx(n)
1219                 dumxx(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot
1220             end if
1221             if ((rnumbyy(n) .ge. 1.0e-35) .and.   &
1222                 (dryvolyy(n) .ge. 1.0e-35)) then
1223                 dumvol1p = dryvolyy(n)/rnumbyy(n)
1224                 dumyy(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot
1225             end if
1226         end do
1227
1228 !       write(msg,97030) 'lnvolold', (dumxx(n), n=1,nsize_aer(itype))
1229 !       call peg_message( lunout, msg )
1230 !       write(msg,97030) 'lnvolnew', (dumyy(n), n=1,nsize_aer(itype))
1231 !       call peg_message( lunout, msg )
1232
1233         do jja = 1, 7
1234             if      (jja .eq. 1) then
1235                 dumch8 = 'rnumbold'
1236                 dumout(:) = rnumbxx(:)
1237             else if (jja .eq. 2) then
1238                 dumch8 = 'rnumbnew'
1239                 dumout(:) = rnumbyy(:)
1240             else if (jja .eq. 3) then
1241                 dumch8 = 'drvolold'
1242                 dumout(:) = dryvolxx(:)
1243             else if (jja .eq. 4) then
1244                 dumch8 = 'drvolnew'
1245                 dumout(:) = dryvolyy(:)
1246             else if (jja .eq. 5) then
1247                 dumch8 = 'lnvolold'
1248                 dumout(:) = dumxx(:)
1249             else if (jja .eq. 6) then
1250                 dumch8 = 'lnvolnew'
1251                 dumout(:) = dumyy(:)
1252             else if (jja .eq. 7) then
1253                 dumch8 = 'lnvolpre'
1254                 dumout(:) = dumpp(:)
1255             end if
1256             do jjb = 1, nsize_aer(itype), 10
1257                 jjc = min( jjb+9, nsize_aer(itype) )
1258                 if (jja .le. 4) then
1259                     write(msg,97020) dumch8, (dumout(n), n=jjb,jjc)
1260                 else
1261                     write(msg,97030) dumch8, (dumout(n), n=jjb,jjc)
1262                 end if
1263                 call peg_message( lunout, msg )
1264                 dumch8 = ' '
1265             end do
1266         end do
1267
1268 !97010  format( / 'movesectapply', a, 4i3, 3x, i3 / 5x, 10(3x,2i3) )
1269 !97020  format( a, 1p, 10e9.1 / (( 8x, 1p, 10e9.1 )) )
1270 !97030  format( a,     10f9.3 / (( 8x,     10f9.3 )) )
1271 97010   format( 'movesectapply', a, 4i3, 3x, i3 )
1272 97011   format( 5x, 10(3x,2i3) )
1273 97020   format( a, 1p, 10e9.1 )
1274 97030   format( a,     10f9.3 )
1275
1276 4900    continue
1277         return
1278         end subroutine move_sections_apply_moves
1279
1280
1281 !-----------------------------------------------------------------------
1282 ! rce 08-nov-2004 - this routine is new (and perhaps temporary)
1283 !
1284         subroutine move_sections_apply_n1_inflow(   &
1285           iflag, iclm, jclm, k, m, iphase, itype,   &
1286           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
1287           densdefault, densh2o, smallmassaa, smallmassbb,   &
1288           delta_water_conform1, delta_numb_conform1,   &
1289           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
1290           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy,   &
1291           xferfracvol, xferfracnum,   &
1292           specmwxx, specdensxx )
1293 !
1294 !   routine applies an ad_hoc correction to bin 1 to account for
1295 !       growth of smaller particles (which are not simulated) growing into
1296 !       bin 1
1297 !   the correction to particle number balances the loss of particles from
1298 !       bin 1 to larger bins by growth
1299 !   the correction to mass assumes that the particles coming into bin 1
1300 !       are slightly larger than dlo_sect(1)
1301 !
1302         implicit none
1303
1304 !       include 'v33com'
1305 !       include 'v33com2'
1306 !       include 'v33com3'
1307 !       include 'v33com9a'
1308 !       include 'v33com9b'
1309
1310 !   subr arguments
1311         integer iflag, iclm, jclm, iphase, itype, k,   &
1312           m, method_movesect, idiag_movesect, llhysw, llwater
1313         integer nnewsave(2,maxd_asize)
1314
1315         real densdefault, densh2o, smallmassaa, smallmassbb
1316         real delta_water_conform1, delta_numb_conform1
1317         real drymassxx(maxd_asize), drymassyy(maxd_asize)
1318         real dryvolxx(maxd_asize), dryvolyy(maxd_asize)
1319         real rmassxx(maxd_acomp+2,maxd_asize),   &
1320              rmassyy(maxd_acomp+2,maxd_asize)
1321         real rnumbxx(maxd_asize), rnumbyy(maxd_asize)
1322         real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize)
1323         real wetvolxx(maxd_asize), wetvolyy(maxd_asize)
1324         real wetmassxx(maxd_asize), wetmassyy(maxd_asize)
1325         real specdensxx(maxd_acomp), specmwxx(maxd_acomp)
1326
1327
1328 !   local variables
1329         integer jj, l, ll, n, nnew, nold
1330
1331         real deltanum, deltavol, dumvol1p, dumxfvol, dumxfnum
1332
1333
1334 !
1335 !   compute fraction of number transferred out of bin 1 by growth
1336 !
1337         nold = 1
1338         n = nold
1339         if ( (nnewsave(1,nold) .eq. nold) .and.   &
1340              (nnewsave(2,nold) .eq. 0   ) ) goto 3900
1341
1342         dumxfnum = 0.0
1343         do 2800 jj = 1, 2
1344             nnew = nnewsave(jj,nold)
1345             if (nnew .le. 0) goto 2800
1346             if (nnew .eq. nold) goto 2800
1347             dumxfnum = dumxfnum + xferfracnum(jj,nold)
1348 2800    continue
1349
1350 !
1351 !   compute "inflow" change to number and volume
1352 !     number change matches that lost by growth
1353 !     volume change assume inflow particles slightly bigger then dlo_sect
1354 !
1355         dumvol1p = 0.95*volumlo_sect(n,itype) + 0.05*volumhi_sect(n,itype)
1356         deltanum = dumxfnum*rnumbxx(n)
1357         deltavol = deltanum*dumvol1p
1358         if (dumxfnum .le. 0.0) goto 3900
1359         if (deltanum .le. 0.0) goto 3900
1360         if (deltavol .le. 0.0) goto 3900
1361
1362 !
1363 !   increment the number and masses
1364 !   if the old dryvol (dryvolxx) > smallmassbb, then compute mass increment for
1365 !       each species from the old masses (rmassxx)
1366 !   otherwise only increment the first mass species
1367 !
1368         if (dryvolxx(n) .gt. smallmassbb) then
1369             dumxfvol = deltavol/dryvolxx(n)
1370             do ll = 1, ncomp_plustracer_aer(itype) + 2
1371                 rmassyy(ll,n) = rmassyy(ll,n) + dumxfvol*rmassxx(ll,n)
1372             end do
1373         else
1374             ll = 1
1375             rmassyy(ll,n) = rmassyy(ll,n) + deltavol*specdensxx(ll)/specmwxx(ll)
1376         end if
1377         rnumbyy(n) = rnumbyy(n) + deltanum
1378
1379 !
1380 !   transfer results into rsub
1381 !
1382         do ll = 1, ncomp_plustracer_aer(itype)
1383             l = massptr_aer(ll,n,itype,iphase)
1384             rsub(l,k,m) = rmassyy(ll,n)
1385         end do
1386         if (iphase .eq. ai_phase) then
1387             l = waterptr_aer(n,itype)
1388             if (l .gt. 0) rsub(l,k,m) = rmassyy(llwater,n)
1389             l = hyswptr_aer(n,itype)
1390             if (l .gt. 0) rsub(l,k,m) = rmassyy(llhysw,n)
1391         end if
1392         rsub(numptr_aer(n,itype,iphase),k,m) = rnumbyy(n)
1393
1394
1395 3900    continue
1396         return
1397         end subroutine move_sections_apply_n1_inflow
1398
1399
1400 !-----------------------------------------------------------------------
1401         subroutine move_sections_conserve_check( ipass,   &
1402           iflag, iclm, jclm, k, m, iphase, itype,   &
1403           method_movesect, idiag_movesect, llhysw, llwater, nnewsave,   &
1404           densdefault, densh2o, smallmassaa, smallmassbb,   &
1405           delta_water_conform1, delta_numb_conform1,   &
1406           drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx,   &
1407           drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy )
1408 !
1409 !   routine checks for conservation of number, mass, and volume
1410 !       by the move_sections algorithm
1411 !
1412 !   ipass = 1
1413 !       initialize all thesum(jj,ll) to zero
1414 !       computes thesum(1,ll) from rmassxx, rnumbxx, ...
1415 !       computes thesum(2,ll) from rmassyy, rnumbyy, ...
1416 !       compares thesum(1,ll) with thesum(2,ll)
1417 !       computes thesum(3,ll) from rsub before section movement
1418 !   ipass = 2
1419 !       computes thesum(4,ll) from rsub after  section movement
1420 !       compares thesum(3,ll) with thesum(4,ll)
1421 !
1422 !   currently only implemented for condensational growth (iflag=1)
1423 !
1424         implicit none
1425
1426 !       include 'v33com'
1427 !       include 'v33com2'
1428 !       include 'v33com3'
1429 !       include 'v33com9a'
1430 !       include 'v33com9b'
1431
1432 !   subr arguments
1433         integer ipass, iflag, iclm, jclm, iphase, itype, k,   &
1434           m, method_movesect, idiag_movesect, llhysw, llwater
1435         integer nnewsave(2,maxd_asize)
1436         real densdefault, densh2o, smallmassaa, smallmassbb
1437         real delta_water_conform1, delta_numb_conform1
1438         real drymassxx(maxd_asize), drymassyy(maxd_asize)
1439         real dryvolxx(maxd_asize), dryvolyy(maxd_asize)
1440         real rmassxx(maxd_acomp+2,maxd_asize),   &
1441              rmassyy(maxd_acomp+2,maxd_asize)
1442         real rnumbxx(maxd_asize), rnumbyy(maxd_asize)
1443         real wetvolxx(maxd_asize), wetvolyy(maxd_asize)
1444         real wetmassxx(maxd_asize), wetmassyy(maxd_asize)
1445
1446 !   local variables
1447         integer jj, l, ll, llworst, llworstb, n
1448         integer nerr, nerrmax
1449         save nerr, nerrmax
1450         data nerr, nerrmax / 0, 999 /
1451
1452         real dumbot, dumtop, dumtoler, dumerr, dumworst, dumworstb
1453         real duma, dumb, dumc, dume
1454         real thesum(4,maxd_acomp+7)
1455         save thesum
1456
1457         character*8 dumname(maxd_acomp+7)
1458         character*160 msg
1459
1460
1461         if (ipass .eq. 2) goto 2000
1462
1463         do ll = 1, ncomp_plustracer_aer(itype)+7
1464         do jj = 1, 4
1465             thesum(jj,ll) = 0.0
1466         end do
1467         end do
1468
1469         do n = 1, nsize_aer(itype)
1470             do ll = 1, ncomp_plustracer_aer(itype)+2
1471                 thesum(1,ll) = thesum(1,ll) + rmassxx(ll,n)
1472                 thesum(2,ll) = thesum(2,ll) + rmassyy(ll,n)
1473             end do
1474             ll = ncomp_plustracer_aer(itype)+3
1475             thesum(1,ll) = thesum(1,ll) + rnumbxx(n)
1476             thesum(2,ll) = thesum(2,ll) + rnumbyy(n)
1477             ll = ncomp_plustracer_aer(itype)+4
1478             thesum(1,ll) = thesum(1,ll) + drymassxx(n)
1479             thesum(2,ll) = thesum(2,ll) + drymassyy(n)
1480             ll = ncomp_plustracer_aer(itype)+5
1481             thesum(1,ll) = thesum(1,ll) + dryvolxx(n)
1482             thesum(2,ll) = thesum(2,ll) + dryvolyy(n)
1483             ll = ncomp_plustracer_aer(itype)+6
1484             thesum(1,ll) = thesum(1,ll) + wetmassxx(n)
1485             thesum(2,ll) = thesum(2,ll) + wetmassyy(n)
1486             ll = ncomp_plustracer_aer(itype)+7
1487             thesum(1,ll) = thesum(1,ll) + wetvolxx(n)
1488             thesum(2,ll) = thesum(2,ll) + wetvolyy(n)
1489         end do
1490
1491
1492 2000    continue
1493 !
1494 !   calc sum over bins for each species
1495 !   for water, account for loss in initial conform (delta_water_conform1)
1496 !
1497         do n = 1, nsize_aer(itype)
1498             do ll = 1, ncomp_plustracer_aer(itype)+3
1499                 if (ll .le. ncomp_plustracer_aer(itype)) then
1500                     l = massptr_aer(ll,n,itype,iphase)
1501                 else if (ll .eq. ncomp_plustracer_aer(itype)+1) then
1502                     l = 0
1503                     if (iphase .eq. ai_phase) l = hyswptr_aer(n,itype)
1504                 else if (ll .eq. ncomp_plustracer_aer(itype)+2) then
1505                     l = 0
1506                     if (iphase .eq. ai_phase) l = waterptr_aer(n,itype)
1507                 else
1508                     l = numptr_aer(n,itype,iphase)
1509                 end if
1510                 if (l .gt. 0)   &
1511                     thesum(ipass+2,ll) = thesum(ipass+2,ll) + rsub(l,k,m)
1512             end do
1513         end do
1514         if (ipass .eq. 2) then
1515             ll = ncomp_plustracer_aer(itype)+2
1516             thesum(3,ll) = thesum(3,ll) + delta_water_conform1
1517             ll = ncomp_plustracer_aer(itype)+3
1518             thesum(3,ll) = thesum(3,ll) + delta_numb_conform1
1519         end if
1520
1521 !
1522 !   now compare either sum1-sum2 or sum3-sum4
1523 !       on ipass=1, jj=1, so compare sum1 & sum2
1524 !       on ipass=2, jj=3, so compare sum3 & sum4
1525 !
1526         do ll = 1, ncomp_plustracer_aer(itype)+7
1527             dumname(ll) = ' '
1528             write(dumname(ll),'(i4.4)') ll
1529             if (ll .le. ncomp_plustracer_aer(itype)) dumname(ll) =   &
1530                         name(massptr_aer(ll,1,itype,iphase))(1:4)
1531             if (ll .eq. ncomp_plustracer_aer(itype)+1) dumname(ll) = 'hysw'
1532             if (ll .eq. ncomp_plustracer_aer(itype)+2) dumname(ll) = 'watr'
1533             if (ll .eq. ncomp_plustracer_aer(itype)+3) dumname(ll) = 'numb'
1534             if (ll .eq. ncomp_plustracer_aer(itype)+4) dumname(ll) = 'drymass'
1535             if (ll .eq. ncomp_plustracer_aer(itype)+5) dumname(ll) = 'dryvol'
1536             if (ll .eq. ncomp_plustracer_aer(itype)+6) dumname(ll) = 'wetmass'
1537             if (ll .eq. ncomp_plustracer_aer(itype)+7) dumname(ll) = 'wetvol'
1538         end do
1539
1540         jj = 2*ipass - 1
1541         dumworst = 0.0
1542         dumworstb = 0.0
1543         llworst = 0
1544         llworstb = 0
1545         do ll = 1, ncomp_plustracer_aer(itype)+7
1546             dumtop = thesum(jj+1,ll) - thesum(jj,ll)
1547 !           dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-35 )
1548 ! change minimum dumbot to 1.0e-30 to reduce unimportant error messages
1549             dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-30 )
1550             dumerr = dumtop/dumbot
1551
1552 ! rce 21-jul-2006 - encountered some cases when delta_*_conform1 is negative
1553 !   and large in magnitude relative to thesum, which causes the mass
1554 !   conservation to be less accurate due to roundoff
1555 ! following section recomputes relative error with delta_*_conform1
1556 !   added onto each of thesum
1557 ! also increased dumtoler slightly
1558             if (ipass .eq. 2) then
1559                 dumc = 1.0
1560                 if (ll .eq. ncomp_plustracer_aer(itype)+2) then
1561                     dumc = delta_water_conform1
1562                 else if (ll .eq. ncomp_plustracer_aer(itype)+3) then
1563                     dumc = delta_numb_conform1
1564                 end if
1565                 if (dumc .lt. 0.0) then
1566                     duma = thesum(3,ll) - dumc
1567                     dumb = thesum(4,ll) - dumc
1568                     dumtop = dumb - duma
1569 !                   dumbot = max( abs(duma), abs(dumb), 1.0e-35 )
1570                     dumbot = max( abs(duma), abs(dumb), 1.0e-30 )
1571                     dume = dumtop/dumbot
1572                     if (abs(dume) .lt. abs(dumerr)) dumerr = dume
1573                 end if
1574             end if
1575
1576             if (abs(dumerr) .gt. abs(dumworst)) then
1577                 llworstb = llworst
1578                 dumworstb = dumworst
1579                 llworst = ll
1580                 dumworst = dumerr
1581             end if
1582         end do
1583
1584         dumtoler = 1.0e-6
1585         if (abs(dumworst) .gt. dumtoler) then
1586             nerr = nerr + 1
1587             if (nerr .le. nerrmax) then
1588                 msg = ' '
1589                 call peg_message( lunout, msg )
1590                 write(msg,97110) iclm, jclm, k, m, ipass, llworst
1591                 call peg_message( lunout, msg )
1592                 write(msg,97120) '    nnew(1,n)',   &
1593                         (nnewsave(1,n), n=1,nsize_aer(itype))
1594                 call peg_message( lunout, msg )
1595                 write(msg,97120) '    nnew(2,n)',   &
1596                         (nnewsave(2,n), n=1,nsize_aer(itype))
1597                 call peg_message( lunout, msg )
1598
1599                 ll = llworst
1600                 if (ll .eq. 0) ll = ncomp_plustracer_aer(itype)+2
1601                 write(msg,97130) 'name/relerr/thesum', jj, '/thesum', jj+1,   &
1602                         dumname(ll), dumworst, thesum(jj,ll), thesum(jj+1,ll)
1603                 call peg_message( lunout, msg )
1604
1605                 if ( (ll .eq. ncomp_plustracer_aer(itype)+3) .and.   &
1606                      (abs(dumworstb) .gt. dumtoler) ) then
1607                     ll = max( 1, llworstb )
1608                     dumtop = thesum(jj+1,ll) - thesum(jj,ll)
1609 !                   dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-35 )
1610                     dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-30 )
1611                     dumerr = dumtop/dumbot
1612                     write(msg,97130) 'name/relerr/thesum', jj, '/thesum', jj+1,   &
1613                         dumname(ll), dumerr, thesum(jj,ll), thesum(jj+1,ll)
1614                     call peg_message( lunout, msg )
1615                 end if
1616             end if
1617         end if
1618
1619 97110   format( 'movesect conserve ERROR - i/j/k/m/pass/llworst',   &
1620                 4i3, 2x, 2i3 )
1621 97120   format( a, 64i3 )
1622 97130   format( a, i1, a, i1, 2x, a, 1p, 3e16.7 )
1623
1624         return
1625         end subroutine move_sections_conserve_check
1626
1627
1628 !-----------------------------------------------------------------------
1629         subroutine test_move_sections( iflag_test, iclm, jclm, k, m )
1630 !
1631 !   routine runs tests on move_sections, using a matrix of
1632 !       pregrow and aftgrow masses for each section
1633 !
1634         implicit none
1635
1636 !       include 'v33com'
1637 !       include 'v33com2'
1638 !       include 'v33com3'
1639 !       include 'v33com9a'
1640 !       include 'v33com9b'
1641
1642 !   subr arguments
1643         integer iflag_test, iclm, jclm, k, m
1644
1645 !   local variables
1646         integer idiag_movesect, iflag, ii, iphase, itype, jj,   &
1647           l, ll, n, nn
1648         integer ientryno
1649         save ientryno
1650         data ientryno / 0 /
1651
1652         real dumnumb, dumvolpre, dumvolaft
1653         real dumsv_rsub(l2maxd)
1654         real dumsv_drymass_pregrow(maxd_asize,maxd_atype)
1655         real dumsv_drymass_aftgrow(maxd_asize,maxd_atype)
1656         real dumsv_drydens_pregrow(maxd_asize,maxd_atype)
1657         real dumsv_drydens_aftgrow(maxd_asize,maxd_atype)
1658
1659         character*160 msg
1660
1661         integer maxvolfactpre, maxvolfactaft
1662         parameter (maxvolfactpre=15, maxvolfactaft=23)
1663
1664         real dumvolfactpre(maxvolfactpre)
1665         data dumvolfactpre /   &
1666         2.0, 0.0, 1.0e-20, 0.5, 0.9,   &
1667         1.0, 1.01, 1.1, 2.0, 4.0, 7.9, 7.99, 8.0,   &
1668         8.1, 16.0 /
1669
1670         real dumvolfactaft(maxvolfactaft)
1671         data dumvolfactaft /   &
1672         4.0, 0.0, 1.0e-20, 0.01, 0.02, 0.05, 0.1, 0.5, 0.9,   &
1673         1.0, 1.01, 1.1, 2.0, 4.0, 7.9, 7.99, 8.0,   &
1674         8.1, 16.0, 32., 64., 128., 256. /
1675
1676
1677 !
1678 !   check for valid inputs
1679 !   and first entry
1680 !
1681         if (msectional .le. 0) return
1682         if (nsize_aer(1) .le. 0) return
1683
1684         idiag_movesect = mod( msectional, 10000 )/100
1685         if (idiag_movesect .ne. 70) return
1686
1687         ientryno = ientryno + 1
1688         if (ientryno .gt. 2) return
1689
1690 !
1691 !   save rsub and drymass/dens_aft/pregrow
1692 !
1693         do l = 1, ltot2
1694             dumsv_rsub(l) = rsub(l,k,m)
1695         end do
1696         do itype = 1, ntype_aer
1697             do n = 1, nsize_aer(itype)
1698                 dumsv_drymass_pregrow(n,itype) = drymass_pregrow(n,itype)
1699                 dumsv_drymass_aftgrow(n,itype) = drymass_aftgrow(n,itype)
1700                 dumsv_drydens_pregrow(n,itype) = drydens_pregrow(n,itype)
1701                 dumsv_drydens_aftgrow(n,itype) = drydens_aftgrow(n,itype)
1702             end do
1703         end do
1704
1705 !
1706 !   make test calls to move_sections
1707 !
1708         do 3900 iflag = 1, 1
1709
1710         iphase = ai_phase
1711         if (iabs(iflag) .eq. 2) iphase = cw_phase
1712
1713         do 3800 itype = 1, ntype_aer
1714
1715         do 2900 nn = 1, nsize_aer(itype)
1716
1717         do 2800 ii = 1, maxvolfactpre
1718
1719         do 2700 jj = 1, maxvolfactaft
1720
1721 !   zero out rsub and dryxxx_yyygrow arrays
1722         do n = 1, nsize_aer(itype)
1723             do ll = 1, ncomp_plustracer_aer(itype)
1724                 rsub(massptr_aer(ll,n,itype,iphase),k,m) = 0.0
1725             end do
1726             l = 0
1727             if (iphase .eq. ai_phase) l = waterptr_aer(n,itype)
1728             if (l .gt. 0) rsub(l,k,m) = 0.0
1729             l = numptr_aer(n,itype,iphase)
1730             if (l .gt. 0) rsub(l,k,m) = 0.0
1731             drymass_pregrow(n,itype) = 0.0
1732             drymass_aftgrow(n,itype) = 0.0
1733             drydens_pregrow(n,itype) = -1.0
1734             drydens_aftgrow(n,itype) = -1.0
1735         end do
1736
1737 !   fill in values for section nn
1738         n = nn
1739         dumnumb = 1.0e7
1740         rsub(numptr_aer(n,itype,iphase),k,m) = dumnumb
1741         ll = 1
1742         l = massptr_aer(ll,n,itype,iphase)
1743
1744         dumvolpre = volumlo_sect(n,itype)*dumvolfactpre(ii)*dumnumb
1745         drydens_pregrow(n,itype) = dens_aer(ll,itype)
1746         drymass_pregrow(n,itype) = dumvolpre*drydens_pregrow(n,itype)
1747         if (ii .eq. 1) drydens_pregrow(n,itype) = -1.0
1748
1749         dumvolaft = volumlo_sect(n,itype)*dumvolfactaft(jj)*dumnumb
1750         drydens_aftgrow(n,itype) = dens_aer(ll,itype)
1751         drymass_aftgrow(n,itype) = dumvolaft*drydens_aftgrow(n,itype)
1752         if (jj .eq. 1) drydens_aftgrow(n,itype) = -1.0
1753
1754         rsub(l,k,m) = drymass_aftgrow(n,itype)/mw_aer(ll,itype)
1755
1756         msg = ' '
1757         call peg_message( lunout, msg )
1758         write(msg,98010) nn, ii, jj
1759         call peg_message( lunout, msg )
1760         write(msg,98011) dumvolfactpre(ii), dumvolfactaft(jj)
1761         call peg_message( lunout, msg )
1762
1763 !   make test call to move_sections
1764         call move_sections( iflag, iclm, jclm, k, m )
1765
1766         msg = ' '
1767         call peg_message( lunout, msg )
1768         write(msg,98010) nn, ii, jj
1769         call peg_message( lunout, msg )
1770         write(msg,98011) dumvolfactpre(ii), dumvolfactaft(jj)
1771         call peg_message( lunout, msg )
1772
1773 2700    continue
1774 2800    continue
1775 2900    continue
1776
1777 3800    continue
1778 3900    continue
1779
1780 98010   format( 'test_move_sections output - nn, ii, jj =', 3i3 )
1781 98011   format( 'volfactpre, volfactaft =', 1p, 2e12.4 )
1782
1783 !
1784 !   restore rsub and drymass/dens_aft/pregrow
1785 !
1786         do l = 1, ltot2
1787             rsub(l,k,m) = dumsv_rsub(l)
1788         end do
1789         do itype = 1, ntype_aer
1790         do n = 1, nsize_aer(itype)
1791             drymass_pregrow(n,itype) = dumsv_drymass_pregrow(n,itype)
1792             drymass_aftgrow(n,itype) = dumsv_drymass_aftgrow(n,itype)
1793             drydens_pregrow(n,itype) = dumsv_drydens_pregrow(n,itype)
1794             drydens_aftgrow(n,itype) = dumsv_drydens_aftgrow(n,itype)
1795         end do
1796         end do
1797
1798         return
1799         end subroutine test_move_sections
1800
1801
1802 !-----------------------------------------------------------------------
1803         subroutine move_sections_checkptrs( iflag, iclm, jclm, k, m )
1804 !
1805 !   checks for valid number and water pointers
1806 !
1807         implicit none
1808
1809 !       include 'v33com'
1810 !       include 'v33com2'
1811 !       include 'v33com3'
1812 !       include 'v33com9a'
1813 !       include 'v33com9b'
1814
1815 !   subr parameters
1816         integer iflag, iclm, jclm, k, m
1817
1818 !   local variables
1819         integer l, itype, iphase, n, ndum
1820         character*160 msg
1821
1822         do 1900 itype = 1, ntype_aer
1823         do 1800 iphase = 1, nphase_aer
1824
1825         ndum = 0
1826         do n = 1, nsize_aer(itype)
1827             l = numptr_aer(n,itype,iphase)
1828             if ((l .le. 0) .or. (l .gt. ltot2)) then
1829                 msg = '*** subr move_sections error - ' //   &
1830                         'numptr_amode not defined'
1831                 call peg_message( lunerr, msg )
1832                 write(msg,9030) 'mode, numptr =', n, l
1833                 call peg_message( lunerr, msg )
1834                 write(msg,9030) 'iphase, itype =', iphase, itype
1835                 call peg_message( lunerr, msg )
1836                 call peg_error_fatal( lunerr, msg )
1837             end if
1838 !       checks involving nspec_amode and nspec_amode_nontracer
1839 !       being the same for all sections are no longer needed
1840             l = 0
1841             if (iphase .eq. ai_phase) l = waterptr_aer(n,itype)
1842             if ((l .gt. 0) .and. (l .le. ltot2)) ndum = ndum + 1
1843         end do
1844         if ((ndum .ne. 0) .and. (ndum .ne. nsize_aer(itype))) then
1845             msg = '*** subr move_sections error - ' //   &
1846                 'waterptr_aer must be on/off for all modes'
1847             call peg_message( lunerr, msg )
1848             write(msg,9030) 'iphase, itype =', iphase, itype
1849             call peg_message( lunerr, msg )
1850             call peg_error_fatal( lunerr, msg )
1851         end if
1852 9030    format( a, 2(1x,i6) )
1853
1854 1800    continue
1855 1900    continue
1856
1857         return
1858         end subroutine move_sections_checkptrs
1859
1860
1861
1862         end module module_mosaic_movesect