chem/module_aerosols_soa_vbs.F

   1 MODULE module_aerosols_soa_vbs
   2 !
   3 ! 10/12/2011: This module is a modified version of the "module_aerosols_sorgam.F". The sorgam subroutine
   4 ! has been replaced by a new SOA scheme based on the Volatiliry Basis Set (VBS) approach, recent smog chamber yields
   5 ! and multi-generational VOC oxidation mechanism (aging) for SOA formation. The SOA_VBS code has been
   6 ! developed by Ravan Ahmadov (ravan.ahmadov@noaa.gov) and Stuart McKeen (Stuart.A.McKeen@noaa.gov) at NOAA/ESRL/CSD.
   7 ! This module has been coupled to the modified version of RACM_ESRL_KPP gas chemistry mechanism. Major modifications to the gas
   8 ! gas chemistry are inclusion of Sesquiterpenes and separation of MBO from OLI.
   9 ! Unlike MOSAIC_VBS this option is for modal approach - MADE aerosol scheme
  10 !
  11 ! Some references for the SOA_VBS scheme:
  12 ! 1) Ahmadov R., McKeen S.A., Robinson A.L., Bahreini R., Middlebrook A., deGouw J., Meagher J., Hsie E.-Y.,
  13 ! Edgerton E., Shaw S., Trainer M. (2012), A volatility basis set model for summertime secondary organic aerosols
  14 ! over the eastern U.S. in 2006. J. Geophys. Res.,117, D06301, doi:10.1029/2011JD016831.
  15 ! 2) Murphy, B. N. and S. N. Pandis (2009). "Simulating the Formation of Semivolatile Primary and Secondary Organic Aerosol
  16 ! in a Regional Chemical Transport Model." Environmental Science & Technology 43(13): 4722-4728.
  17 ! 3) Donahue, N. M., A. L. Robinson, et al. (2006). "Coupled partitioning, dilution, and chemical aging of semivolatile
  18 ! organics." Environmental Science & Technology 40(8): 2635-2643.
  19 !
  20 ! A reference for the MADE aerosol parameterization:
  21 ! Ackermann, I. J., H. Hass, M. Memmesheimer, A. Ebel, F. S. Binkowski, and U. Shankar (1998),
  22 ! Modal aerosol dynamics model for Europe: Development and first applications, Atmos. Environ., 32(17), 2981-2999.
  23 !
  24 !!WARNING! The deposition of organic condensable vapours (cvasoa* and cvbsoa*) are highly uncertain due to lack of observations.
  25 ! Currently this process is parameterized using modeled dry deposition velocities of HNO3 (multiplied by "depo_fact" for OCVs).
  26 ! Paper by Ahmadov et al. (2012) desribes this approach. The default value for "depo_fact" in WRF-CHEM is 0.25.
  27 ! A user can set a different value for "depo_fact" in namelist.input.
  28 !
  29 !!WARNING! Another uncertainty is wet removal of OCVs! This is neglected in the current version of the WRF-CHEM code.
  30 !
  31 ! 30/06/2014: Modified by Paolo Tuccella
  32 !             The module has been modified in order to include the aqueous phase
  33 !
  34   USE module_state_description
  35 !  USE module_data_radm2
  36   USE module_data_soa_vbs
  37 !  USE module_radm
  38
  39   IMPLICIT NONE
  40 #define cw_species_are_in_registry
  41
  42 CONTAINS
  43
  44    SUBROUTINE  soa_vbs_driver ( id,ktau,dtstep,t_phy,moist,aerwrf,p8w,  &
  45                t8w,alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w,             &
  46 !liqy
  47               gamn2o5,cn2o5,kn2o5,yclno2,snu,sac,                       &
  48 !liqy - 20150319
  49                h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,               &
  50                vcsulf_old,                                              &
  51                vdrog3,                                                  &
  52                kemit,brch_ratio,do_isorropia,                           &
  53                ids,ide, jds,jde, kds,kde,                               &
  54                ims,ime, jms,jme, kms,kme,                               &
  55                its,ite, jts,jte, kts,kte                                )
  56
  57 !   USE module_configure, only: grid_config_rec_type
  58 !   TYPE (grid_config_rec_type), INTENT (in) :: config_flags
  59
  60    INTEGER, INTENT(IN   )  ::         ids,ide, jds,jde, kds,kde, &
  61                                       ims,ime, jms,jme, kms,kme, &
  62                                       its,ite, jts,jte, kts,kte, &
  63                                       kemit,   id, ktau
  64
  65    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),        &
  66          INTENT(IN ) ::                                      moist
  67
  68    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),         &
  69          INTENT(INOUT ) ::                                   chem
  70 !
  71 ! following are aerosol arrays that are not advected
  72 !
  73    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
  74          INTENT(INOUT ) ::                                             &
  75 !liqy
  76               gamn2o5,cn2o5,kn2o5,yclno2,snu,sac,          &
  77 !liqy - 20150319
  78            h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
  79
  80    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
  81          INTENT(INOUT ) ::    brch_ratio
  82
  83 !           cvasoa1,cvasoa2,    &
  84 !           cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4
  85
  86    REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog_vbs),                  &
  87          INTENT(IN   ) :: VDROG3
  88    REAL, DIMENSION( ims:ime , kms:kme , jms:jme )         ,            &
  89          INTENT(IN   ) ::                             t_phy,           &
  90                                                         alt,           &
  91                                                       p_phy,           &
  92                                                       dz8w,            &
  93                                                       rh,              &     ! fractional relative humidity
  94                                                         z,             &
  95                                               t8w,p8w,z_at_w ,         &
  96                                                       aerwrf ,         &
  97                                                     rho_phy
  98    REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme )         ,         &
  99          INTENT(IN   ) ::   vcsulf_old
 100    REAL, INTENT(IN   ) ::   dtstep
 101    LOGICAL, INTENT(IN ) :: do_isorropia
 102
 103       REAL drog_in(ldrog_vbs)    ! anthropogenic AND biogenic organic aerosol precursors [ug m**-3 s**-1]
 104
 105 !      REAL condvap_in(lspcv) ! condensable vapors [ug m**-3]
 106       REAL, PARAMETER :: rgas=8.314510
 107       REAL convfac,convfac2
 108
 109 !...BLKSIZE set to one in column model ciarev02
 110       INTEGER, PARAMETER :: blksize=1
 111
 112 !...number of aerosol species
 113 !  number of species (gas + aerosol)
 114       INTEGER nspcsda
 115       PARAMETER (nspcsda=l1ae) !bs
 116 ! (internal aerosol dynamics)
 117 !bs # of anth. cond. vapors in SOA_VBS
 118       INTEGER nacv
 119       PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
 120 !bs total # of cond. vapors in SOA_VBS
 121       INTEGER ncv
 122       PARAMETER (ncv=lspcv) !bs
 123 !bs total # of cond. vapors in CTM
 124       REAL cblk(blksize,nspcsda) ! main array of variables
 125                                    ! particles [ug/m^3/s]
 126       REAL soilrat_in
 127                     ! emission rate of soil derived coars
 128                     ! input HNO3 to CBLK [ug/m^3]
 129       REAL nitrate_in
 130                     ! input NH3 to CBLK  [ug/m^3]
 131       REAL nh3_in
 132                     ! input SO4 vapor    [ug/m^3]
 133       REAL hcl_in
 134
 135       REAL vsulf_in
 136
 137       REAL so4rat_in
 138                     ! input SO4 formation[ug/m^3/sec]
 139       REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
 140                     ! Emission rate of i-mode EC [ug m**-3 s**-1]
 141       REAL eeci_in
 142                     ! Emission rate of j-mode EC [ug m**-3 s**-1]
 143       REAL eecj_in
 144                     ! Emission rate of j-mode org. aerosol [ug m**-
 145       REAL eorgi_in
 146
 147       REAL eorgj_in ! Emission rate of j-mode org. aerosol [ug m**-
 148       REAL pres     ! pressure in cb
 149       REAL temp     ! temperature in K
 150  !     REAL relhum   ! rel. humidity (0,1)
 151       REAL brrto
 152
 153       REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
 154
 155 !...molecular weights                   ciarev02
 156 ! these molecular weights aren't used at all
 157
 158 ! molecular weight for SO4
 159       REAL mwso4
 160       PARAMETER (mwso4=96.0576)
 161
 162 ! molecular weight for HNO3
 163       REAL mwhno3
 164       PARAMETER (mwhno3=63.01287)
 165
 166 ! molecular weight for NH3
 167       REAL mwnh3
 168       PARAMETER (mwnh3=17.03061)
 169
 170 ! molecular weight for HCL
 171       REAL mwhcl
 172       PARAMETER (mwhcl=36.46100)
 173
 174 !bs molecular weight for Elemental Carbon
 175       REAL mwec
 176       PARAMETER (mwec=12.0)
 177 !liqy
 178           REAL mwn2o5
 179           PARAMETER (mwn2o5=108.009)
 180
 181           REAL mwclno2
 182           PARAMETER (mwclno2=81.458)
 183 !liqy-20140905
 184 ! they aren't used
 185 !!rs molecular weight
 186 !      REAL mwaro1
 187 !      PARAMETER (mwaro1=150.0)
 188 !
 189 !!rs molecular weight
 190 !      REAL mwaro2
 191 !      PARAMETER (mwaro2=150.0)
 192 !
 193 !!rs molecular weight
 194 !      REAL mwalk1
 195 !      PARAMETER (mwalk1=140.0)
 196 !
 197 !!rs molecular weight
 198 !      REAL mwalk2
 199 !      PARAMETER (mwalk2=140.0)
 200 !
 201 !!rs molecular weight
 202 !      REAL mwole1
 203 !      PARAMETER (mwole1=140.0)
 204 !
 205 !!rs molecular weight
 206 !      REAL mwapi1
 207 !      PARAMETER (mwapi1=200.0)
 208 !
 209 !!rs molecular weight
 210 !      REAL mwapi2
 211 !      PARAMETER (mwapi2=200.0)
 212 !
 213 !!rs molecular weight
 214 !      REAL mwlim1
 215 !      PARAMETER (mwlim1=200.0)
 216 !
 217 !!rs molecular weight
 218 !      REAL mwlim2
 219 !      PARAMETER (mwlim2=200.0)
 220
 221 INTEGER :: i,j,k,l,debug_level
 222 ! convert advected aerosol variables to ug/m3 from mixing ratio
 223 ! they will be converted back at the end of this driver
 224 !
 225    do l=p_so4aj,num_chem
 226       do j=jts,jte
 227          do k=kts,kte
 228             do i=its,ite
 229                chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j))
 230             enddo
 231          enddo
 232       enddo
 233    enddo
 234
 235    ! Use RH from phys/???
 236       do 100 j=jts,jte
 237          do 100 i=its,ite
 238             debug_level=0
 239 !             do k=kts,kte
 240 !                t(k) = t_phy(i,k,j)
 241 !                p(k) = .001*p_phy(i,k,j)
 242 !                rh0(k) = MIN( 95.,100. * moist(i,k,j,p_qv) /        &
 243 !                         (3.80*exp(17.27*(t_phy(i,k,j)-273.)/      &
 244 !                         (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))   )
 245 !                rh0(k)=max(.1,0.01*rh0(k))
 246 !             enddo
 247
 248              do k=kts,kte
 249
 250              ! added here
 251                   t(k) = t_phy(i,k,j)
 252                   p(k) = .001*p_phy(i,k,j)
 253                   rh0(k) = rh(i,k,j)
 254
 255 !               IF ( rh0(k)<0.1 .OR. rh0(k)>0.95 ) THEN
 256 !                  CALL wrf_error_fatal ( 'rh0 is out of the permissible range' )
 257 !               ENDIF
 258
 259                cblk=0.
 260
 261 !               do l=1,ldrog
 262 !                  drog_in(l)=0.
 263 !               enddo
 264
 265 !               do l=1,lspcv
 266 !                  condvap_in(l)=0.
 267 !               enddo
 268
 269                convfac = p(k)/rgas/t(k)*1000.
 270                so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
 271                soilrat_in = 0.
 272                nitrate_in = max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
 273                nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
 274 !liqy
 275 !uncomment hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
 276                hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
 277 !comment hcl_in = 0.
 278 !               hcl_in = 0.
 279               cblk(1,vn2o5) = max(epsilc,chem(i,k,j,p_n2o5)*convfac*mwn2o5)
 280               cblk(1,vclno2) =max(epsilc,chem(i,k,j,p_clno2)*convfac*mwclno2)
 281 !liqy-20140905
 282                vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
 283
 284 ! * organic aerosol precursors DeltaROG and SOA production
 285                drog_in(PALK4) = VDROG3(i,k,j,PALK4)
 286                drog_in(PALK5) = VDROG3(i,k,j,PALK5)
 287                drog_in(POLE1) = VDROG3(i,k,j,POLE1)
 288                drog_in(POLE2) = VDROG3(i,k,j,POLE2)
 289                drog_in(PARO1) = VDROG3(i,k,j,PARO1)
 290                drog_in(PARO2) = VDROG3(i,k,j,PARO2)
 291                drog_in(PISOP) = VDROG3(i,k,j,PISOP)
 292                drog_in(PTERP) = VDROG3(i,k,j,PTERP)
 293                drog_in(PSESQ) = VDROG3(i,k,j,PSESQ)
 294                drog_in(PBRCH) = VDROG3(i,k,j,PBRCH)
 295
 296         cblk(1,VASOA1J) =   chem(i,k,j,p_asoa1j)
 297         cblk(1,VASOA1I) =   chem(i,k,j,p_asoa1i)
 298         cblk(1,VASOA2J) =   chem(i,k,j,p_asoa2j)
 299         cblk(1,VASOA2I) =   chem(i,k,j,p_asoa2i)
 300         cblk(1,VASOA3J) =   chem(i,k,j,p_asoa3j)
 301         cblk(1,VASOA3I) =   chem(i,k,j,p_asoa3i)
 302         cblk(1,VASOA4J) =   chem(i,k,j,p_asoa4j)
 303         cblk(1,VASOA4I) =   chem(i,k,j,p_asoa4i)
 304
 305         cblk(1,VBSOA1J) =   chem(i,k,j,p_bsoa1j)
 306         cblk(1,VBSOA1I) =   chem(i,k,j,p_bsoa1i)
 307         cblk(1,VBSOA2J) =   chem(i,k,j,p_bsoa2j)
 308         cblk(1,VBSOA2I) =   chem(i,k,j,p_bsoa2i)
 309         cblk(1,VBSOA3J) =   chem(i,k,j,p_bsoa3j)
 310         cblk(1,VBSOA3I) =   chem(i,k,j,p_bsoa3i)
 311         cblk(1,VBSOA4J) =   chem(i,k,j,p_bsoa4j)
 312         cblk(1,VBSOA4I) =   chem(i,k,j,p_bsoa4i)
 313
 314 ! Comment out the old code
 315 !        condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
 316 !        condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
 317 !        condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
 318 !        condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
 319 !        cblk(1,VORGARO1J) =   chem(i,k,j,p_orgaro1j)
 320 !        cblk(1,VORGARO1I) =   chem(i,k,j,p_orgaro1i)
 321 !        cblk(1,VORGARO2J) =   chem(i,k,j,p_orgaro2j)
 322 !        cblk(1,VORGARO2I) =   chem(i,k,j,p_orgaro2i)
 323 !        cblk(1,VORGALK1J) =   chem(i,k,j,p_orgalk1j)
 324 !        cblk(1,VORGALK1I) =   chem(i,k,j,p_orgalk1i)
 325 !        cblk(1,VORGOLE1J) =   chem(i,k,j,p_orgole1j)
 326 !        cblk(1,VORGOLE1I) =   chem(i,k,j,p_orgole1i)
 327 !        cblk(1,VORGBA1J ) =   chem(i,k,j,p_orgba1j)
 328 !        cblk(1,VORGBA1I ) =   chem(i,k,j,p_orgba1i)
 329 !        cblk(1,VORGBA2J ) =   chem(i,k,j,p_orgba2j)
 330 !        cblk(1,VORGBA2I ) =   chem(i,k,j,p_orgba2i)
 331 !        cblk(1,VORGBA3J ) =   chem(i,k,j,p_orgba3j)
 332 !        cblk(1,VORGBA3I ) =   chem(i,k,j,p_orgba3i)
 333 !        cblk(1,VORGBA4J ) =   chem(i,k,j,p_orgba4j)
 334 !        cblk(1,VORGBA4I ) =   chem(i,k,j,p_orgba4i)
 335
 336         cblk(1,VORGPAJ  ) =   chem(i,k,j,p_orgpaj)
 337         cblk(1,VORGPAI  ) =   chem(i,k,j,p_orgpai)
 338         cblk(1,VECJ     ) =   chem(i,k,j,p_ecj)
 339         cblk(1,VECI     ) =   chem(i,k,j,p_eci)
 340         cblk(1,VP25AJ   ) =   chem(i,k,j,p_p25j)
 341         cblk(1,VP25AI   ) =   chem(i,k,j,p_p25i)
 342         cblk(1,VANTHA   ) =   chem(i,k,j,p_antha)
 343         cblk(1,VSEAS    ) =   chem(i,k,j,p_seas)
 344         cblk(1,VSOILA   ) =   chem(i,k,j,p_soila)
 345         cblk(1,VH2OAJ   ) =   max(epsilc,h2oaj(i,k,j))
 346         cblk(1,VH2OAI   ) =   max(epsilc,h2oai(i,k,j))
 347         cblk(1,VNU3     ) =   max(epsilc,nu3(i,k,j))
 348         cblk(1,VAC3     ) =   max(epsilc,ac3(i,k,j))
 349
 350         cblk(1,VCOR3    ) =   max(epsilc,cor3(i,k,j))
 351 !liqy
 352         cblk(1,vgamn2o5) = max(epsilc,gamn2o5(i,k,j))
 353         cblk(1,vcn2o5)   = max(epsilc,cn2o5(i,k,j))
 354         cblk(1,vkn2o5)   = max(epsilc,kn2o5(i,k,j))
 355         cblk(1,vyclno2)  = max(epsilc,yclno2(i,k,j))
 356         cblk(1,vsnu)     = max(epsilc,snu(i,k,j))
 357         cblk(1,vsac)     = max(epsilc,sac(i,k,j))
 358 !liqy-20150319
 359         cblk(1,vcvasoa1)  =   chem(i,k,j,p_cvasoa1)
 360         cblk(1,vcvasoa2)  =   chem(i,k,j,p_cvasoa2)
 361         cblk(1,vcvasoa3)  =   chem(i,k,j,p_cvasoa3)
 362         cblk(1,vcvasoa4)  =   chem(i,k,j,p_cvasoa4)
 363
 364         cblk(1,vcvbsoa1)  =   chem(i,k,j,p_cvbsoa1)
 365         cblk(1,vcvbsoa2)  =   chem(i,k,j,p_cvbsoa2)
 366         cblk(1,vcvbsoa3)  =   chem(i,k,j,p_cvbsoa3)
 367         cblk(1,vcvbsoa4)  =   chem(i,k,j,p_cvbsoa4)
 368 !
 369 ! Set emissions to zero
 370          epmcoarse(1)     = 0.
 371          epm25i(1)        = 0.
 372          epm25j(1)        = 0.
 373          eeci_in          = 0.
 374          eecj_in          = 0.
 375          eorgi_in         = 0.
 376          eorgj_in         = 0.
 377          cblk(1,VSO4AJ  ) = chem(i,k,j,p_so4aj)
 378          cblk(1,VSO4AI  ) = chem(i,k,j,p_so4ai)
 379          cblk(1,VNO3AJ  ) = chem(i,k,j,p_no3aj)
 380          cblk(1,VNO3AI  ) = chem(i,k,j,p_no3ai)
 381          cblk(1,VNAAJ   ) = chem(i,k,j,p_naaj)
 382          cblk(1,VNAAI   ) = chem(i,k,j,p_naai)
 383 !liqy
 384 !uncomment cblk(1,VCLAJ   ) = chem(i,k,j,p_claj)
 385 !uncomment cblk(1,VCLAI   ) = chem(i,k,j,p_clai)
 386          cblk(1,VCLAJ   ) = chem(i,k,j,p_claj)
 387          cblk(1,VCLAI   ) = chem(i,k,j,p_clai)
 388 !comment cblk(1,VCLAJ   ) = 0.
 389 !comment cblk(1,VCLAI   ) = 0.
 390 !         cblk(1,VCLAJ   ) = 0.
 391 !         cblk(1,VCLAI   ) = 0.
 392                 cblk(1,vcaaj) = chem(i,k,j,p_caaj)
 393                 cblk(1,vcaai) = chem(i,k,j,p_caai)
 394                 cblk(1,vkaj) = chem(i,k,j,p_kaj)
 395                 cblk(1,vkai) = chem(i,k,j,p_kai)
 396                 cblk(1,vmgaj) = chem(i,k,j,p_mgaj)
 397                 cblk(1,vmgai) = chem(i,k,j,p_mgai)
 398 !liqy-20140623
 399 !
 400 !rs. nitrate, nh3, sulf
 401       cblk(1,vsulf)  =   vsulf_in
 402       cblk(1,vhno3)  =   nitrate_in
 403       cblk(1,vnh3)   =   nh3_in
 404       cblk(1,vhcl)   =   hcl_in
 405       cblk(1,VNH4AJ) =   chem(i,k,j,p_nh4aj)
 406       cblk(1,VNH4AI) =   chem(i,k,j,p_nh4ai)
 407       cblk(1,VNU0  ) =   max(1.e7,chem(i,k,j,p_nu0))
 408       cblk(1,VAC0  ) =   max(1.e7,chem(i,k,j,p_ac0))
 409       cblk(1,VCORN ) =   chem(i,k,j,p_corn)
 410 !liqy
 411        cblk(1,valt_in) = alt(i,k,j)
 412 !liqy -20150319
 413 ! the following operation updates cblk, which includes the vapors and SOA species
 414 ! condvap_in is removed
 415       CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh0(k),nitrate_in,nh3_in, &
 416         vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv,nacv,eeci_in,eecj_in, &
 417         eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k,brrto, &
 418         do_isorropia )
 419
 420 ! calculation of brch_ratio
 421         brch_ratio(i,k,j)= brrto
 422         !------------------------------------------------------------------------
 423
 424         chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
 425         chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
 426         chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
 427         chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
 428         chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
 429         chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
 430         chem(i,k,j,p_naaj)  = cblk(1,VNAAJ   )
 431         chem(i,k,j,p_naai)  = cblk(1,VNAAI   )
 432 !liqy
 433 !uncomment chem(i,k,j,p_claj) = cblk(1,VCLAJ   )
 434 !uncomment chem(i,k,j,p_clai) = cblk(1,VCLAI   )
 435         chem(i,k,j,p_claj) = cblk(1,VCLAJ   )
 436         chem(i,k,j,p_clai) = cblk(1,VCLAI   )
 437
 438                 chem(i,k,j,p_caaj) = cblk(1,vcaaj)
 439                 chem(i,k,j,p_caai) = cblk(1,vcaai)
 440                 chem(i,k,j,p_kaj) = cblk(1,vkaj)
 441                 chem(i,k,j,p_kai) = cblk(1,vkai)
 442                 chem(i,k,j,p_mgaj) = cblk(1,vmgaj)
 443                 chem(i,k,j,p_mgai) = cblk(1,vmgai)
 444 !liqy-20140616
 445
 446         chem(i,k,j,p_asoa1j)  =   cblk(1,VASOA1J)
 447         chem(i,k,j,p_asoa1i)  =   cblk(1,VASOA1I)
 448         chem(i,k,j,p_asoa2j)  =   cblk(1,VASOA2J)
 449         chem(i,k,j,p_asoa2i)  =   cblk(1,VASOA2I)
 450         chem(i,k,j,p_asoa3j)  =   cblk(1,VASOA3J)
 451         chem(i,k,j,p_asoa3i)  =   cblk(1,VASOA3I)
 452         chem(i,k,j,p_asoa4j)  =   cblk(1,VASOA4J)
 453         chem(i,k,j,p_asoa4i)  =   cblk(1,VASOA4I)
 454
 455         chem(i,k,j,p_bsoa1j)  =   cblk(1,VBSOA1J)
 456         chem(i,k,j,p_bsoa1i)  =   cblk(1,VBSOA1I)
 457         chem(i,k,j,p_bsoa2j)  =   cblk(1,VBSOA2J)
 458         chem(i,k,j,p_bsoa2i)  =   cblk(1,VBSOA2I)
 459         chem(i,k,j,p_bsoa3j)  =   cblk(1,VBSOA3J)
 460         chem(i,k,j,p_bsoa3i)  =   cblk(1,VBSOA3I)
 461         chem(i,k,j,p_bsoa4j)  =   cblk(1,VBSOA4J)
 462         chem(i,k,j,p_bsoa4i)  =   cblk(1,VBSOA4I)
 463
 464 !      chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
 465 !      chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
 466 !      chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
 467 !      chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
 468 !      chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
 469 !      chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
 470 !      chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
 471 !      chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
 472 !      chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
 473 !      chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
 474 !      chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
 475 !      chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
 476 !      chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
 477 !      chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
 478 !      chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
 479 !      chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
 480
 481       chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ  )
 482       chem(i,k,j,p_orgpai) = cblk(1,VORGPAI  )
 483       chem(i,k,j,p_ecj)    = cblk(1,VECJ     )
 484       chem(i,k,j,p_eci)    = cblk(1,VECI     )
 485       chem(i,k,j,p_p25j)   = cblk(1,VP25AJ   )
 486       chem(i,k,j,p_p25i)   = cblk(1,VP25AI   )
 487       chem(i,k,j,p_antha)  = cblk(1,VANTHA   )
 488       chem(i,k,j,p_seas)   = cblk(1,VSEAS    )
 489       chem(i,k,j,p_soila)  = cblk(1,VSOILA   )
 490       chem(i,k,j,p_nu0)    = max(1.e7,cblk(1,VNU0     ))
 491       chem(i,k,j,p_ac0)    = max(1.e7,cblk(1,VAC0     ))
 492
 493       chem(i,k,j,p_corn) = cblk(1,VCORN    )
 494       h2oaj(i,k,j) = cblk(1,VH2OAJ   )
 495       h2oai(i,k,j) = cblk(1,VH2OAI   )
 496       nu3(i,k,j) = cblk(1,VNU3     )
 497       ac3(i,k,j) = cblk(1,VAC3     )
 498       cor3(i,k,j) = cblk(1,VCOR3    )
 499 !liqy
 500        gamn2o5(i,k,j)= cblk(1,vgamn2o5)
 501        cn2o5(i,k,j)  = cblk(1,vcn2o5)
 502        kn2o5(i,k,j)  = cblk(1,vkn2o5)
 503        yclno2(i,k,j) = cblk(1,vyclno2)
 504        snu(i,k,j)    = cblk(1,vsnu)
 505        sac(i,k,j)    = cblk(1,vsac)
 506 !liqy-20150319
 507
 508     chem(i,k,j,p_cvasoa1)= cblk(1,VCVASOA1 )
 509     chem(i,k,j,p_cvasoa2)= cblk(1,VCVASOA2 )
 510     chem(i,k,j,p_cvasoa3)= cblk(1,VCVASOA3 )
 511     chem(i,k,j,p_cvasoa4)= cblk(1,VCVASOA4 )
 512
 513     chem(i,k,j,p_cvbsoa1)= cblk(1,VCVBSOA1 )
 514     chem(i,k,j,p_cvbsoa2)= cblk(1,VCVBSOA2 )
 515     chem(i,k,j,p_cvbsoa3)= cblk(1,VCVBSOA3 )
 516     chem(i,k,j,p_cvbsoa4)= cblk(1,VCVBSOA4 )
 517
 518 !---------------------------------------------------------------------------
 519
 520 !  cvbsoa1(i,k,j) = 0.
 521 !  cvbsoa2(i,k,j) = 0.
 522 !  cvbsoa3(i,k,j) = 0.
 523 !  cvbsoa4(i,k,j) = 0.
 524
 525 !      cvaro1(i,k,j) = cblk(1,VCVARO1  )
 526 !      cvaro2(i,k,j) = cblk(1,VCVARO2  )
 527 !      cvalk1(i,k,j) = cblk(1,VCVALK1  )
 528 !      cvole1(i,k,j) = cblk(1,VCVOLE1  )
 529 !      cvapi1(i,k,j) = 0.
 530 !      cvapi2(i,k,j) = 0.
 531 !      cvlim1(i,k,j) = 0.
 532 !      cvlim2(i,k,j) = 0.
 533
 534       chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
 535       chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
 536       chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
 537
 538 !liqy
 539                 chem(i,k,j,p_hcl) = max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL)
 540                 chem(i,k,j,p_n2o5) = max(epsilc,cblk(1,vn2o5)/CONVFAC/MWN2O5)
 541                 chem(i,k,j,p_clno2) = max(epsilc,cblk(1,vclno2)/CONVFAC/MWCLNO2)
 542 !liqy-20140905
 543       enddo          ! k-loop
 544 100  continue ! i,j-loop ends
 545
 546 ! convert aerosol variables back to mixing ratio from ug/m3
 547   do l=p_so4aj,num_chem
 548      do j=jts,jte
 549         do k=kts,kte
 550            do i=its,ite
 551               chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j))
 552            enddo
 553         enddo
 554      enddo
 555   enddo
 556
 557 END SUBROUTINE soa_vbs_driver
 558 ! ///////////////////////////////////////////////////
 559
 560 SUBROUTINE sum_pm_soa_vbs (                                         &
 561      alt, chem, h2oaj, h2oai,                                      &
 562      pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10,dust_opt,          &
 563      ids,ide, jds,jde, kds,kde,                                    &
 564      ims,ime, jms,jme, kms,kme,                                    &
 565      its,ite, jts,jte, kts,kte                                     )
 566
 567    INTEGER, INTENT(IN   ) ::     dust_opt,                        &
 568                                  ids,ide, jds,jde, kds,kde,       &
 569                                  ims,ime, jms,jme, kms,kme,       &
 570                                  its,ite, jts,jte, kts,kte
 571
 572    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
 573          INTENT(IN ) :: chem
 574
 575    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 576          INTENT(IN ) :: alt,h2oaj,h2oai
 577
 578    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 579          INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
 580
 581    INTEGER :: i,ii,j,jj,k,n
 582 !
 583 ! sum up pm2_5 and pm10 output
 584 !
 585       pm2_5_dry(its:ite, kts:kte, jts:jte)    = 0.
 586       pm2_5_water(its:ite, kts:kte, jts:jte)  = 0.
 587       pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0.
 588       do j=jts,jte
 589          jj=min(jde-1,j)
 590       do k=kts,kte
 591       do i=its,ite
 592          ii=min(ide-1,i)
 593          do n=p_so4aj,p_p25i
 594             pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
 595          enddo
 596
 597 !!! TUCCELLA
 598          if( p_p25cwi .gt. p_p25i) then
 599          do n=p_so4cwj,p_p25cwi
 600             pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
 601          enddo
 602          endif
 603
 604          pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) &
 605                                + chem(ii,k,jj,p_eci)
 606          pm2_5_water(i,k,j) =  pm2_5_water(i,k,j)+h2oaj(i,k,j)       &
 607                                + h2oai(i,k,j)
 608
 609          !Convert the units from mixing ratio to concentration (ug m^-3)
 610          pm2_5_dry(i,k,j)    = pm2_5_dry(i,k,j) / alt(ii,k,jj)
 611          pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj)
 612          pm2_5_water(i,k,j)  = pm2_5_water(i,k,j) / alt(ii,k,jj)
 613       enddo
 614       enddo
 615       enddo
 616       do j=jts,jte
 617          jj=min(jde-1,j)
 618          do k=kts,kte
 619             do i=its,ite
 620                ii=min(ide-1,i)
 621                pm10(i,k,j) = pm2_5_dry(i,k,j)                       &
 622                            + ( chem(ii,k,jj,p_antha)               &
 623                            + chem(ii,k,jj,p_soila)                 &
 624                            + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj)
 625 !!!TUCCELLA
 626                if( p_p25cwi .gt. p_p25i) then
 627                     pm10(i,k,j) = pm10(i,k,j)                       &
 628                            + ( chem(ii,k,jj,p_anthcw)               &
 629                            + chem(ii,k,jj,p_soilcw)                 &
 630                            + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj)
 631                endif
 632             enddo
 633          enddo
 634       enddo
 635     END SUBROUTINE sum_pm_soa_vbs
 636 ! ///////////////////////////////////////////////////
 637
 638 SUBROUTINE     soa_vbs_depdriver (id,config_flags,ktau,dtstep,                        &
 639                ust,t_phy,moist,p8w,t8w,rmol,znt,pbl,                    &
 640                alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w,                    &
 641                h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,               &
 642
 643 ! the vapors are part of chem array
 644 !               cvasoa1,cvasoa2, &
 645 !               cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,               &
 646
 647                aer_res,vgsa,                                            &
 648                numaer,                                                  &
 649                ids,ide, jds,jde, kds,kde,                               &
 650                ims,ime, jms,jme, kms,kme,                               &
 651                its,ite, jts,jte, kts,kte                                )
 652
 653    USE module_configure,only:  grid_config_rec_type
 654    TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags
 655
 656    INTEGER, INTENT(IN   )    ::       numaer,                    &
 657                                       ids,ide, jds,jde, kds,kde, &
 658                                       ims,ime, jms,jme, kms,kme, &
 659                                       its,ite, jts,jte, kts,kte, &
 660                                       id,ktau
 661
 662    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),        &
 663          INTENT(IN ) ::                                   moist
 664    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),         &
 665          INTENT(INOUT ) ::                                   chem
 666 !
 667 ! following are aerosol arrays that are not advected
 668 !
 669    REAL, DIMENSION( its:ite, jts:jte, numaer ),                       &
 670          INTENT(INOUT ) ::                                             &
 671          vgsa
 672    REAL, DIMENSION( its:ite, jts:jte ),                       &
 673          INTENT(INOUT ) ::                                             &
 674          aer_res
 675
 676    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 677          INTENT(INOUT ) ::                                             &
 678            h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
 679
 680 ! no vapors
 681 !cvaro1,cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
 682
 683    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
 684           INTENT(IN   ) ::                            t_phy,    &
 685                                                       alt,      &
 686                                                       p_phy,    &
 687                                                       dz8w,     &
 688                                                         rh,     &
 689                                                          z,     &
 690                                               t8w,p8w,z_at_w ,  &
 691                                                     rho_phy
 692    REAL,  DIMENSION( ims:ime ,  jms:jme )                  ,    &
 693           INTENT(IN   ) ::                     ust,rmol, pbl, znt
 694    REAL,  INTENT(IN   ) ::                                 dtstep
 695
 696       REAL, PARAMETER   ::   rgas=8.314510
 697       REAL convfac,convfac2
 698 !...BLKSIZE set to one in column model ciarev02
 699
 700       INTEGER, PARAMETER   :: blksize=1
 701
 702 !...number of aerosol species
 703 !  number of species (gas + aerosol)
 704       INTEGER nspcsda
 705       PARAMETER (nspcsda=l1ae) !bs
 706 ! (internal aerosol dynamics)
 707 !bs # of anth. cond. vapors in SOA_VBS
 708       INTEGER nacv
 709       PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
 710 !bs total # of cond. vapors in SOA_VBS
 711       INTEGER, PARAMETER :: ncv=lspcv   ! number of bins=8
 712 !bs total # of cond. vapors in CTM
 713       REAL cblk(blksize,nspcsda) ! main array of variables
 714                                    ! particles [ug/m^3/s]
 715       REAL soilrat_in
 716                     ! emission rate of soil derived coars
 717                     ! input HNO3 to CBLK [ug/m^3]
 718       REAL nitrate_in
 719                     ! input NH3 to CBLK  [ug/m^3]
 720       REAL nh3_in
 721                     ! input SO4 vapor    [ug/m^3]
 722       REAL vsulf_in
 723
 724       REAL so4rat_in
 725                     ! input SO4 formation[ug/m^3/sec]
 726                     ! pressure in cb
 727       REAL pres
 728                     ! temperature in K
 729       REAL temp
 730                     !bs
 731       REAL relhum
 732                     ! rel. humidity (0,1)
 733       REAL ::  p(kts:kte),t(kts:kte),rh0(kts:kte)
 734
 735 !...molecular weights                   ciarev02
 736
 737 ! molecular weight for SO4
 738       REAL mwso4
 739       PARAMETER (mwso4=96.0576)
 740
 741 ! molecular weight for HNO3
 742       REAL mwhno3
 743       PARAMETER (mwhno3=63.01287)
 744
 745 ! molecular weight for NH3
 746       REAL mwnh3
 747       PARAMETER (mwnh3=17.03061)
 748
 749 !bs molecular weight for Organic Spec
 750 !     REAL mworg
 751 !     PARAMETER (mworg=175.0)
 752
 753 !bs molecular weight for Elemental Ca
 754       REAL mwec
 755       PARAMETER (mwec=12.0)
 756
 757 ! they aren't used
 758 !!rs molecular weight
 759 !      REAL mwaro1
 760 !      PARAMETER (mwaro1=150.0)
 761 !
 762 !!rs molecular weight
 763 !      REAL mwaro2
 764 !      PARAMETER (mwaro2=150.0)
 765 !
 766 !!rs molecular weight
 767 !      REAL mwalk1
 768 !      PARAMETER (mwalk1=140.0)
 769 !
 770 !!rs molecular weight
 771 !      REAL mwalk2
 772 !      PARAMETER (mwalk2=140.0)
 773 !
 774 !!rs molecular weight
 775 !!rs molecular weight
 776 !      REAL mwole1
 777 !      PARAMETER (mwole1=140.0)
 778 !
 779 !!rs molecular weight
 780 !      REAL mwapi1
 781 !      PARAMETER (mwapi1=200.0)
 782 !
 783 !!rs molecular weight
 784 !      REAL mwapi2
 785 !      PARAMETER (mwapi2=200.0)
 786 !
 787 !!rs molecular weight
 788 !      REAL mwlim1
 789 !      PARAMETER (mwlim1=200.0)
 790 !
 791 !      REAL mwlim2
 792 !      PARAMETER (mwlim2=200.0)
 793
 794       INTEGER NUMCELLS  ! actual number of cells in arrays ( default is 1 in box model)
 795 !ia                       kept to 1 in current version of column model
 796       PARAMETER( NUMCELLS = 1)
 797
 798       REAL RA(BLKSIZE )             ! aerodynamic resistance [ s m**-1 ]
 799       REAL USTAR( BLKSIZE )         ! surface friction velocity [ m s**-1 ]
 800       REAL WSTAR( BLKSIZE )         ! convective velocity scale [ m s**-1 ]
 801       REAL PBLH( BLKSIZE )          ! PBL height (m)
 802       REAL ZNTT( BLKSIZE )          ! Surface roughness length (m)
 803       REAL RMOLM( BLKSIZE )         ! Inverse of Monin-Obukhov length (1/m)
 804
 805       REAL BLKPRS(BLKSIZE)         ! pressure in cb
 806       REAL BLKTA(BLKSIZE)          ! temperature in K
 807       REAL BLKDENS(BLKSIZE)        ! Air density in kg/m3
 808 !
 809 ! *** OUTPUT:
 810 !
 811 ! *** atmospheric properties
 812
 813       REAL XLM( BLKSIZE )           ! atmospheric mean free path [ m ]
 814       REAL AMU( BLKSIZE )           ! atmospheric dynamic viscosity [ kg/m s ]
 815
 816 ! *** followng is for future version
 817       REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
 818       REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
 819
 820 ! *** modal diameters: [ m ]
 821       REAL DGNUC( BLKSIZE )         ! nuclei mode geometric mean diameter  [ m ]
 822       REAL DGACC( BLKSIZE )         ! accumulation geometric mean diameter [ m ]
 823       REAL DGCOR( BLKSIZE )         ! coarse mode geometric mean diameter  [ m ]
 824
 825 ! *** aerosol properties:
 826 ! *** Modal mass concentrations [ ug m**3 ]
 827       REAL PMASSN( BLKSIZE )        ! mass concentration in Aitken mode
 828       REAL PMASSA( BLKSIZE )        ! mass concentration in accumulation mode
 829       REAL PMASSC( BLKSIZE )        ! mass concentration in coarse mode
 830
 831 ! *** average modal particle densities  [ kg/m**3 ]
 832       REAL PDENSN( BLKSIZE )        ! average particle density in nuclei mode
 833       REAL PDENSA( BLKSIZE )        ! average particle density in accumulation mode
 834       REAL PDENSC( BLKSIZE )        ! average particle density in coarse mode
 835
 836 ! *** average modal Knudsen numbers
 837       REAL KNNUC ( BLKSIZE )        ! nuclei mode  Knudsen number
 838       REAL KNACC ( BLKSIZE )        ! accumulation Knudsen number
 839       REAL KNCOR ( BLKSIZE )        ! coarse mode  Knudsen number
 840 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 841
 842 INTEGER :: i,j,k,l
 843 !
 844 !     print *,'in sorgdepdriver ',its,ite,jts,jte
 845       do l=1,numaer
 846        do i=its,ite
 847         do j=jts,jte
 848            vgsa(i,j,l)=0.
 849         enddo
 850        enddo
 851       enddo
 852       vdep=0.
 853
 854       do 100 j=jts,jte
 855          do 100 i=its,ite
 856             cblk=epsilc
 857             do k=kts,kte
 858                t(k) = t_phy(i,k,j)
 859                p(k) = .001*p_phy(i,k,j)
 860                rh0(k) = rh(i,k,j)
 861             end do
 862
 863             k=kts
 864                convfac = p(k)/rgas/t(k)*1000.
 865                nitrate_in = chem(i,k,j,p_hno3)*convfac*mwhno3
 866                nh3_in =     chem(i,k,j,p_nh3)*convfac*mwnh3
 867                vsulf_in =   chem(i,k,j,p_sulf)*convfac*mwso4
 868
 869 !rs. nitrate, nh3, sulf
 870       BLKPRS(BLKSIZE)   = 1.e3*P(K)                ! pressure in Pa
 871       BLKTA(BLKSIZE)   = T(K)         ! temperature in K
 872       USTAR(BLKSIZE) = max(1.e-1,UST(i,j))
 873       WSTAR(BLKSIZE) = 0.
 874       pblh(blksize) = pbl(i,j)
 875       zntt(blksize) = znt(i,j)
 876       rmolm(blksize)= rmol(i,j)
 877       convfac2=1./alt(i,k,j)    ! density of dry air
 878       BLKDENS(BLKSIZE)=convfac2
 879       cblk(1,vsulf) = max(epsilc,vsulf_in)
 880       cblk(1,vhno3) = max(epsilc,nitrate_in)
 881       cblk(1,vnh3)  = max(epsilc,nh3_in)
 882       cblk(1,VSO4AJ   ) =   max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
 883       cblk(1,VSO4AI   ) =   max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
 884       cblk(1,VNH4AJ   ) =   max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
 885       cblk(1,VNH4AI   ) =   max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
 886       cblk(1,VNO3AJ   ) =   max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
 887       cblk(1,VNO3AI   ) =   max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
 888
 889       if (p_naai >= param_first_scalar) &
 890          cblk(1,VNAAI ) =   max(epsilc,chem(i,k,j,p_naai)*convfac2)
 891       if (p_naaj >= param_first_scalar) &
 892          cblk(1,VNAAJ ) =   max(epsilc,chem(i,k,j,p_naaj)*convfac2)
 893       if (p_clai >= param_first_scalar) &
 894          cblk(1,VCLAI ) =   max(epsilc,chem(i,k,j,p_clai)*convfac2)
 895       if (p_claj >= param_first_scalar) &
 896          cblk(1,VCLAJ ) =   max(epsilc,chem(i,k,j,p_claj)*convfac2)
 897
 898 !liqy
 899       if (p_caai >= param_first_scalar) &
 900          cblk(1,VCAAI ) =   max(epsilc,chem(i,k,j,p_caai)*convfac2)
 901       if (p_caaj >= param_first_scalar) &
 902          cblk(1,VCAAJ ) =   max(epsilc,chem(i,k,j,p_caaj)*convfac2)
 903       if (p_kai >= param_first_scalar) &
 904          cblk(1,VKAI ) =   max(epsilc,chem(i,k,j,p_kai)*convfac2)
 905       if (p_kaj >= param_first_scalar) &
 906          cblk(1,VKAJ ) =   max(epsilc,chem(i,k,j,p_kaj)*convfac2)
 907       if (p_mgai >= param_first_scalar) &
 908          cblk(1,VMGAI ) =   max(epsilc,chem(i,k,j,p_mgai)*convfac2)
 909       if (p_mgaj >= param_first_scalar) &
 910          cblk(1,VMGAJ ) =   max(epsilc,chem(i,k,j,p_mgaj)*convfac2)
 911 !liqy-20140617
 912
 913       cblk(1,VASOA1J) =     max(epsilc,chem(i,k,j,p_asoa1j)*convfac2)  ! ug/kg-air to ug/m3
 914       cblk(1,VASOA1I) =     max(epsilc,chem(i,k,j,p_asoa1i)*convfac2)
 915       cblk(1,VASOA2J) =     max(epsilc,chem(i,k,j,p_asoa2j)*convfac2)
 916       cblk(1,VASOA2I) =     max(epsilc,chem(i,k,j,p_asoa2i)*convfac2)
 917       cblk(1,VASOA3J) =     max(epsilc,chem(i,k,j,p_asoa3j)*convfac2)
 918       cblk(1,VASOA3I) =     max(epsilc,chem(i,k,j,p_asoa3i)*convfac2)
 919       cblk(1,VASOA4J) =     max(epsilc,chem(i,k,j,p_asoa4j)*convfac2)
 920       cblk(1,VASOA4I) =     max(epsilc,chem(i,k,j,p_asoa4i)*convfac2)
 921
 922       cblk(1,VBSOA1J) =     max(epsilc,chem(i,k,j,p_bsoa1j)*convfac2)
 923       cblk(1,VBSOA1I) =     max(epsilc,chem(i,k,j,p_bsoa1i)*convfac2)
 924       cblk(1,VBSOA2J) =     max(epsilc,chem(i,k,j,p_bsoa2j)*convfac2)
 925       cblk(1,VBSOA2I) =     max(epsilc,chem(i,k,j,p_bsoa2i)*convfac2)
 926       cblk(1,VBSOA3J) =     max(epsilc,chem(i,k,j,p_bsoa3j)*convfac2)
 927       cblk(1,VBSOA3I) =     max(epsilc,chem(i,k,j,p_bsoa3i)*convfac2)
 928       cblk(1,VBSOA4J) =     max(epsilc,chem(i,k,j,p_bsoa4j)*convfac2)
 929       cblk(1,VBSOA4I) =     max(epsilc,chem(i,k,j,p_bsoa4i)*convfac2)
 930
 931 !      cblk(1,VORGARO1J) =   max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
 932 !      cblk(1,VORGARO1I) =   max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
 933 !      cblk(1,VORGARO2J) =   max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
 934 !      cblk(1,VORGARO2I) =   max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
 935 !      cblk(1,VORGALK1J) =   max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
 936 !      cblk(1,VORGALK1I) =   max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
 937 !      cblk(1,VORGOLE1J) =   max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
 938 !      cblk(1,VORGOLE1I) =   max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
 939 !      cblk(1,VORGBA1J ) =   max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
 940 !      cblk(1,VORGBA1I ) =   max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
 941 !      cblk(1,VORGBA2J ) =   max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
 942 !      cblk(1,VORGBA2I ) =   max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
 943 !      cblk(1,VORGBA3J ) =   max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
 944 !      cblk(1,VORGBA3I ) =   max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
 945 !      cblk(1,VORGBA4J ) =   max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
 946 !      cblk(1,VORGBA4I ) =   max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
 947
 948       cblk(1,VORGPAJ  ) =   max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
 949       cblk(1,VORGPAI  ) =   max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
 950       cblk(1,VECJ     ) =   max(epsilc,chem(i,k,j,p_ecj)*convfac2)
 951       cblk(1,VECI     ) =   max(epsilc,chem(i,k,j,p_eci)*convfac2)
 952       cblk(1,VP25AJ   ) =   max(epsilc,chem(i,k,j,p_p25j)*convfac2)
 953       cblk(1,VP25AI   ) =   max(epsilc,chem(i,k,j,p_p25i)*convfac2)
 954
 955       cblk(1,VANTHA   ) =   max(epsilc,chem(i,k,j,p_antha)*convfac2)
 956       cblk(1,VSEAS    ) =   max(epsilc,chem(i,k,j,p_seas)*convfac2)
 957       cblk(1,VSOILA   ) =   max(epsilc,chem(i,k,j,p_soila)*convfac2)
 958
 959       cblk(1,VNU0     ) =   max(epsilc,chem(i,k,j,p_nu0)*convfac2)
 960       cblk(1,VAC0     ) =   max(epsilc,chem(i,k,j,p_ac0)*convfac2)
 961
 962       cblk(1,VCORN    ) =   max(epsilc,chem(i,k,j,p_corn)*convfac2)
 963       cblk(1,VH2OAJ   ) =   h2oaj(i,k,j)
 964       cblk(1,VH2OAI   ) =   h2oai(i,k,j)
 965       cblk(1,VNU3     ) =   nu3(i,k,j)
 966       cblk(1,VAC3     ) =   ac3(i,k,j)
 967       cblk(1,VCOR3    ) =   cor3(i,k,j)
 968
 969 ! here cblk is used to call modpar, however modpar doesn't need vapors!
 970 !      cblk(1,vcvasoa1  ) =  cvasoa1(i,k,j)
 971 !      cblk(1,vcvasoa2  ) =  cvasoa2(i,k,j)
 972 !      cblk(1,vcvasoa3  ) =  cvasoa3(i,k,j)
 973 !      cblk(1,vcvasoa4  ) =  cvasoa4(i,k,j)
 974 !      cblk(1,vcvbsoa1) = 0.
 975 !      cblk(1,vcvbsoa2) = 0.
 976 !      cblk(1,vcvbsoa3) = 0.
 977 !      cblk(1,vcvbsoa4) = 0.
 978
 979 !      cblk(1,VCVARO1  ) =   cvaro1(i,k,j)
 980 !      cblk(1,VCVARO2  ) =   cvaro2(i,k,j)
 981 !      cblk(1,VCVALK1  ) =   cvalk1(i,k,j)
 982 !      cblk(1,VCVOLE1  ) =   cvole1(i,k,j)
 983 !      cblk(1,VCVAPI1  ) =   0.
 984 !      cblk(1,VCVAPI2  ) =   0.
 985 !      cblk(1,VCVLIM1  ) =   0.
 986 !      cblk(1,VCVLIM2  ) =   0.
 987
 988 !     cblk(1,VCVAPI1  ) =   cvapi1(i,k,j)
 989 !     cblk(1,VCVAPI2  ) =   cvapi2(i,k,j)
 990 !     cblk(1,VCVLIM1  ) =   cvlim1(i,k,j)
 991 !     cblk(1,VCVLIM2  ) =   cvlim2(i,k,j)
 992 !
 993 !rs.   get size distribution information
 994 !       if(i.eq.126.and.j.eq.99)then
 995 !          print *,'in modpar ',i,j
 996 !          print *,cblk,BLKTA,BLKPRS,USTAR
 997 !          print *,'BLKSIZE, NSPCSDA, NUMCELLS'
 998 !          print *,BLKSIZE, NSPCSDA, NUMCELLS
 999 !          print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
1000 !          print *,XLM, AMU,PDENSN, PDENSA, PDENSC
1001 !          print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
1002 !          print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
1003 !       endif
1004
1005         CALL MODPAR(  BLKSIZE, NSPCSDA, NUMCELLS,     &
1006              CBLK,                                    &
1007              BLKTA, BLKPRS,                           &
1008              PMASSN, PMASSA, PMASSC,                  &
1009              PDENSN, PDENSA, PDENSC,                  &
1010              XLM, AMU,                                &
1011              DGNUC, DGACC, DGCOR,                     &
1012              KNNUC, KNACC,KNCOR    )
1013
1014         if (config_flags%aer_drydep_opt == 11) then
1015         CALL VDVG(  BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
1016              BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR,  AMU,   &
1017              DGNUC, DGACC, DGCOR,                      &
1018              KNNUC, KNACC,KNCOR,                       &
1019              PDENSN, PDENSA, PDENSC,                   &
1020              VSED, VDEP )
1021         else
1022 ! for aerosol dry deposition, no CBLK in VDVG_2
1023         CALL VDVG_2(  BLKSIZE, NSPCSDA, NUMCELLS,k,    &
1024              BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,&
1025              ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,&
1026              KNNUC, KNACC,KNCOR,                       &
1027              PDENSN, PDENSA, PDENSC,                   &
1028              VSED, VDEP )
1029         endif
1030
1031         VGSA(i, j, VSO4AJ )  =  VDEP(1, VDMACC )
1032         VGSA(i, j, VSO4AI )  =  VDEP(1, VDMNUC )
1033         VGSA(i, j, VNH4AJ )  =  VGSA(i, j, VSO4AJ )
1034         VGSA(i, j, VNH4AI )  =  VGSA(i, j, VSO4AI )
1035         VGSA(i, j, VNO3AJ )  =  VGSA(i, j, VSO4AJ )
1036         VGSA(i, j, VNO3AI )  =  VGSA(i, j, VSO4AI )
1037
1038         if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI )  =  VGSA(i, j, VSO4AI )
1039         if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ )  =  VGSA(i, j, VSO4AJ )
1040         if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI )  =  VGSA(i, j, VSO4AI )
1041         if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ )  =  VGSA(i, j, VSO4AJ )
1042 !liqy
1043         if (p_caai >= param_first_scalar) VGSA(i, j, VCAAI )  =  VGSA(i,j,VSO4AI )
1044         if (p_caaj >= param_first_scalar) VGSA(i, j, VCAAJ )  =  VGSA(i,j,VSO4AJ)
1045         if (p_kai >= param_first_scalar) VGSA(i, j, VKAI )  =  VGSA(i, j,VSO4AI)
1046         if (p_kaj >= param_first_scalar) VGSA(i, j, VKAJ )  =  VGSA(i, j,VSO4AJ)
1047         if (p_mgai >= param_first_scalar) VGSA(i, j, VMGAI )  =  VGSA(i,j,VSO4AI )
1048         if (p_mgaj >= param_first_scalar) VGSA(i, j, VMGAJ )  =  VGSA(i,j,VSO4AJ )
1049 !liqy-20140703
1050         VGSA(i, j, VASOA1J ) =  VGSA(i, j, VSO4AJ )
1051         VGSA(i, j, VASOA1I ) =  VGSA(i, j, VSO4AI )
1052         VGSA(i, j, VASOA2J ) =  VGSA(i, j, VSO4AJ )
1053         VGSA(i, j, VASOA2I ) =  VGSA(i, j, VSO4AI )
1054         VGSA(i, j, VASOA3J ) =  VGSA(i, j, VSO4AJ )
1055         VGSA(i, j, VASOA3I ) =  VGSA(i, j, VSO4AI )
1056         VGSA(i, j, VASOA4J ) =  VGSA(i, j, VSO4AJ )
1057         VGSA(i, j, VASOA4I ) =  VGSA(i, j, VSO4AI )
1058
1059         VGSA(i, j, VBSOA1J ) =  VGSA(i, j, VSO4AJ )
1060         VGSA(i, j, VBSOA1I ) =  VGSA(i, j, VSO4AI )
1061         VGSA(i, j, VBSOA2J ) =  VGSA(i, j, VSO4AJ )
1062         VGSA(i, j, VBSOA2I ) =  VGSA(i, j, VSO4AI )
1063         VGSA(i, j, VBSOA3J ) =  VGSA(i, j, VSO4AJ )
1064         VGSA(i, j, VBSOA3I ) =  VGSA(i, j, VSO4AI )
1065         VGSA(i, j, VBSOA4J ) =  VGSA(i, j, VSO4AJ )
1066         VGSA(i, j, VBSOA4I ) =  VGSA(i, j, VSO4AI )
1067         !----------------------------------------------------------------------
1068
1069 !        VGSA(i, j, VORGARO1J)  =  VGSA(i, j, VSO4AJ )
1070 !        VGSA(i, j, VORGARO1I)  =  VGSA(i, j, VSO4AI )
1071 !        VGSA(i, j, VORGARO2J)  =  VGSA(i, j, VSO4AJ )
1072 !        VGSA(i, j, VORGARO2I)  =  VGSA(i, j, VSO4AI )
1073 !        VGSA(i, j, VORGALK1J)  =  VGSA(i, j, VSO4AJ )
1074 !        VGSA(i, j, VORGALK1I)  =  VGSA(i, j, VSO4AI )
1075 !        VGSA(i, j, VORGOLE1J)  =  VGSA(i, j, VSO4AJ )
1076 !        VGSA(i, j, VORGOLE1I)  =  VGSA(i, j, VSO4AI )
1077 !        VGSA(i, j, VORGBA1J )  =  VGSA(i, j, VSO4AJ )
1078 !        VGSA(i, j, VORGBA1I )  =  VGSA(i, j, VSO4AI )
1079 !        VGSA(i, j, VORGBA2J )  =  VGSA(i, j, VSO4AJ )
1080 !        VGSA(i, j, VORGBA2I )  =  VGSA(i, j, VSO4AI )
1081 !        VGSA(i, j, VORGBA3J )  =  VGSA(i, j, VSO4AJ )
1082 !        VGSA(i, j, VORGBA3I )  =  VGSA(i, j, VSO4AI )
1083 !        VGSA(i, j, VORGBA4J )  =  VGSA(i, j, VSO4AJ )
1084 !        VGSA(i, j, VORGBA4I )  =  VGSA(i, j, VSO4AI )
1085
1086         VGSA(i, j, VORGPAJ )  =  VGSA(i, j, VSO4AJ )
1087         VGSA(i, j, VORGPAI )  =  VGSA(i, j, VSO4AI )
1088         VGSA(i, j, VECJ    )  =  VGSA(i, j, VSO4AJ )
1089         VGSA(i, j, VECI    )  =  VGSA(i, j, VSO4AI )
1090         VGSA(i, j, VP25AJ  )  =  VGSA(i, j, VSO4AJ )
1091         VGSA(i, j, VP25AI  )  =  VGSA(i, j, VSO4AI )
1092
1093         VGSA(i, j, VANTHA  )  =  VDEP(1, VDMCOR )
1094         VGSA(i, j, VSEAS   )  =  VGSA(i, j, VANTHA )
1095         VGSA(i, j, VSOILA  )  =  VGSA(i, j, VANTHA )
1096         VGSA(i, j, VNU0    )  =  VDEP(1, VDNNUC )
1097         VGSA(i, j, VAC0    )  =  VDEP(1, VDNACC )
1098         VGSA(i, j, VCORN   )  =  VDEP(1, VDNCOR )
1099 !     enddo         ! k-loop
1100  100  continue      ! i,j-loop
1101
1102 END SUBROUTINE soa_vbs_depdriver
1103 ! ///////////////////////////////////////////////////
1104
1105     SUBROUTINE actcof(cat,an,gama,molnu,phimult)
1106 ! DESCRIPTION:
1107 !  This subroutine computes the activity coefficients of (2NH4+,SO4--),
1108 !  (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
1109 !  multicomponent solution, using Bromley's model and Pitzer's method.
1110
1111 ! REFERENCES:
1112 !   Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
1113 !     in aqueous solutions.  AIChE J. 19, 313-320.
1114
1115 !   Chan, C.K. R.C. Flagen, & J.H.  Seinfeld (1992) Water Activities of
1116 !     NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
1117
1118 !   Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
1119 !     of strong acids over saline solutions - I HNO3,
1120 !     Atmos. Environ. (22): 91-100
1121
1122 !   Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
1123 !     and mean activity and osmotic coefficients of 0-100% nitric acid
1124 !     as a function of temperature,   J. Phys. Chem (94): 5369 - 5380
1125
1126 !   Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
1127 !     general equilibrium model for inorganic multicomponent atmospheric
1128 !     aerosols.  Atmos. Environ. 21(11), 2453-2466.
1129
1130 ! ARGUMENT DESCRIPTION:
1131 !     CAT(1) : conc. of H+    (moles/kg)
1132 !     CAT(2) : conc. of NH4+  (moles/kg)
1133 !     AN(1)  : conc. of SO4-- (moles/kg)
1134 !     AN(2)  : conc. of NO3-  (moles/kg)
1135 !     AN(3)  : conc. of HSO4- (moles/kg)
1136 !     GAMA(2,1)    : mean molal ionic activity coeff for (2NH4+,SO4--)
1137 !     GAMA(2,2)    :                                     (NH4+,NO3-)
1138 !     GAMA(2,3)    :                                     (NH4+. HSO4-)
1139 !     GAMA(1,1)    :                                     (2H+,SO4--)
1140 !     GAMA(1,2)    :                                     (H+,NO3-)
1141 !     GAMA(1,3)    :                                     (H+,HSO4-)
1142 !     MOLNU   : the total number of moles of all ions.
1143 !     PHIMULT : the multicomponent paractical osmotic coefficient.
1144
1145 ! REVISION HISTORY:
1146 !      Who       When        Detailed description of changes
1147 !   ---------   --------  -------------------------------------------
1148 !   S.Roselle   7/26/89   Copied parts of routine BROMLY, and began this
1149 !                         new routine using a method described by Pilini
1150 !                         and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
1151 !   S.Roselle   7/30/97   Modified for use in Models-3
1152 !   F.Binkowski 8/7/97    Modified coefficients BETA0, BETA1, CGAMA
1153
1154 !-----------------------------------------------------------------------
1155 !...........INCLUDES and their descriptions
1156 !      INCLUDE SUBST_XSTAT     ! M3EXIT status codes
1157 !....................................................................
1158
1159 ! Normal, successful completion
1160       INTEGER xstat0
1161       PARAMETER (xstat0=0)
1162 ! File I/O error
1163       INTEGER xstat1
1164       PARAMETER (xstat1=1)
1165 ! Execution error
1166       INTEGER xstat2
1167       PARAMETER (xstat2=2)
1168 ! Special  error
1169       INTEGER xstat3
1170       PARAMETER (xstat3=3)
1171       CHARACTER*120 xmsg
1172
1173 !...........PARAMETERS and their descriptions:
1174 ! number of cations
1175       INTEGER ncat
1176       PARAMETER (ncat=2)
1177
1178 ! number of anions
1179       INTEGER nan
1180       PARAMETER (nan=3)
1181
1182 !...........ARGUMENTS and their descriptions
1183 ! tot # moles of all ions
1184       REAL molnu
1185 ! multicomponent paractical osmo
1186       REAL phimult
1187       REAL cat(ncat) ! cation conc in moles/kg (input
1188       REAL an(nan) ! anion conc in moles/kg (input)
1189       REAL gama(ncat,nan)
1190 !...........SCRATCH LOCAL VARIABLES and their descriptions:
1191 ! mean molal ionic activity coef
1192       CHARACTER*16 & ! driver program name
1193         pname
1194       SAVE pname
1195
1196 ! anion indX
1197       INTEGER ian
1198
1199       INTEGER icat
1200 ! cation indX
1201
1202       REAL fgama
1203 ! ionic strength
1204       REAL i
1205       REAL r
1206       REAL s
1207       REAL ta
1208       REAL tb
1209       REAL tc
1210       REAL texpv
1211       REAL trm
1212 ! 2*ionic strength
1213       REAL twoi
1214 ! 2*sqrt of ionic strength
1215       REAL twosri
1216       REAL zbar
1217       REAL zbar2
1218       REAL zot1
1219 ! square root of ionic strength
1220       REAL sri
1221       REAL f2(ncat)
1222       REAL f1(nan)
1223       REAL zp(ncat) ! absolute value of charges of c
1224       REAL zm(nan) ! absolute value of charges of a
1225       REAL bgama(ncat,nan)
1226       REAL x(ncat,nan)
1227       REAL m(ncat,nan) ! molality of each electrolyte
1228       REAL lgama0(ncat,nan) ! binary activity coefficients
1229       REAL y(nan,ncat)
1230       REAL beta0(ncat,nan) ! binary activity coefficient pa
1231       REAL beta1(ncat,nan) ! binary activity coefficient pa
1232       REAL cgama(ncat,nan) ! binary activity coefficient pa
1233       REAL v1(ncat,nan) ! number of cations in electroly
1234       REAL v2(ncat,nan)
1235 ! number of anions in electrolyt
1236       DATA zp/1.0, 1.0/
1237       DATA zm/2.0, 1.0, 1.0/
1238       DATA xmsg/' '/
1239       DATA pname/'ACTCOF'/
1240
1241 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1242
1243 ! *** (1,1);(1,3)  - Clegg & Brimblecombe (1988)
1244 ! *** (2,3)        - Pilinis & Seinfeld (1987), cgama different
1245 ! *** (1,2)        - Clegg & Brimblecombe (1990)
1246 ! *** (2,1);(2,2)  - Chan, Flagen & Seinfeld (1992)
1247
1248 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1249
1250   DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2    /        ! 2H+SO4
1251   DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 / ! HNO3
1252   DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0       /  ! H+HSO4
1253   DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/,cgama(2,1)/ -1.2683E-3/ ! (NH4)2
1254   DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/,cgama(2,2)/3.51217E-5/ ! NH4NO3
1255   DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 /
1256 ! NH4HSO
1257       DATA v1(1,1), v2(1,1)/2.0, 1.0/  ! 2H+SO4-
1258       DATA v1(2,1), v2(2,1)/2.0, 1.0/  ! (NH4)2SO4
1259       DATA v1(1,2), v2(1,2)/1.0, 1.0/  ! HNO3
1260       DATA v1(2,2), v2(2,2)/1.0, 1.0/  ! NH4NO3
1261       DATA v1(1,3), v2(1,3)/1.0, 1.0/  ! H+HSO4-
1262       DATA v1(2,3), v2(2,3)/1.0, 1.0/
1263 !-----------------------------------------------------------------------
1264 !  begin body of subroutine ACTCOF
1265
1266 !...compute ionic strength
1267 ! NH4HSO4
1268       i = 0.0
1269       DO icat = 1, ncat
1270         i = i + cat(icat)*zp(icat)*zp(icat)
1271       END DO
1272
1273       DO ian = 1, nan
1274         i = i + an(ian)*zm(ian)*zm(ian)
1275       END DO
1276
1277       i = 0.5*i
1278 !...check for problems in the ionic strength
1279       IF (i==0.0) THEN
1280         DO ian = 1, nan
1281           DO icat = 1, ncat
1282             gama(icat,ian) = 0.0
1283           END DO
1284         END DO
1285
1286 !       xmsg = 'Ionic strength is zero...returning zero activities'
1287 !       WRITE (6,*) xmsg
1288         RETURN
1289
1290       ELSE IF (i<0.0) THEN
1291 !        xmsg = 'Ionic strength below zero...negative concentrations'
1292 !        CALL wrf_error_fatal ( xmsg )
1293
1294         xmsg = 'WARNING: Ionic strength below zero (= negative ion concentrations) - setting ion concentrations to zero.'
1295         call wrf_message(xmsg)
1296         DO ian = 1, nan
1297           DO icat = 1, ncat
1298             gama(icat,ian) = 0.0
1299           END DO
1300         END DO
1301         RETURN
1302
1303       END IF
1304
1305 !...compute some essential expressions
1306       sri = sqrt(i)
1307       twosri = 2.0*sri
1308       twoi = 2.0*i
1309       texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1310       r = 1.0 + 0.75*i
1311       s = 1.0 + 1.5*i
1312       zot1 = 0.511*sri/(1.0+sri)
1313
1314 !...Compute binary activity coeffs
1315       fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1316       DO icat = 1, ncat
1317         DO ian = 1, nan
1318
1319           bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1320             )*texpv
1321
1322 !...compute the molality of each electrolyte for given ionic strength
1323
1324           m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1325             (1.0/(v1(icat,ian)+v2(icat,ian)))
1326
1327 !...calculate the binary activity coefficients
1328
1329           lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1330             ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1331             ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1332             v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1333             ian)))/2.302585093
1334
1335         END DO
1336       END DO
1337
1338 !...prepare variables for computing the multicomponent activity coeffs
1339
1340       DO ian = 1, nan
1341         DO icat = 1, ncat
1342           zbar = (zp(icat)+zm(ian))*0.5
1343           zbar2 = zbar*zbar
1344           y(ian,icat) = zbar2*an(ian)/i
1345           x(icat,ian) = zbar2*cat(icat)/i
1346         END DO
1347       END DO
1348
1349       DO ian = 1, nan
1350         f1(ian) = 0.0
1351         DO icat = 1, ncat
1352           f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1353             zot1*zp(icat)*zm(ian)*x(icat,ian)
1354         END DO
1355       END DO
1356
1357       DO icat = 1, ncat
1358         f2(icat) = 0.0
1359         DO ian = 1, nan
1360           f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1361             zot1*zp(icat)*zm(ian)*y(ian,icat)
1362         END DO
1363       END DO
1364
1365 !...now calculate the multicomponent activity coefficients
1366
1367       DO ian = 1, nan
1368         DO icat = 1, ncat
1369
1370           ta = -zot1*zp(icat)*zm(ian)
1371           tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1372           tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1373           trm = ta + tb*tc
1374
1375           IF (trm>30.0) THEN
1376             gama(icat,ian) = 1.0E+30
1377 !           xmsg = 'Multicomponent activity coefficient is extremely large'
1378 !           WRITE (6,*) xmsg
1379           ELSE
1380             gama(icat,ian) = 10.0**trm
1381           END IF
1382
1383         END DO
1384       END DO
1385
1386       RETURN
1387 !ia*********************************************************************
1388     END SUBROUTINE actcof
1389
1390 !ia
1391 !ia     AEROSOL DYNAMICS DRIVER ROUTINE                                 *
1392 !ia     based on MODELS3 formulation by FZB
1393 !ia     Modified by IA in November 97
1394 !ia
1395 !ia     Revision history
1396 !ia     When    WHO     WHAT
1397 !ia     ----    ----    ----
1398 !ia     ????    FZB     BEGIN
1399 !ia     05/97   IA      Adapted for use in CTM2-S
1400 !ia     11/97   IA      Modified for new model version
1401 !ia                     see comments under iarev02
1402 !ia
1403 !ia     Called BY:      RPMMOD3
1404 !ia
1405 !ia     Calls to:       EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1406 !ia                     GETVSED
1407 !ia
1408 !ia*********************************************************************
1409
1410 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1411     blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat, &
1412     orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,epm25i, &
1413     epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1414     dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1415     kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1416     ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid,brrto,do_isorropia)
1417
1418 !USE module_configure, only: grid_config_rec_type
1419 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
1420
1421 !     IMPLICIT NONE
1422 ! dimension of arrays
1423       INTEGER blksize
1424 ! number of species in CBLK
1425       INTEGER nspcsda
1426 ! actual number of cells in arrays
1427       INTEGER numcells
1428 ! number of k-level
1429       INTEGER layer
1430 ! of organic aerosol precursor
1431       INTEGER ldrog_vbs
1432       REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1433
1434       REAL dt
1435 ! *** Meteorological information:
1436
1437 ! synchronization time  [s]
1438       REAL blkta(blksize) ! Air temperature [ K ]
1439       REAL blkprs(blksize) ! Air pressure in [ Pa ]
1440       REAL blkdens(blksize) ! Air density  [ kg/ m**3 ]
1441       REAL blkrh(blksize)
1442 ! *** Chemical production rates: [ ug / m**3 s ]
1443
1444 ! Fractional relative humidity
1445       REAL so4rat(blksize)
1446 ! sulfate gas-phase production rate
1447 ! total # of cond. vapors & SOA species
1448       INTEGER ncv
1449       INTEGER nacv
1450 !bs * organic condensable vapor production rate
1451 ! # of anthrop. cond. vapors & SOA speci
1452       REAL drog(blksize,ldrog_vbs) !bs
1453 ! *** anthropogenic organic aerosol mass production rates from aromatics
1454 ! Delta ROG conc. [ppm]
1455       REAL organt1rat(blksize)
1456
1457 ! *** anthropogenic organic aerosol mass production rates from aromatics
1458       REAL organt2rat(blksize)
1459
1460 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1461       REAL organt3rat(blksize)
1462
1463 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1464       REAL organt4rat(blksize)
1465
1466 ! *** biogenic organic aerosol production rates
1467       REAL orgbio1rat(blksize)
1468
1469 ! *** biogenic organic aerosol production rates
1470       REAL orgbio2rat(blksize)
1471
1472 ! *** biogenic organic aerosol production rates
1473       REAL orgbio3rat(blksize)
1474
1475 ! *** biogenic organic aerosol production rates
1476       REAL orgbio4rat(blksize)
1477
1478 ! *** Primary emissions rates: [ ug / m**3 s ]
1479 ! *** emissions rates for unidentified PM2.5 mass
1480       REAL epm25i(blksize) ! Aitken mode
1481       REAL epm25j(blksize)
1482 ! *** emissions rates for primary organic aerosol
1483 ! Accumululaton mode
1484       REAL eorgi(blksize) ! Aitken mode
1485       REAL eorgj(blksize)
1486 ! *** emissions rates for elemental carbon
1487 ! Accumululaton mode
1488       REAL eeci(blksize) ! Aitken mode
1489       REAL eecj(blksize)
1490 ! *** emissions rates for coarse mode particles
1491 ! Accumululaton mode
1492       REAL esoil(blksize) ! soil derived coarse aerosols
1493       REAL eseas(blksize) ! marine coarse aerosols
1494       REAL epmcoarse(blksize)
1495
1496 ! *** OUTPUT:
1497 ! *** atmospheric properties
1498 ! anthropogenic coarse aerosols
1499       REAL xlm(blksize) ! atmospheric mean free path [ m ]
1500       REAL amu(blksize)
1501 ! *** modal diameters: [ m ]
1502
1503 ! atmospheric dynamic viscosity [ kg
1504       REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1505       REAL dgacc(blksize) ! accumulation geometric mean diamet
1506       REAL dgcor(blksize)
1507
1508 ! *** aerosol properties:
1509 ! *** Modal mass concentrations [ ug m**3 ]
1510 ! coarse mode geometric mean diamete
1511       REAL pmassn(blksize) ! mass concentration in Aitken mode
1512       REAL pmassa(blksize) ! mass concentration in accumulation
1513       REAL pmassc(blksize)
1514 ! *** average modal particle densities  [ kg/m**3 ]
1515
1516 ! mass concentration in coarse mode
1517       REAL pdensn(blksize) ! average particle density in nuclei
1518       REAL pdensa(blksize) ! average particle density in accumu
1519       REAL pdensc(blksize)
1520 ! *** average modal Knudsen numbers
1521
1522 ! average particle density in coarse
1523       REAL knnuc(blksize) ! nuclei mode  Knudsen number
1524       REAL knacc(blksize) ! accumulation Knudsen number
1525       REAL kncor(blksize)
1526 ! ***  modal condensation factors ( see comments in NUCLCOND )
1527
1528 ! coarse mode  Knudsen number
1529       REAL fconcn(blksize)
1530       REAL fconca(blksize)
1531 !bs
1532       REAL fconcn_org(blksize)
1533       REAL fconca_org(blksize)
1534 !bs
1535
1536 ! *** Rates for secondary particle formation:
1537
1538 ! *** production of new mass concentration [ ug/m**3 s ]
1539       REAL dmdt(blksize) !                                 by particle formation
1540
1541 ! *** production of new number concentration [ number/m**3 s ]
1542
1543 ! rate of production of new mass concen
1544       REAL dndt(blksize) !                                 by particle formation
1545
1546 ! *** growth rate for third moment by condensation of precursor
1547 !      vapor on existing particles [ 3rd mom/m**3 s ]
1548
1549 ! rate of producton of new particle num
1550       REAL cgrn3(blksize) !  Aitken mode
1551       REAL cgra3(blksize)
1552 ! *** Rates for coaglulation: [ m**3/s ]
1553
1554 ! *** Unimodal Rates:
1555
1556 !  Accumulation mode
1557       REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1558       REAL ura00(blksize)
1559
1560 ! *** Bimodal Rates:  Aitken mode with accumulation mode ( d( Aitken mod
1561
1562 ! accumulation mode 0th moment self-coagulat
1563       REAL brna01(blksize)
1564 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1565 ! rate for 0th moment
1566       REAL c30(blksize)                                                        ! by intermodal c
1567       REAL brrto
1568 !
1569       LOGICAL do_isorropia
1570 ! *** other processes
1571
1572 ! intermodal 3rd moment transfer r
1573       REAL deltaso4a(blksize) !                                  sulfate aerosol by condensation   [ u
1574
1575 !      INTEGER NN, VV ! loop indICES
1576 ! increment of concentration added to
1577
1578 ! ////////////////////// Begin code ///////////////////////////////////
1579 ! concentration lower limit
1580       CHARACTER*16 pname
1581       PARAMETER (pname=' AEROPROC       ')
1582
1583       INTEGER unit
1584       PARAMETER (unit=20)
1585       integer igrid,jgrid,kgrid,isorop
1586
1587 ! *** get water, ammonium  and nitrate content:
1588 !     for now, don't call if temp is below -40C (humidity
1589 !     for this wrf version is already limited to 10 percent)
1590         if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. do_isorropia )then
1591             CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1592         else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. (.not. do_isorropia) )then
1593            CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1594         endif
1595
1596         CALL n2o5het(blksize,nspcsda,numcells,dt,cblk,blkta,blkrh,dgnuc,dgacc,dgcor,igrid,jgrid,kgrid)
1597 !liqy-20140709
1598
1599 !      isorop=0
1600
1601 ! *** get water, ammonium  and nitrate content:
1602 !     for now, don't call if temp is below -40C (humidity
1603 !     for this wrf version is already limited to 10 percent)
1604
1605 !        if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then
1606 !           CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
1607 !        else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then
1608 !           CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1609 !        endif
1610
1611 ! *** get size distribution information:
1612
1613       CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1614         pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1615         kncor)
1616
1617 ! *** Calculate coagulation rates for fine particles:
1618
1619       CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1620         dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1621
1622 ! *** get condensation and particle formation (nucleation) rates:
1623
1624       CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1625         so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
1626         orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
1627         fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
1628
1629 ! *** advance forward in time DT seconds:
1630       CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,organt1rat, &
1631         organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1632         orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1633         dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1634         dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1635
1636 ! *** get new distribution information:
1637       CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1638         pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1639         kncor)
1640
1641       RETURN
1642     END SUBROUTINE aeroproc
1643 !//////////////////////////////////////////////////////////////////
1644 !//////////////////////////////////////////////////////////////////
1645 !******************************************************************************
1646 !liqy
1647         SUBROUTINE n2o5het(blksize,nspcsda,numcells,dt,cblk,blkta,blkrh,dgnuc,dgacc,dgcor,igrid,jgrid,kgrid)
1648
1649 ! dimension of arrays
1650       INTEGER blksize
1651 ! actual number of cells in arrays
1652       INTEGER numcells
1653 ! nmber of species in CBLK
1654       INTEGER nspcsda
1655       REAL cblk(blksize,nspcsda)
1656           REAL dt
1657 ! *** Meteorological information in blocked arays:
1658       REAL blkta(blksize) ! Air temperature [ K ]
1659       REAL blkrh(blksize) ! Fractional relative humidity
1660       REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1661       REAL dgacc(blksize) ! accumulation geometric mean diamet
1662      REAL dgcor(blksize)
1663 !
1664       Integer igrid,jgrid,kgrid
1665
1666       INTEGER lcell ! loop counter
1667 ! air temperature
1668       REAL temp
1669 !relative humidity.
1670       REAL rh
1671 !aerosol number density
1672       REAL nnu
1673       REAL nac
1674 !aerosol mean diameter
1675       REAL dnu!nuclei
1676       REAL dac !accumulation
1677 !aerosol surface area density
1678       REAL snu
1679       REAL sac
1680 !uptake of n2o5 on aerosols
1681       REAL gamn2o5
1682 !n2o5 molecular speed
1683       REAL cn2o5
1684 !reaction rate constants of N2O5 hydrolysis
1685       REAL kn2o5
1686 !yield of clno2
1687       REAL yclno2
1688
1689
1690       REAL ah2o
1691       REAL acl
1692       REAL ano3
1693       REAL gn2o5
1694
1695       REAL mwh2o
1696       PARAMETER (mwh2o = 18.015)
1697       REAL mwcl
1698       PARAMETER (mwcl = 35.453)
1699       REAL mwno3
1700       PARAMETER (mwno3 = 62.004)
1701       REAL mwn2o5
1702       PARAMETER (mwn2o5 = 108.009)
1703       REAL mwclno2
1704       PARAMETER (mwclno2 = 81.458)
1705       REAL deln2o5
1706       REAL pclno2
1707       REAL pno3
1708
1709       REAL fraci,fracj,fracij
1710       REAL rgasuniv
1711       PARAMETER (rgasuniv = 8.314510)
1712       REAL pirs
1713       PARAMETER (pirs = 3.14)
1714       INTEGER xxx
1715       PARAMETER (xxx = 1)
1716
1717       real vaer
1718 !==================================================
1719         DO lcell = 1, numcells
1720
1721
1722         temp = blkta(lcell)
1723         rh = blkrh(lcell)
1724         nnu = cblk(lcell,vnu0)          !#/m3-dry air
1725         nac = cblk(lcell,vac0)
1726         dnu = dgnuc(lcell)              !m
1727         dac = dgacc(lcell)
1728         vaer = (pirs/6.0) * (cblk(lcell,vnu3) + cblk(lcell,vac3))
1729 !aerosol volume in i and j mode.
1730 !=================================================
1731 !convert the unit from ug/m3 to mol/L (in aerosol solution)
1732         ah2o = ( cblk(lcell,vh2oaj) + cblk(lcell,vh2oai) ) * 1.0E-9 / ( mwh2o*vaer)
1733
1734 !convert the unit from ug/m3 to mol/L (in aerosol solution)
1735         acl  = ( cblk(lcell,vclaj) + cblk(lcell,vclai) ) * 1.0E-9/(mwcl*vaer)
1736         ano3 = ( cblk(lcell,vno3aj) + cblk(lcell,vno3ai) ) * 1.0E-9/(mwno3*vaer)
1737
1738 ! convert the unit from ug/m3 to mol/L in air atmosphere.
1739         gn2o5 = cblk(lcell,vn2o5) * 1.0E-9 /mwn2o5
1740
1741         cblk(lcell,vgamn2o5) = 3.2E-8 * ( 1.15E6 - 1.15E6 * exp(-1.3E-1* ah2o ) ) * ( 1 - (1/((6E-2*ah2o/ano3)+1+(29*acl/ano3))))
1742
1743         cblk(lcell,vsnu) = nnu*dnu*dnu*esn16*pirs
1744         cblk(lcell,vsac) = nac*dac*dac*esa16*pirs
1745
1746         cblk(lcell,vcn2o5) = SQRT( 8.0 * rgasuniv * temp * 1000 / ( pirs* mwn2o5 ) )
1747         cblk(lcell,vkn2o5) = cblk(lcell,vcn2o5) * ( cblk(lcell,vsnu) +cblk(lcell,vsac) ) * cblk(lcell,vgamn2o5) / 4
1748         deln2o5 = gn2o5-gn2o5*exp(-1*cblk(lcell,vkn2o5)*dt)      !mole/L in atmosphere
1749
1750         cblk(lcell,vyclno2)= 1/(1+ah2o/(483*acl))
1751
1752         pclno2=deln2o5*cblk(lcell,vyclno2)   !mol/L in atmosphere
1753
1754         if (acl*vaer .lt. pclno2) then
1755                 pclno2=abs(acl*vaer-epsilc*epsilc)
1756                 cblk(lcell,vyclno2)=pclno2/deln2o5
1757         end if
1758
1759
1760         pno3 = deln2o5 * ( 2 - cblk(lcell,vyclno2) ) !mole/L in atmosphere
1761
1762         cblk(lcell,vclno2) = cblk(lcell,vclno2) + pclno2*mwclno2*1.0E9
1763
1764         fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
1765         fracj = 1.0 - fraci
1766
1767         cblk(lcell,vclaj)=max(epsilc*epsilc,(acl*vaer-pclno2))*mwcl*1.0E9*fracj
1768         cblk(lcell,vclai)=max(epsilc*epsilc,(acl*vaer-pclno2))*mwcl*1.0E9*fraci
1769
1770         cblk(lcell,vn2o5) = cblk(lcell,vn2o5)*exp(-1*cblk(lcell,vkn2o5)*dt)
1771         cblk(lcell,vno3ai) = (ano3*vaer + pno3) * mwno3 * 1.0E9* fraci
1772         cblk(lcell,vno3aj) = (ano3*vaer + pno3) * mwno3 * 1.0E9* fracj
1773
1774         END DO
1775
1776         END SUBROUTINE n2o5het
1777 !liqy-20140905
1778 !//////////////////////////////////////////////////////////////////////////////
1779
1780
1781 ! *** Time stepping code advances the aerosol moments one timestep;
1782     SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat         &
1783        ,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat     &
1784        ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1785        ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn      &
1786        ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1787         igrid,jgrid,kgrid)
1788
1789 ! ***  DESCRIPTION: Integrate the Number and Mass equations
1790 !                   for each mode over the time interval DT.
1791 !      PRECONDITIONS:
1792 !       AEROSTEP() must follow calls to all other dynamics routines.
1793
1794 ! ***   Revision history:
1795 !       Adapted 3/95 by UAS and CJC from EAM2's code.
1796 !       Revised 7/29/96 by FSB to use block structure
1797 !       Revised 11/15/96 by FSB dropped flow-through and cast
1798 !                           number solver into Riccati equation form.
1799 !       Revised 8/8/97 by FSB to have mass in Aitken and accumulation mode
1800 !                        each predicted rather than total mass and
1801 !                        Aitken mode mass. Also used a local approximation
1802 !                        the error function. Also added coarse mode.
1803 !       Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1804 !                       accumulation mode by coagulation
1805 !       Revised 10/27/97 by FSB to modify code to use primay emissions
1806 !                        and to correct 3rd moment updates.
1807 !                        Also added coarse mode.
1808 !       Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1809 !       Revised  11/5/97 by FSB to fix error in MSTRNSFR
1810 !       Revised  11/6/97 FSB to correct the expression for FACTRANS to
1811 !                        remove the 6/pi coefficient. UAS found this.
1812 !       Revised 12/15/97 by FSB to change equations for mass concentratin
1813 !                        to a chemical production form with analytic
1814 !                        solutions for the Aitken mode and to remove
1815 !                        time stepping of the 3rd moments. The mass concentration
1816 !                        in the accumulation mode is updated with a forward
1817 !                        Eulerian step.
1818 !       Revised 1/6/98   by FSB Lowered minimum concentration for
1819 !                        sulfate aerosol to 0.1 [ ng / m**3 ].
1820 !       Revised 1/12/98  C30 replaces BRNA31 as a variable. C30 represents
1821 !                        intermodal transfer rate of 3rd moment in place
1822 !                        of 3rd moment coagulation rate.
1823 !       Revised 5/5/98   added new renaming criterion based on diameters
1824 !       Added   3/23/98  by BS condensational groth factors for organics
1825
1826 !**********************************************************************
1827 !     IMPLICIT NONE
1828
1829 ! *** ARGUMENTS:
1830
1831 ! dimension of arrays
1832       INTEGER blksize
1833 ! actual number of cells in arrays
1834       INTEGER numcells
1835 ! nmber of species in CBLK
1836       INTEGER nspcsda
1837 ! model layer
1838       INTEGER layer
1839       REAL cblk(blksize,nspcsda) ! main array of variables
1840       INTEGER igrid,jgrid,kgrid
1841       REAL dt
1842 ! *** Chemical production rates: [ ug / m**3 s ]
1843
1844 ! time step [sec]
1845       REAL so4rat(blksize)  ! sulfate gas-phase production rate
1846
1847 ! anthropogenic organic aerosol mass production rates
1848       REAL organt1rat(blksize)
1849       REAL organt2rat(blksize)
1850       REAL organt3rat(blksize)
1851       REAL organt4rat(blksize)
1852
1853 ! biogenic organic aerosol production rates
1854       REAL orgbio1rat(blksize)
1855       REAL orgbio2rat(blksize)
1856       REAL orgbio3rat(blksize)
1857       REAL orgbio4rat(blksize)
1858
1859 ! *** Primary emissions rates: [ ug / m**3 s ]
1860 ! *** emissions rates for unidentified PM2.5 mass
1861       REAL epm25i(blksize) ! Aitken mode
1862       REAL epm25j(blksize)
1863 ! *** emissions rates for primary organic aerosol
1864 ! Accumululaton mode
1865       REAL eorgi(blksize) ! Aitken mode
1866       REAL eorgj(blksize)
1867 ! *** emissions rates for elemental carbon
1868 ! Accumululaton mode
1869       REAL eeci(blksize) ! Aitken mode
1870       REAL eecj(blksize)
1871 ! *** emissions rates for coarse mode particles
1872 ! Accumululaton mode
1873       REAL esoil(blksize) ! soil derived coarse aerosols
1874       REAL eseas(blksize) ! marine coarse aerosols
1875       REAL epmcoarse(blksize)
1876 ! anthropogenic coarse aerosols
1877       REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1878       REAL dgacc(blksize)
1879 ! accumulation
1880       REAL fconcn(blksize)                                 ! Aitken mode  [ 1 / s ]
1881 ! reciprocal condensation rate
1882       REAL fconca(blksize)                                 ! acclumulation mode [ 1 / s ]
1883 ! reciprocal condensation rate
1884       REAL fconcn_org(blksize)                                 ! Aitken mode  [ 1 / s ]
1885 ! reciprocal condensation rate for organ
1886       REAL fconca_org(blksize)                                 ! acclumulation mode [ 1 / s ]
1887 ! reciprocal condensation rate for organ
1888       REAL dmdt(blksize)                                 ! by particle formation [ ug/m**3 /s ]
1889 ! rate of production of new mass concent
1890       REAL dndt(blksize)                                 ! by particle formation [ number/m**3 /s
1891 ! rate of producton of new particle numb
1892       REAL deltaso4a(blksize)                                 ! sulfate aerosol by condensation [ ug/m
1893 ! increment of concentration added to
1894       REAL urn00(blksize) ! Aitken intramodal coagulation rate
1895       REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1896       REAL brna01(blksize) ! bimodal coagulation rate for number
1897       REAL c30(blksize)                                                         ! by intermodal coagulation
1898 ! intermodal 3rd moment transfer rate by
1899       REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1900       REAL cgra3(blksize)
1901 ! *** Modal mass concentrations [ ug m**3 ]
1902
1903 ! growth rate for 3rd moment for Accumul
1904       REAL pmassn(blksize) ! mass concentration in Aitken mode
1905       REAL pmassa(blksize) ! mass concentration in accumulation
1906       REAL pmassc(blksize)
1907
1908 ! *** Local Variables
1909
1910 ! mass concentration in coarse mode
1911       INTEGER l, lcell, spc
1912 ! ** following scratch variables are used for solvers
1913
1914 ! *** variables needed for modal dynamics solvers:
1915 ! Loop indices
1916       REAL*8 a, b, c
1917       REAL*8 m1, m2, y0, y
1918       REAL*8 dhat, p, pexpdt, expdt
1919       REAL*8 loss, prod, pol, lossinv
1920 ! mass intermodal transfer by coagulation
1921       REAL mstrnsfr
1922
1923       REAL factrans
1924
1925 ! *** CODE additions for renaming
1926       REAL getaf2
1927       REAL aaa, xnum, xm3, fnum, fm3, phnum, phm3 ! Defined below
1928       REAL erf, & ! Error and complementary error function
1929         erfc
1930
1931       REAL xx
1932 ! dummy argument for ERF and ERFC
1933 ! a numerical value for a minimum concentration
1934
1935 ! *** This value is smaller than any reported tropospheric concentration
1936
1937 ! *** Statement function given for error function. Source is
1938 !     Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1939 !      droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1940 !      20:253-265. They cite Reasearch & Education Asociation (REA), (19
1941 !      Handbook of Mathematical, Scientific, and Engineering Formulas,
1942 !      Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1943
1944       erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1945       erfc(xx) = 1.0 - erf(xx)
1946 !     ::::::::::::::::::::::::::::::::::::::::
1947
1948 ! ///// begin code
1949 ! *** set up time-step integration
1950
1951       DO l = 1, numcells
1952
1953 ! *** code to move number forward by one time step.
1954 ! *** solves the Ricatti equation:
1955
1956 !     dY/dt = C - A * Y ** 2 - B * Y
1957
1958 !     Coded 11/21/96 by Dr. Francis S. Binkowski
1959
1960 ! *** Aitken mode:
1961 ! *** coefficients
1962         a = urn00(l)
1963         b = brna01(l)*cblk(l,vac0)
1964         c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1965
1966 ! includes primary emissions
1967         y0 = cblk(l,vnu0)
1968 ! ***  trap on C = 0
1969
1970 ! initial condition
1971         IF (c>0.0D0) THEN
1972
1973           dhat = sqrt(b*b+4.0D0*a*c)
1974
1975           m1 = 2.0D0*a*c/(b+dhat)
1976
1977           m2 = -0.5D0*(b+dhat)
1978
1979           p = -(m1-a*y0)/(m2-a*y0)
1980
1981           pexpdt = p*exp(-dhat*dt)
1982
1983           y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1984 ! solution
1985         ELSE
1986
1987 ! *** rearrange solution for NUMERICAL stability
1988 !     note If B << A * Y0, the following form, although
1989 !     seemingly awkward gives the correct answer.
1990
1991           expdt = exp(-b*dt)
1992           IF (expdt<1.0D0) THEN
1993             y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1994           ELSE
1995             y = y0
1996           END IF
1997
1998         END IF
1999 !       if(y.lt.nummin_i)then
2000 !         print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
2001 !         print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
2002 !         print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
2003 !       endif
2004
2005         cblk(l,vnu0) = max(nummin_i,y)
2006
2007 ! *** now do accumulation mode number
2008
2009 ! *** coefficients
2010
2011 ! update
2012         a = ura00(l)
2013         b = & ! NOTE B = 0.0
2014           0.0D0
2015         c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
2016 ! includes primary emissi
2017         y0 = cblk(l,vac0)
2018 ! *** this equation requires special handling, because C can be zero.
2019 !     if this happens, the form of the equation is different:
2020
2021 ! initial condition
2022 !       print *,vac0,y0,c,nummin_j,a
2023         IF (c>0.0D0) THEN
2024
2025           dhat = sqrt(4.0D0*a*c)
2026
2027           m1 = 2.0D0*a*c/dhat
2028
2029           m2 = -0.5D0*dhat
2030
2031           p = -(m1-a*y0)/(m2-a*y0)
2032
2033 !       print *,p,-dhat,dt,-dhat*dt
2034 !       print *,exp(-dhat*dt)
2035           pexpdt = p*exp(-dhat*dt)
2036
2037           y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
2038 ! solution
2039         ELSE
2040
2041           y = y0/(1.0D0+dt*a*y0)
2042 !       print *,dhat,y0,dt,a
2043           y = y0/(1.+dt*a*y0)
2044 !       print *,y
2045 ! correct solution to equation
2046         END IF
2047
2048         cblk(l,vac0) = max(nummin_j,y)
2049 ! *** now do coarse mode number neglecting coagulation
2050 ! update
2051 !       print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
2052         prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
2053
2054 !       print *,cblk(l,vcorn),factnumc,prod
2055         cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
2056
2057 ! *** Prepare to advance modal mass concentration one time step.
2058
2059 ! *** Set up production and and intermodal transfer terms terms:
2060 !       print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
2061         cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
2062
2063 ! includes growth from pri
2064         cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
2065           orgfac*eorgj(l)                                              ! and transfer of 3rd momen
2066                                              ! intermodal coagulation
2067
2068 ! *** set up transfer coefficients for coagulation between Aitken and ac
2069
2070
2071 ! *** set up special factors for mass transfer from the Aitken to accumulation
2072 !     intermodal coagulation. The mass transfer rate is proportional to
2073 !     transfer rate, C30. The proportionality factor is p/6 times the the
2074 !     density. The average particle density for a species is the species
2075 !     divided by the particle volume concentration, pi/6 times the 3rd m
2076 !     The p/6 coefficients cancel.
2077
2078 ! includes growth from prim
2079 !       print *,'loss',vnu3,c30(l),cblk(l,vnu3)
2080         loss = c30(l)/cblk(l,vnu3)
2081
2082 ! Normalized coagulation transfer r
2083         factrans = loss*dt                            ! yields an estimate of the amount of mass t
2084      ! the Aitken to the accumulation mode in the
2085
2086 ! Multiplying this factor by the species con
2087 !       print *,'factrans = ',factrans,loss
2088         expdt = exp(-factrans)                               ! decay term is common to all Aitken mode
2089 !       print *,'factrans = ',factrans,loss,expdt
2090 ! variable name is re-used here. This expo
2091         lossinv = 1.0/loss
2092 ! *** now advance mass concentrations one time step.
2093
2094 ! ***  update sulfuric acid vapor concentration by removing mass concent
2095 !      condensed sulfate and newly produced particles.
2096 ! *** The method follows Youngblood and Kreidenweis, Further Development
2097 !     of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
2098 !     Atmospheric Science Paper Number 550, April,1994, pp 85-89.
2099 ! set up for multiplication rather than divi
2100         cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
2101
2102 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
2103 ! *** Solution is:     c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
2104
2105 ! *** sulfate:
2106         mstrnsfr = cblk(l,vso4ai)*factrans
2107         prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
2108         pol = prod*lossinv
2109 !       print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
2110
2111         cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
2112         cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
2113         cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
2114
2115 ! *** anthropogenic secondary organic:
2116 !bs * anthropogenic secondary organics from aromatic precursors
2117 !!! anthropogenic secondary organics from different precursors
2118 !!! the formulas are the same as in BS's version, only precursors and partition are different!
2119
2120         mstrnsfr = cblk(l,vasoa1i)*factrans
2121         prod = organt1rat(l)*fconcn_org(l)
2122         pol = prod*lossinv
2123
2124         cblk(l,vasoa1i) = pol + (cblk(l,vasoa1i)-pol)*expdt
2125         cblk(l,vasoa1i) = max(conmin,cblk(l,vasoa1i))
2126         cblk(l,vasoa1j) = cblk(l,vasoa1j) + organt1rat(l)*fconca_org(l)*dt + mstrnsfr
2127         !!!!!!!!!!!!!
2128
2129         mstrnsfr = cblk(l,vasoa2i)*factrans
2130         prod = organt2rat(l)*fconcn_org(l)
2131         pol = prod*lossinv
2132
2133         cblk(l,vasoa2i) = pol + (cblk(l,vasoa2i)-pol)*expdt
2134         cblk(l,vasoa2i) = max(conmin,cblk(l,vasoa2i))
2135         cblk(l,vasoa2j) = cblk(l,vasoa2j) + organt2rat(l)*fconca_org(l)*dt + mstrnsfr
2136         !!!!!!!!!!!!!
2137
2138         mstrnsfr = cblk(l,vasoa3i)*factrans
2139         prod = organt3rat(l)*fconcn_org(l)
2140         pol = prod*lossinv
2141
2142         cblk(l,vasoa3i) = pol + (cblk(l,vasoa3i)-pol)*expdt
2143         cblk(l,vasoa3i) = max(conmin,cblk(l,vasoa3i))
2144         cblk(l,vasoa3j) = cblk(l,vasoa3j) + organt3rat(l)*fconca_org(l)*dt + mstrnsfr
2145         !!!!!!!!!!!!!
2146
2147         mstrnsfr = cblk(l,vasoa4i)*factrans
2148         prod = organt4rat(l)*fconcn_org(l)
2149         pol = prod*lossinv
2150
2151         cblk(l,vasoa4i) = pol + (cblk(l,vasoa4i)-pol)*expdt
2152         cblk(l,vasoa4i) = max(conmin,cblk(l,vasoa4i))
2153         cblk(l,vasoa4j) = cblk(l,vasoa4j) + organt4rat(l)*fconca_org(l)*dt + mstrnsfr
2154
2155 ! *** biogenic secondary organic
2156         mstrnsfr = cblk(l,vbsoa1i)*factrans
2157         prod = orgbio1rat(l)*fconcn_org(l)
2158         pol = prod*lossinv
2159
2160         cblk(l,vbsoa1i) = pol + (cblk(l,vbsoa1i)-pol)*expdt
2161         cblk(l,vbsoa1i) = max(conmin,cblk(l,vbsoa1i))
2162         cblk(l,vbsoa1j) = cblk(l,vbsoa1j) + orgbio1rat(l)*fconca_org(l)*dt + mstrnsfr
2163         !!!!!!!!!!!!!
2164
2165         mstrnsfr = cblk(l,vbsoa2i)*factrans
2166         prod = orgbio2rat(l)*fconcn_org(l)
2167         pol = prod*lossinv
2168
2169         cblk(l,vbsoa2i) = pol + (cblk(l,vbsoa2i)-pol)*expdt
2170         cblk(l,vbsoa2i) = max(conmin,cblk(l,vbsoa2i))
2171         cblk(l,vbsoa2j) = cblk(l,vbsoa2j) + orgbio2rat(l)*fconca_org(l)*dt + mstrnsfr
2172         !!!!!!!!!!!!!
2173
2174         mstrnsfr = cblk(l,vbsoa3i)*factrans
2175         prod = orgbio3rat(l)*fconcn_org(l)
2176         pol = prod*lossinv
2177
2178         cblk(l,vbsoa3i) = pol + (cblk(l,vbsoa3i)-pol)*expdt
2179         cblk(l,vbsoa3i) = max(conmin,cblk(l,vbsoa3i))
2180         cblk(l,vbsoa3j) = cblk(l,vbsoa3j) + orgbio3rat(l)*fconca_org(l)*dt + mstrnsfr
2181         !!!!!!!!!!!!!
2182
2183         mstrnsfr = cblk(l,vbsoa4i)*factrans
2184         prod = orgbio4rat(l)*fconcn_org(l)
2185         pol = prod*lossinv
2186
2187         cblk(l,vbsoa4i) = pol + (cblk(l,vbsoa4i)-pol)*expdt
2188         cblk(l,vbsoa4i) = max(conmin,cblk(l,vbsoa4i))
2189         cblk(l,vbsoa4j) = cblk(l,vbsoa4j) + orgbio4rat(l)*fconca_org(l)*dt + mstrnsfr
2190
2191 ! *** primary anthropogenic organic
2192         mstrnsfr = cblk(l,vorgpai)*factrans
2193         prod = eorgi(l)
2194         pol = prod*lossinv
2195
2196         cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
2197         cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
2198         cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
2199
2200 ! *** other anthropogenic PM2.5
2201         mstrnsfr = cblk(l,vp25ai)*factrans
2202         prod = epm25i(l)
2203         pol = prod*lossinv
2204
2205         cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
2206         cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
2207         cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
2208
2209 ! ***  elemental carbon
2210         mstrnsfr = cblk(l,veci)*factrans
2211         prod = eeci(l)
2212         pol = prod*lossinv
2213
2214         cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
2215         cblk(l,veci) = max(conmin,cblk(l,veci))
2216         cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
2217
2218 ! *** coarse mode
2219 ! *** soil dust
2220         cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
2221         cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
2222
2223 ! *** sea salt
2224         cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
2225         cblk(l,vseas) = max(conmin,cblk(l,vseas))
2226
2227 ! *** anthropogenic PM10 coarse fraction
2228         cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
2229         cblk(l,vantha) = max(conmin,cblk(l,vantha))
2230
2231       END DO
2232
2233
2234 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
2235 !     then merge modes by renaming.
2236
2237 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
2238
2239 ! end of time-step loop for total mass
2240       DO lcell = 1, numcells
2241
2242 !       IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
2243 !    &      CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
2244         IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
2245             lcell,vnu0)>cblk(lcell,vac0)) &
2246             THEN
2247
2248 ! check if mer
2249           aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
2250             dgacc(lcell),xxlsgn,xxlsga,sqrt2)
2251
2252 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2253 !        dd is the diameter at which the Aitken-mode and accumulation-mo
2254 !        distributions intersect (overap).
2255
2256           xnum = max(aaa,xxm3)                                    ! this means that no more than one ha
2257                                    ! total Aitken mode number may be tra per call.
2258
2259 ! do not let XNUM become negative bec
2260           xm3 = xnum - &
2261             xxm3
2262 ! set up for 3rd moment and mass tran
2263           IF (xm3>0.0) &
2264               THEN
2265 ! do mode merging if  overlap is corr
2266             phnum = 0.5*(1.0+erf(xnum))
2267             phm3 = 0.5*(1.0+erf(xm3))
2268             fnum = 0.5*erfc(xnum)
2269             fm3 = 0.5*erfc(xm3)
2270
2271 !     In the Aitken mode:
2272
2273 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2274 !     distributions with  diameters greater than dd respectively.
2275
2276 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2277 !     distributions with diameters less than dd.
2278
2279 ! *** rename the  Aitken mode particle number as accumulation mode
2280 !     particle number
2281
2282     cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2283
2284 ! *** adjust the Aitken mode number
2285
2286     cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2287
2288 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2289 !     to the accumulation mode is proportional to the amount of 3rd mome
2290 !     transferred, therefore FM3 is used for mass transfer.
2291
2292     cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2293
2294     cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2295
2296     cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2297
2298 !liqy
2299         cblk(lcell,vnaaj) = cblk(lcell,vnaaj) + cblk(lcell,vnaai)*fm3
2300         cblk(lcell,vclaj) = cblk(lcell,vclaj) + cblk(lcell,vclai)*fm3
2301         cblk(lcell,vcaaj) = cblk(lcell,vcaaj) + cblk(lcell,vcaai)*fm3
2302         cblk(lcell,vkaj)  = cblk(lcell,vkaj)  + cblk(lcell,vkai)*fm3
2303         cblk(lcell,vmgaj) = cblk(lcell,vmgaj) + cblk(lcell,vmgai)*fm3
2304 !liqy-20140617
2305
2306     cblk(lcell,vasoa1j) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)*fm3
2307
2308     cblk(lcell,vasoa2j) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)*fm3
2309
2310     cblk(lcell,vasoa3j) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)*fm3
2311
2312     cblk(lcell,vasoa4j) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)*fm3
2313
2314     cblk(lcell,vbsoa1j) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)*fm3
2315
2316     cblk(lcell,vbsoa2j) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)*fm3
2317
2318     cblk(lcell,vbsoa3j) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)*fm3
2319
2320     cblk(lcell,vbsoa4j) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)*fm3
2321
2322     cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + cblk(lcell,vorgpai)*fm3
2323
2324     cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2325
2326     cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2327
2328 ! *** update Aitken mode for mass loss to accumulation mode
2329           cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2330
2331           cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2332
2333           cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2334 !liqy
2335                   cblk(lcell,vnaai) = cblk(lcell,vnaai)*phm3
2336                   cblk(lcell,vclai) = cblk(lcell,vclai)*phm3
2337                   cblk(lcell,vcaai) = cblk(lcell,vcaai)*phm3
2338                   cblk(lcell,vkai)  = cblk(lcell,vkai)*phm3
2339                   cblk(lcell,vmgai) = cblk(lcell,vmgai)*phm3
2340 !liqy-20140617
2341
2342           cblk(lcell,vasoa1i) = cblk(lcell,vasoa1i)*phm3
2343
2344           cblk(lcell,vasoa2i) = cblk(lcell,vasoa2i)*phm3
2345
2346           cblk(lcell,vasoa3i) = cblk(lcell,vasoa3i)*phm3
2347
2348           cblk(lcell,vasoa4i) = cblk(lcell,vasoa4i)*phm3
2349
2350           cblk(lcell,vbsoa1i) = cblk(lcell,vbsoa1i)*phm3
2351
2352           cblk(lcell,vbsoa2i) = cblk(lcell,vbsoa2i)*phm3
2353
2354           cblk(lcell,vbsoa3i) = cblk(lcell,vbsoa3i)*phm3
2355
2356           cblk(lcell,vbsoa4i) = cblk(lcell,vbsoa4i)*phm3
2357
2358           cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2359
2360           cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2361
2362           cblk(lcell,veci) = cblk(lcell,veci)*phm3
2363
2364     END IF
2365 ! end check on whether modal overlap is OK
2366
2367    END IF
2368 ! end check on necessity for merging
2369
2370 END DO
2371 !     set min value for all concentrations
2372
2373 ! loop for merging
2374       DO spc = 1, nspcsda
2375         DO lcell = 1, numcells
2376           cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2377         END DO
2378       END DO
2379 !---------------------------------------------------------------------------------
2380
2381 RETURN
2382 END SUBROUTINE aerostep
2383 !#######################################################################
2384
2385 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2386 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2387 !         mso4,mnh4,mno3 are in microMOLES / cubic meter
2388
2389 !  This  version uses polynomials rather than tables, and uses empirical
2390 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2391 !   where:
2392
2393 !            mfs = ms / ( ms + mw)
2394 !             ms is the mass of solute
2395 !             mw is the mass of water.
2396
2397 !  Define y = mw/ ms
2398
2399 !  then  mfs = 1 / (1 + y)
2400
2401 !    y can then be obtained from the values of mfs as
2402
2403 !             y = (1 - mfs) / mfs
2404
2405
2406 !     the aerosol is assumed to be in a metastable state if the rh is
2407 !     is below the rh of deliquescence, but above the rh of crystallizat
2408
2409 !     ZSR interpolation is used for sulfates with x ( the molar ratio of
2410 !     ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2411 !     section 1: 0 <= x < 1
2412 !     section 2: 1 <= x < 1.5
2413 !     section 3: 1.5 <= x < 2.0
2414 !     section 4: 2 <= x
2415 !     In sections 1 through 3, only the sulfates can affect the amount o
2416 !     on the particles.
2417 !     In section 4, we have fully neutralized sulfate, and extra ammoniu
2418 !     allows more nitrate to be present. Thus, the ammount of water is c
2419 !     using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2420 !     assumed to occur in sections 2,3,and 4. See detailed discussion be
2421
2422 ! definitions:
2423 !     mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2424 !      for sulfate, ammonium, and nitrate respectively
2425 !     irhx is the relative humidity (%)
2426 !     wh2o is the returned water amount in micrograms / cubic meter of a
2427 !     x is the molar ratio of ammonium to sulfate
2428 !     y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2429 !     for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2430 !     y3 is the value of the mass ratio of water to solute for
2431 !     a pure ammonium nitrate  solution.
2432
2433 !coded by Dr. Francis S. Binkowski, 4/8/96.
2434
2435 !     IMPLICIT NONE
2436       INTEGER irhx, irh
2437       REAL mso4, mnh4, mno3
2438       REAL tso4, tnh4, tno3, wh2o, x
2439       REAL aw, awc
2440 !     REAL poly4, poly6
2441       REAL mfs0, mfs1, mfs15, mfs2
2442       REAL c0(4), c1(4), c15(4), c2(4)
2443       REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2444       REAL kso4(6), kno3(6), mfsso4, mfsno3
2445       REAL mwso4, mwnh4, mwno3, mw2, mwano3
2446
2447 ! *** molecular weights:
2448       PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2449         mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2450
2451 !     The polynomials use data for aw as a function of mfs from Tang and
2452 !     Munkelwitz, JGR 99: 18801-18808, 1994.
2453 !     The polynomials were fit to Tang's values of water activity as a
2454 !     function of mfs.
2455
2456 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2457 !     now give mfs as a function of water activity.
2458
2459       DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2460       DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2461       DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2462
2463 ! *** the following coefficients are a fit to the data in Table 1 of
2464 !     Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2465 !      data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2466 ! *** New data fit to data from
2467 !       Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2468 !       Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2469 !       Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2470       DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2471
2472 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2473 !     Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2474
2475       DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2476       DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2477
2478 ! *** check range of per cent relative humidity
2479       irh = irhx
2480       irh = max(1,irh)
2481       irh = min(irh,100)
2482       aw = float(irh)/ & ! water activity = fractional relative h
2483         100.0
2484       tso4 = max(mso4,0.0)
2485       tnh4 = max(mnh4,0.0)
2486       tno3 = max(mno3,0.0)
2487       x = 0.0
2488 ! *** if there is non-zero sulfate calculate the molar ratio
2489       IF (tso4>0.0) THEN
2490         x = tnh4/tso4
2491       ELSE
2492 ! *** otherwise check for non-zero nitrate and ammonium
2493         IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2494       END IF
2495
2496 ! *** begin screen on x for calculating wh2o
2497       IF (x<1.0) THEN
2498
2499         mfs0 = poly4(c0,aw)
2500         mfs1 = poly4(c1,aw)
2501         y0 = (1.0-mfs0)/mfs0
2502         y1 = (1.0-mfs1)/mfs1
2503         y = (1.0-x)*y0 + x*y1
2504
2505       ELSE IF (x<1.5) THEN
2506
2507         IF (irh>=40) THEN
2508           mfs1 = poly4(c1,aw)
2509           mfs15 = poly4(c15,aw)
2510           y1 = (1.0-mfs1)/mfs1
2511           y15 = (1.0-mfs15)/mfs15
2512           y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2513         ELSE
2514 ! *** set up for crystalization
2515
2516 ! *** Crystallization is done as follows:
2517 !      For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2518 !      For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2519 !      and since the code does not allow ar rh < 0.01, crystallization
2520 !      is assumed not to occur in this range.
2521 !      For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2522 !      from a value of y15 at rh = 0.4 to a value of zero at y1. From
2523 !      point B to point A in the diagram.
2524 !      The algorithm does a double interpolation to calculate the amount
2525 !      water.
2526
2527 !        y1(0.40)               y15(0.40)
2528 !         +                     + Point B
2529
2530 !         +--------------------+
2531 !       x=1                   x=1.5
2532 !      Point A
2533
2534           awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2535           y = 0.0
2536           IF (aw>=awc) & ! interpolate using crystalization
2537               THEN
2538             mfs1 = poly4(c1,0.40)
2539             mfs15 = poly4(c15,0.40)
2540             y140 = (1.0-mfs1)/mfs1
2541             y1540 = (1.0-mfs15)/mfs15
2542             y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2543             yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2544             y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2545 ! end of checking for aw
2546           END IF
2547
2548         END IF
2549 ! end of checking on irh
2550       ELSE IF (x<1.9999) THEN
2551
2552         y = 0.0
2553         IF (irh>=40) THEN
2554           mfs15 = poly4(c15,aw)
2555           mfs2 = poly4(c2,aw)
2556           y15 = (1.0-mfs15)/mfs15
2557           y2 = (1.0-mfs2)/mfs2
2558           y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2559
2560         END IF
2561
2562 ! end of check for crystallization
2563
2564       ELSE
2565 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2566
2567 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2568 ! *** check for crystallization here. their data indicate a 40% value
2569 !     is appropriate.
2570 ! 1.9999 < x
2571         y2 = 0.0
2572         y3 = 0.0
2573         IF (irh>=40) THEN
2574           mfsso4 = poly6(kso4,aw)
2575           mfsno3 = poly6(kno3,aw)
2576           y2 = (1.0-mfsso4)/mfsso4
2577           y3 = (1.0-mfsno3)/mfsno3
2578
2579         END IF
2580
2581       END IF
2582 ! *** now set up output of wh2o
2583
2584 !      wh2o units are micrograms (liquid water) / cubic meter of air
2585
2586 ! end of checking on x
2587       IF (x<1.9999) THEN
2588
2589         wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2590
2591       ELSE
2592
2593 ! *** this is the case that all the sulfate is ammonium sulfate
2594 !     and the excess ammonium forms ammonum nitrate
2595
2596         wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2597
2598       END IF
2599
2600       RETURN
2601     END SUBROUTINE awater
2602 !//////////////////////////////////////////////////////////////////////
2603
2604     SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2605         dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2606 !***********************************************************************
2607 !**    DESCRIPTION:  calculates aerosol coagulation rates for unimodal
2608 !       and bimodal coagulation using E. Whitby 1990's prescription.
2609
2610 !.......   Rates for coaglulation:
2611 !.......   Unimodal Rates:
2612 !.......   URN00:  nuclei       mode 0th moment self-coagulation rate
2613 !.......   URA00:  accumulation mode 0th moment self-coagulation rate
2614
2615 !.......   Bimodal Rates:  (only 1st order coeffs appear)
2616 !.......   NA-- nuclei  with accumulation coagulation rates,
2617 !.......   AN-- accumulation with nuclei coagulation rates
2618 !.......   BRNA01:  rate for 0th moment ( d(nuclei mode 0) / dt  term)
2619 !.......   BRNA31:           3rd        ( d(nuclei mode 3) / dt  term)
2620 !**    Revision history:
2621 !       prototype 1/95 by Uma and Carlie
2622 !       Revised   8/95 by US for calculation of density from stmt func
2623 !                 and collect met variable stmt funcs in one include fil
2624 !      REVISED 7/25/96 by FSB to use block structure
2625 !      REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2626 !      REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2627 !                              changed. All coagulation coefficients
2628 !                              returned with positive signs. Their
2629 !                              linearization is also abandoned.
2630 !                              Fixed values are used for the corrections
2631 !                              to the free-molecular coagulation integra
2632 !                              The code forces the harmonic means to be
2633 !                              evaluated in 64 bit arithmetic on 32 bit
2634 !     REVISED 11/14/96 BY FSB  Internal units are now MKS, moment / unit
2635
2636 !      REVISED 1/12/98 by FSB   C30 replaces BRNA31 as an array. This wa
2637 !                              because BRNA31 can become zero on a works
2638 !                              because of limited precision. With the ch
2639 !                              aerostep to omit update of the 3rd moment
2640 !                              C30 is the only variable now needed.
2641 !                              the logic using ONE88 to force REAL*8 ari
2642 !                              has been removed and all intermediates ar
2643 !                              REAL*8.
2644 !     IMPLICIT NONE
2645
2646 ! dimension of arrays
2647       INTEGER blksize
2648 ! actual number of cells in arrays
2649       INTEGER numcells
2650
2651       INTEGER nspcsda
2652
2653 ! nmber of species in CBLK
2654       REAL cblk(blksize,nspcsda) ! main array of variables
2655       REAL blkta(blksize) ! Air temperature [ K ]
2656       REAL pdensn(blksize) ! average particel density in Aitk
2657       REAL pdensa(blksize) ! average particel density in accu
2658       REAL amu(blksize) ! atmospheric dynamic viscosity [
2659       REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2660       REAL dgacc(blksize) ! accumulation mode mean diameter
2661       REAL knnuc(blksize) ! Aitken mode Knudsen number
2662       REAL knacc(blksize)
2663 ! *** output:
2664
2665 ! accumulation mode Knudsen number
2666       REAL urn00(blksize) ! intramodal coagulation rate (Ait
2667       REAL ura00(blksize)
2668 ! intramodal coagulation rate (acc
2669       REAL brna01(blksize) ! intermodal coagulaton rate (numb
2670       REAL c30(blksize)                                                               ! by inter
2671
2672 ! *** Local variables:
2673 ! intermodal 3rd moment transfer r
2674       REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2675         kncacc
2676       REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2677         kfmacc
2678       REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2679         kfm
2680       REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2681         bencna
2682       REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2683         bencm3n
2684       REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2685         befmna
2686       REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2687         befm3n
2688       REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2689         betana
2690       REAL*8 & ! intermodal coagulation rate for 3rd mo
2691         brna31
2692       REAL*8 & ! scratch subexpression
2693         s1
2694       REAL*8 t1, & ! scratch subexpressions
2695         t2
2696       REAL*8 t16, & ! T1**6, T2**6
2697         t26
2698       REAL*8 rat, & ! ratio of acc to nuc size and its inver
2699         rin
2700       REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2701         rsq4
2702       REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2703         rsqi3
2704       REAL*8 & ! dgnuc**3
2705         dgn3
2706       REAL*8 & !                                 in 64 bit arithmetic
2707         dga3
2708 ! dgacc**3
2709
2710       INTEGER lcell
2711 ! *** Fixed values for correctionss to coagulation
2712 !      integrals for free-molecular case.
2713 ! loop counter
2714       REAL*8 bm0
2715       PARAMETER (bm0=0.8D0)
2716       REAL*8 bm0i
2717       PARAMETER (bm0i=0.9D0)
2718       REAL*8 bm3i
2719       PARAMETER (bm3i=0.9D0)
2720       REAL*8 & ! approx Cunningham corr. factor
2721         a
2722       PARAMETER (a=1.246D0)
2723 !.......................................................................
2724 !   begin body of subroutine  COAGRATE
2725
2726 !...........   Main computational grid-traversal loops
2727 !...........   for computing coagulation rates.
2728
2729 ! *** Both modes have fixed std devs.
2730       DO lcell = 1, &
2731           numcells
2732 ! *** moment independent factors
2733
2734 !  loop on LCELL
2735         s1 = two3*boltz*blkta(lcell)/amu(lcell)
2736
2737 ! For unimodal coagualtion:
2738
2739         kncnuc = s1
2740         kncacc = s1
2741
2742         kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2743         kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2744
2745 ! For bimodal coagulation:
2746
2747         knc = s1
2748         kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2749
2750 !...........   Begin unimodal coagulation rate calculations:
2751 !...........   Near-continuum regime.
2752
2753         dgn3 = dgnuc(lcell)**3
2754         dga3 = dgacc(lcell)**3
2755
2756         t1 = sqrt(dgnuc(lcell))
2757         t2 = sqrt(dgacc(lcell))
2758         t16 = & ! = T1**6
2759           dgn3
2760         t26 = &
2761           dga3
2762 !.......   Note rationalization of fractions and subsequent cancellation
2763 !.......   from the formulation in  Whitby et al. (1990)
2764
2765 ! = T2**6
2766         bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2767
2768         bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2769
2770 !...........   Free molecular regime. Uses fixed value for correction
2771 !               factor BM0
2772
2773         befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2774         befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2775
2776 !...........   Calculate half the harmonic mean between unimodal rates
2777 !...........   free molecular and near-continuum regimes
2778
2779 ! FSB       64 bit evaluation
2780
2781         betann = bencnn*befmnn/(bencnn+befmnn)
2782         betana = bencna*befmna/(bencna+befmna)
2783
2784         urn00(lcell) = betann
2785         ura00(lcell) = betana
2786
2787 ! *** End of unimodal coagulation calculations.
2788
2789 !...........   Begin bimodal coagulation rate calculations:
2790
2791         rat = dgacc(lcell)/dgnuc(lcell)
2792         rin = 1.0D0/rat
2793         rsqt = sqrt(rat)
2794         rsq4 = rat**2
2795
2796         rsqti = 1.0D0/rsqt
2797         rsqi3 = rin*rsqti
2798
2799 !...........   Near-continuum coeffs:
2800 !...........   0th moment nuc mode bimodal coag coefficient
2801
2802         bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2803           )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2804
2805 !...........   3rd moment nuc mode bimodal coag coefficient
2806
2807         bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2808           *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2809           rin*esn64*esa04)
2810
2811 !...........   Free molecular regime coefficients:
2812 !...........   Uses fixed value for correction
2813 !               factor BM0I, BM3I
2814 !...........   0th moment nuc mode coeff
2815
2816         befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2817           rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2818
2819 !...........   3rd moment nuc mode coeff
2820
2821         befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2822           rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2823
2824
2825 !...........   Calculate half the harmonic mean between bimodal rates
2826 !...........   free molecular and near-continuum regimes
2827
2828 ! FSB       Force 64 bit evaluation
2829
2830         brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2831
2832         brna31 = bencm3n* & ! BRNA31 now is a scala
2833           befm3n/(bencm3n+befm3n)
2834         c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2835 !       print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2836                               ! 3d moment transfer by intermodal coagula
2837 !         End bimodal coagulation rate.
2838
2839       END DO
2840 ! end of main lop over cells
2841       RETURN
2842 END SUBROUTINE coagrate
2843 !------------------------------------------------------------------
2844
2845 ! subroutine  to find the roots of a cubic equation / 3rd order polynomi
2846 ! formulae can be found in numer. recip.  on page 145
2847 !   kiran  developed  this version on 25/4/1990
2848 !   dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2849 ! ***
2850 !234567
2851 ! coagrate
2852     SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2853 !     IMPLICIT NONE
2854       INTEGER nr
2855       REAL*8 a2, a1, a0
2856       REAL crutes(3)
2857       REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2858       REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2859       REAL*8 costh, sinth
2860       DATA sqrt3/1.732050808/, one3rd/0.333333333/
2861 !bs
2862       REAL*8 onebs
2863       PARAMETER (onebs=1.0)
2864 !bs
2865       a2sq = a2*a2
2866       qq = (a2sq-3.*a1)/9.
2867       rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2868 ! CASE 1 THREE REAL ROOTS or  CASE 2 ONLY ONE REAL ROOT
2869       dum1 = qq*qq*qq
2870       rrsq = rr*rr
2871       dum2 = dum1 - rrsq
2872       IF (dum2>=0.) THEN
2873 ! NOW WE HAVE THREE REAL ROOTS
2874         phi = sqrt(dum1)
2875         IF (abs(phi)<1.E-20) THEN
2876           print *, ' cubic phi small, phi = ',phi
2877           crutes(1) = 0.0
2878           crutes(2) = 0.0
2879           crutes(3) = 0.0
2880           nr = 0
2881           CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2882         END IF
2883         theta = acos(rr/phi)/3.0
2884         costh = cos(theta)
2885         sinth = sin(theta)
2886 ! *** use trig identities to simplify the expressions
2887 ! *** binkowski's modification
2888         part1 = sqrt(qq)
2889         yy1 = part1*costh
2890         yy2 = yy1 - a2/3.0
2891         yy3 = sqrt3*part1*sinth
2892         crutes(3) = -2.0*yy1 - a2/3.0
2893         crutes(2) = yy2 + yy3
2894         crutes(1) = yy2 - yy3
2895 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2896         IF (crutes(1)<0.0) crutes(1) = 1.0E9
2897         IF (crutes(2)<0.0) crutes(2) = 1.0E9
2898         IF (crutes(3)<0.0) crutes(3) = 1.0E9
2899 ! *** put smallest positive root in crutes(1)
2900         crutes(1) = min(crutes(1),crutes(2),crutes(3))
2901         nr = 3
2902 !     NOW HERE WE HAVE ONLY ONE REAL ROOT
2903       ELSE
2904 ! dum IS NEGATIVE
2905         part1 = sqrt(rrsq-dum1)
2906         part2 = abs(rr)
2907         part3 = (part1+part2)**one3rd
2908         crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2909 !bs     &        -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2910         crutes(2) = 0.
2911         crutes(3) = 0.
2912 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2913 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2914 !     if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2915         nr = 1
2916       END IF
2917       RETURN
2918     END SUBROUTINE cubic
2919 !///////////////////////////////////////////////////////////////////////
2920
2921 !liqy
2922 !    Calculate the aerosol chemical speciation and water content.
2923 ! cubic
2924     SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
2925 !***********************************************************************
2926 !**    DESCRIPTION:
2927 !       Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2928 !       and water between the gas and aerosol phases as the total sulfate,
2929 !       ammonia, and nitrate concentrations, relative humidity and
2930 !       temperature change.  The evolution of the aerosol mass concentration
2931 !       due to the change in aerosol chemical composition is calculated.
2932 !**    REVISION HISTORY:
2933 !       prototype 1/95 by Uma and Carlie
2934 !       Revised   8/95 by US to calculate air density in stmt func
2935 !                 and collect met variable stmt funcs in one include fil
2936 !       Revised 7/26/96 by FSB to use block concept.
2937 !       Revise 12/1896 to do do i-mode calculation.
2938 !**********************************************************************
2939 !     IMPLICIT NONE
2940
2941 ! dimension of arrays
2942       INTEGER blksize
2943 ! actual number of cells in arrays
2944       INTEGER numcells
2945 ! nmber of species in CBLK
2946       INTEGER nspcsda,igrid,jgrid,kgrid
2947       REAL cblk(blksize,nspcsda)
2948 ! *** Meteorological information in blocked arays:
2949
2950 ! main array of variables
2951       REAL blkta(blksize) ! Air temperature [ K ]
2952       REAL blkrh(blksize) ! Fractional relative humidity
2953
2954       INTEGER lcell ! loop counter
2955 ! air temperature
2956       REAL temp
2957 !iamodels3
2958       REAL rh
2959 ! relative humidity
2960       REAL so4, no3, nh3, nh4, hno3
2961       REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2962 ! Fraction of dry sulfate mass in i-mode
2963       REAL fraci
2964       REAL fracj
2965 ! Fraction of dry sulfate mass in j-mode
2966
2967 ! ISOROPIA variables double precision
2968 !      real(kind=8) wi(5),wt(5),wt_save(5)
2969 !      real(kind=8) rhi,tempi,cntrl(2)
2970 !      real(kind=8) gas(3),aerliq(12),aersld(9),other(6)
2971 !      character*15 scasi
2972
2973 !aerosol phase na,cl. gas phase hcl.
2974                 REAL ana,acl,aca,ak,amg
2975                 REAL ghcl
2976 !delta nh3, hno3, and hcl in gaseous phase.
2977                 real dgnh3,dgno3,dghcl
2978 !dmax equals to the maximum available nh4+, no3-, and cl- for evaporation.
2979                 real dmax
2980 ! ISOROPIA variables
2981              DOUBLE PRECISION WI(8), GAS(3), AERLIQ(15), AERSLD(19), CNTRL(2), &
2982                                 WT(8), OTHER(9), RHI, TEMPI
2983              CHARACTER SCASE*15
2984
2985 !molecular weight for all isorropia species
2986
2987                 REAL intmw(37)
2988                 DATA intmw/1.008, &
2989                 22.990, 18.039, 35.453, 96.061, 97.069, 62.004, 18.015, &
2990                 17.031, 36.461, 63.012, 17.007, 40.078, 39.098, 24.305, 84.994,&
2991                 80.043, 58.443, 53.492, 142.041, 132.139, 120.059, 115.108, &
2992                 247.247, 136.139, 164.086, 110.984, 174.257, 136.167, 101.102, &
2993                 74.551, 120.366, 148.313, 95.211, 17.031, 63.012, 36.461 /
2994
2995       REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
2996       REAL dgacc(blksize) ! accumulation geometric mean diamet
2997       REAL dgcor(blksize)
2998       REAL dtstep
2999
3000 !intmw AERLIQ Name
3001 !       1       1       H+
3002 !       2       2       Na+
3003 !       3       3       NH4+
3004 !       4       4       Cl-
3005 !       5       5       SO42-
3006 !       6       6       HSO4-
3007 !       7       7       NO3-
3008 !       8       8       H2O
3009 !       9       9       NH3
3010 !       10      10      HCL
3011 !       11      11      HNO3
3012 !       12      12      OH-
3013 !       13      13      Ca2+
3014 !       14      14      K+
3015 !       15      15      Mg2+
3016
3017 !intmw AERSLD Name
3018 !       16      1       NaNO3
3019 !       17      2       NH4NO3
3020 !       18      3       NaCl
3021 !       19      4       NH4Cl
3022 !       20      5       Na2SO4
3023 !       21      6       (NH4)2SO4
3024 !       22      7       NaHSO4
3025 !       23      8       NH4HSO4
3026 !       24      9       (NH4)3H(SO4)2
3027 !       25      10      CaSO4
3028 !       26      11      Ca(NO3)2
3029 !       27      12      CaCl2
3030 !       28      13      K2SO4
3031 !       29      14      KHSO4
3032 !       30      15      KNO3
3033 !       31      16      KCL
3034 !       32      17      MgSO4
3035 !       33      18      Mg(NO3)2
3036 !       34      19      MgCl2
3037 !intmw GAS Name
3038 !       35      1       NH3
3039 !       36      2       HNO3
3040 !       37      3       HCL
3041
3042         character*8 date
3043         character*10 time
3044         character*5 zone
3045         integer*4  values(8)
3046
3047
3048       DO lcell = 1,numcells
3049 ! equilibrium for the fine mode.
3050 ! *** Fetch temperature, fractional relative humidity, and air density
3051         temp = blkta(lcell)
3052         rh = blkrh(lcell)
3053         RHI = DBLE(rh)
3054         TEMPI = DBLE(temp) ! Temperature (K) provided by phys
3055
3056         WI(1) = DBLE(((cblk(lcell,vnaaj)  + cblk(lcell,vnaai)) &
3057                    /22.99)*1.e-6)      ! sodium
3058
3059         WI(2) = DBLE(  &
3060                 ((cblk(lcell,vso4aj) +  cblk(lcell,vso4ai)) &
3061                          /96.061)*1.e-6)       ! sulfate
3062
3063         WI(3) = DBLE(((cblk(lcell,vnh3)/(18.039-1.)) +  &
3064                 ((cblk(lcell,vnh4aj) +  cblk(lcell,vnh4ai)) &
3065                           /18.039))*1.e-6)       ! ammoinum
3066
3067         WI(4) = DBLE(((cblk(lcell,vhno3)/(62.004+1.)) + &
3068                 ((cblk(lcell,vno3aj) +  cblk(lcell,vno3ai)) &
3069                           /62.004))*1.e-6)   ! nitrate
3070
3071         WI(5) = DBLE(((cblk(lcell,vhcl)/(35.453+1.)) +  &
3072                 ((cblk(lcell,vclaj)  + cblk(lcell,vclai)) &
3073                           /35.453))*1.e-6)     ! chloride
3074
3075         WI(6) = DBLE((cblk(lcell,vcaaj)  + cblk(lcell,vcaai)) &
3076                    /40.078*1.e-6) !calcium
3077
3078         WI(7) = DBLE((cblk(lcell,vkaj)  + cblk(lcell,vkai)) &
3079                    /39.098*1.e-6) !potassium
3080
3081         WI(8) = DBLE((cblk(lcell,vmgaj)  + cblk(lcell,vmgai)) &
3082                    /24.305*1.e-6) !magnesium
3083
3084
3085                 CNTRL(1) = DBLE(0.) ! 0=FORWARD PROBLEM, 1=REVERSE PROBLEM
3086                 CNTRL(2) = DBLE(1.) ! 0=SOLID+LIQUID AEROSOL, 1=METASTABLE
3087
3088                 CALL ISOROPIA2p1 (WI, RHI, TEMPI, CNTRL, &
3089                         WT, GAS, AERLIQ, AERSLD, SCASE, OTHER)
3090
3091 !****************************************************************************
3092
3093                         gnh3 = real(GAS(1)*DBLE(17.031)*1.D6) ! in ug/m3
3094                         anh4 = real((wt(3) - gas(1))*DBLE(18.039)*1.D6)
3095                         gno3 = real(GAS(2)*DBLE(63.012)*1.D6) ! in ug/m3
3096                         ano3 = real((wt(4) - gas(2))*DBLE(62.004)*1.D6)
3097                         ghcl = real(GAS(3)*DBLE(36.461)*1.D6) ! in ug/m3
3098                         acl = real((wt(5) - gas(3))*DBLE(35.453)*1.D6)
3099
3100                         aso4 = real(wt(2)*DBLE(96.061)*1.D6) ! in ug/m3
3101
3102                         ah2o = real(AERLIQ(8)*DBLE(18.015)*1.D6) !H2O
3103                         ana = real(wt(1)*DBLE(22.99)*1.D6)
3104                         aca = real(wt(6)*DBLE(40.078)*1.D6)
3105                         ak  = real(wt(7)*DBLE(39.098)*1.D6)
3106                         amg = real(wt(8)*DBLE(24.305)*1.D6)
3107 !****************************************************************************
3108 !****************************************************************************
3109 ! *** the following is an interim procedure. Assume the i-mode has the
3110 !     same relative mass concentrations as the total mass. Use SO4 as
3111 !     the surrogate.
3112
3113 ! *** get modal fraction
3114         fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3115         fracj = 1.0 - fraci
3116
3117 ! *** update do i-mode
3118         cblk(lcell,vso4ai) = fraci*aso4
3119
3120         cblk(lcell,vh2oai) = fraci*ah2o
3121         cblk(lcell,vnh4ai) = fraci*anh4
3122         cblk(lcell,vno3ai) = fraci*ano3
3123         cblk(lcell,vnaai) = fraci*ana
3124         cblk(lcell,vclai) = fraci*acl
3125         cblk(lcell,vcaai) = fraci*aca
3126         cblk(lcell,vkai) = fraci*ak
3127         cblk(lcell,vmgai) = fraci*amg
3128
3129 ! *** update accumulation mode:
3130         cblk(lcell,vso4aj) = fracj*aso4
3131
3132         cblk(lcell,vh2oaj) = fracj*ah2o
3133         cblk(lcell,vnh4aj) = fracj*anh4
3134         cblk(lcell,vno3aj) = fracj*ano3
3135         cblk(lcell,vnaaj) = fracj*ana
3136         cblk(lcell,vclaj) = fracj*acl
3137         cblk(lcell,vcaaj) = fracj*aca
3138         cblk(lcell,vkaj) = fracj*ak
3139         cblk(lcell,vmgaj) = fracj*amg
3140
3141 ! *** update gas / vapor phase
3142         cblk(lcell,vnh3) = gnh3
3143         cblk(lcell,vhno3) = gno3
3144         cblk(lcell,vhcl) = ghcl
3145 !        cblk(lcell,vsulf) = epsilc
3146 !end threatment for the equilibrium for fine mode.
3147 !**************************************************************************************
3148       END DO !  end loop on cells
3149
3150       RETURN
3151
3152     END SUBROUTINE eql3
3153 !liqy-20140709
3154
3155
3156     SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
3157 !***********************************************************************
3158 !**    DESCRIPTION:
3159 !       Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
3160 !       and water between the gas and aerosol phases as the total sulfate,
3161 !       ammonia, and nitrate concentrations, relative humidity and
3162 !       temperature change.  The evolution of the aerosol mass concentration
3163 !       due to the change in aerosol chemical composition is calculated.
3164 !**    REVISION HISTORY:
3165 !       prototype 1/95 by Uma and Carlie
3166 !       Revised   8/95 by US to calculate air density in stmt func
3167 !                 and collect met variable stmt funcs in one include fil
3168 !       Revised 7/26/96 by FSB to use block concept.
3169 !       Revise 12/1896 to do do i-mode calculation.
3170 !**********************************************************************
3171 !     IMPLICIT NONE
3172
3173 ! dimension of arrays
3174       INTEGER blksize
3175 ! actual number of cells in arrays
3176       INTEGER numcells
3177 ! nmber of species in CBLK
3178       INTEGER nspcsda
3179       REAL cblk(blksize,nspcsda)
3180 ! *** Meteorological information in blocked arays:
3181
3182 ! main array of variables
3183       REAL blkta(blksize) ! Air temperature [ K ]
3184       REAL blkrh(blksize)
3185
3186 ! Fractional relative humidity
3187
3188       INTEGER lcell
3189 ! loop counter
3190 ! air temperature
3191       REAL temp
3192 !iamodels3
3193       REAL rh
3194 ! relative humidity
3195       REAL so4, no3, nh3, nh4, hno3
3196       REAL aso4, ano3, ah2o, anh4, gnh3, gno3
3197 ! Fraction of dry sulfate mass in i-mode
3198       REAL fraci
3199 !.......................................................................
3200       REAL fracj
3201 ! Fraction of dry sulfate mass in j-mode
3202       DO lcell = 1, &
3203           numcells
3204 ! *** Fetch temperature, fractional relative humidity, and
3205 !     air density
3206
3207 !  loop on cells
3208         temp = blkta(lcell)
3209         rh = blkrh(lcell)
3210
3211 ! *** the following is an interim procedure. Assume the i-mode has the
3212 !     same relative mass concentrations as the total mass. Use SO4 as
3213 !     the surrogate. The results of this should be the same as those
3214 !     from the original RPM.
3215
3216 ! *** do total aerosol
3217         so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
3218
3219 !iamodels3
3220         no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
3221 !    &                        + CBLK(LCELL, VHNO3)
3222
3223         hno3 = cblk(lcell,vhno3)
3224
3225 !iamodels3
3226
3227         nh3 = cblk(lcell,vnh3)
3228
3229         nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
3230 !    &                        + CBLK(LCELL, VNH3)
3231
3232 !bs           CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
3233 !bs     &             ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
3234 !bs
3235 !bs * call old version of rpmares
3236 !bs
3237         CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
3238           gnh3,gno3)
3239 !bs
3240
3241 ! *** get modal fraction
3242         fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3243         fracj = 1.0 - fraci
3244
3245 ! *** update do i-mode
3246
3247         cblk(lcell,vh2oai) = fraci*ah2o
3248         cblk(lcell,vnh4ai) = fraci*anh4
3249         cblk(lcell,vno3ai) = fraci*ano3
3250
3251 ! *** update accumulation mode:
3252
3253         cblk(lcell,vh2oaj) = fracj*ah2o
3254         cblk(lcell,vnh4aj) = fracj*anh4
3255         cblk(lcell,vno3aj) = fracj*ano3
3256
3257
3258 ! *** update gas / vapor phase
3259         cblk(lcell,vnh3) = gnh3
3260         cblk(lcell,vhno3) = gno3
3261
3262       END DO
3263 !  end loop on cells
3264       RETURN
3265
3266 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3267     END SUBROUTINE eql4
3268 ! eql4
3269
3270     SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
3271 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3272 !bs                                                                    !
3273 !bs  Description:                                                      !
3274 !bs                                                                    !
3275 !bs  Get the Jacobian of the function                                  !
3276 !bs                                                                    !
3277 !bs         ( a1 * X1^2 + b1 * X1 + c1 )                               !
3278 !bs         ( a2 * X2^2 + b2 * X1 + c2 )                               !
3279 !bs         ( a3 * X3^2 + b3 * X1 + c3 )                               !
3280 !bs  F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0.                          !
3281 !bs         ( a5 * X5^2 + b5 * X1 + c5 )                               !
3282 !bs         ( a6 * X6^2 + b6 * X1 + c6 )                               !
3283 !bs                                                                    !
3284 !bs   a_i = IMW_i                                                      !
3285 !bs   b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i  !
3286 !bs   c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ]                 !
3287 !bs                                                                    !
3288 !bs          delta F_i    ( 2. * a_i * X_i + b_i           if i .EQ. j !
3289 !bs  J_ij = ----------- = (                                            !
3290 !bs          delta X_j    ( X_i * IMW_j - CTOT_i * IMW_j   if i .NE. j !
3291 !bs                                                                    !
3292 !bs                                                                    !
3293 !bs  Called by:       NEWT                                             !
3294 !bs                                                                    !
3295 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3296 !bs
3297 !     IMPLICIT NONE
3298 !bs
3299 !bs
3300 !dimension of problem
3301       INTEGER n
3302       REAL x(n) !bs
3303 !     INTEGER NP                !bs maximum expected value of N
3304 !     PARAMETER (NP = 6)
3305 !bs initial guess of CAER
3306       REAL ct(np)
3307       REAL cs(np)
3308       REAL imw(np)
3309 !bs
3310       REAL fjac(n,n)
3311 !bs
3312       INTEGER i, & !bs loop index
3313         j
3314       REAL a(np)
3315       REAL b(np)
3316       REAL b1(np)
3317       REAL b2(np)
3318       REAL sum_jnei
3319 !bs
3320       DO i = 1, n
3321         a(i) = imw(i)
3322         sum_jnei = 0.
3323         DO j = 1, n
3324           sum_jnei = sum_jnei + x(j)*imw(j)
3325         END DO
3326         b1(i) = sum_jnei - (x(i)*imw(i))
3327         b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
3328         b(i) = b1(i) + b2(i)
3329       END DO
3330       DO j = 1, n
3331         DO i = 1, n
3332           IF (i==j) THEN
3333             fjac(i,j) = 2.*a(i)*x(i) + b(i)
3334           ELSE
3335             fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
3336           END IF
3337         END DO
3338       END DO
3339 !bs
3340       RETURN
3341     END SUBROUTINE fdjac
3342 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3343     FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
3344 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3345 !bs                                                                    !
3346 !bs  Description:                                                      !
3347 !bs                                                                    !
3348 !bs  Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed.   !
3349 !bs                                                                    !
3350 !bs  Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name,      !
3351 !bs  user-supplied routine that returns the vector of functions at X.  !
3352 !bs  The common block NEWTV communicates the function values back to   !
3353 !bs  NEWT.                                                             !
3354 !bs                                                                    !
3355 !bs  Called by:       NEWT                                             !
3356 !bs                                                                    !
3357 !bs  Calls:           FUNCV                                            !
3358 !bs                                                                    !
3359 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3360
3361 !     IMPLICIT NONE
3362
3363 !bs
3364 !bs
3365       INTEGER n
3366 !     INTEGER NP
3367 !     PARAMETER (NP = 6)
3368       REAL ct(np)
3369       REAL cs(np)
3370       REAL imw(np)
3371       REAL m,fmin
3372       REAL x(*), fvec(np)
3373
3374       INTEGER i
3375       REAL sum
3376
3377       CALL funcv(n,x,fvec,ct,cs,imw,m)
3378       sum = 0.
3379       DO i = 1, n
3380         sum = sum + fvec(i)**2
3381       END DO
3382       fmin = 0.5*sum
3383       RETURN
3384     END FUNCTION fmin
3385 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3386     SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
3387 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3388 !bs                                                                    !
3389 !bs  Description:                                                      !
3390 !bs                                                                    !
3391 !bs  Called by:       FMIN                                             !
3392 !bs                                                                    !
3393 !bs  Calls:           None                                             !
3394 !bs                                                                    !
3395 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3396 !bs
3397 !     IMPLICIT NONE
3398 !bs
3399 !bs
3400       INTEGER n
3401       REAL x(*)
3402       REAL fvec(n)
3403 !bs
3404 !     INTEGER NP
3405 !     PARAMETER (NP = 6)
3406       REAL ct(np)
3407       REAL cs(np)
3408       REAL imw(np)
3409       REAL m
3410 !bs
3411       INTEGER i, j
3412       REAL sum_jnei
3413       REAL a(np)
3414       REAL b(np)
3415       REAL c(np)
3416 !bs
3417       DO i = 1, n
3418         a(i) = imw(i)
3419         sum_jnei = 0.
3420         DO j = 1, n
3421           sum_jnei = sum_jnei + x(j)*imw(j)
3422         END DO
3423         sum_jnei = sum_jnei - (x(i)*imw(i))
3424         b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
3425         c(i) = -ct(i)*(sum_jnei+m)
3426         fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
3427       END DO
3428 !bs
3429       RETURN
3430     END SUBROUTINE funcv
3431     REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
3432 ! *** set up new processor for renaming of particles from i to j modes
3433 !     IMPLICIT NONE
3434       REAL aa, bb, cc, disc, qq, alfa, l, yji
3435       REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
3436
3437       alfa = xlsgi/xlsgj
3438       yji = log(dgnj/dgni)/(sqrt2*xlsgi)
3439       aa = 1.0 - alfa*alfa
3440       l = log(alfa*nj/ni)
3441       bb = 2.0*yji*alfa*alfa
3442       cc = l - yji*yji*alfa*alfa
3443       disc = bb*bb - 4.0*aa*cc
3444       IF (disc<0.0) THEN
3445         getaf = - & ! error in intersection
3446           5.0
3447         RETURN
3448       END IF
3449       qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3450       getaf = cc/qq
3451       RETURN
3452 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3453     END FUNCTION getaf
3454 !     Parameterization for sulfuric acid/water
3455 !     nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3456 !     April 20, 1998.
3457
3458 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3459 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3460
3461 !ia      subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3462 ! getaf
3463     SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3464 !     IMPLICIT NONE
3465
3466 ! *** Input:
3467
3468 ! ambient temperature [ K ]
3469       REAL temp
3470 ! fractional relative humidity
3471       REAL rh
3472 ! sulfuric acid concentration [ ug / m**3 ]
3473       REAL h2so4
3474
3475       REAL so4rat
3476 ! *** Output:
3477
3478 !sulfuric acid production rate [ ug / ( m**3 s )]
3479 ! particle number production rate [ # / ( m**3 s )]
3480       REAL ndot1
3481 ! particle mass production rate [ ug / ( m**3 s )]
3482       REAL mdot1
3483                  ! [ m**2 / ( m**3 s )]
3484       REAL m2dot
3485
3486 ! *** Internal:
3487
3488 ! *** NOTE, all units are cgs internally.
3489 ! particle second moment production rate
3490
3491       REAL ra
3492 ! fractional relative acidity
3493 ! sulfuric acid vaper concentration [ cm ** -3 ]
3494       REAL nav
3495 ! water vapor concentration   [ cm ** -3 ]
3496       REAL nwv
3497 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3498       REAL nav0
3499                 ! to produce a nucleation rate of 1 [ cm ** -3  s ** -1
3500       REAL nac
3501 ! critical sulfuric acid vapor concentration [ cm ** -3
3502 ! mole fractio of the critical nucleus
3503       REAL xal
3504       REAL nsulf, & ! see usage
3505         delta
3506       REAL*8 & ! factor to calculate Jnuc
3507         chi
3508       REAL*8 &
3509         jnuc
3510 ! nucleation rate [ cm ** -3  s ** -1 ]
3511       REAL tt, & ! dummy variables for statement functions
3512         rr
3513       REAL pi
3514       PARAMETER (pi=3.14159265)
3515
3516       REAL pid6
3517       PARAMETER (pid6=pi/6.0)
3518
3519 ! avogadro's constant [ 1/mol ]
3520       REAL avo
3521       PARAMETER (avo=6.0221367E23)
3522
3523 ! universal gas constant [ j/mol-k ]
3524       REAL rgasuniv
3525       PARAMETER (rgasuniv=8.314510)
3526
3527 ! 1 atmosphere in pascals
3528       REAL atm
3529       PARAMETER (atm=1013.25E+02)
3530
3531 ! formula weight for h2so4 [ g mole **-1 ]
3532       REAL mwh2so4
3533       PARAMETER (mwh2so4=98.07948)
3534
3535 ! diameter of a 3.5 nm particle in cm
3536       REAL d35
3537       PARAMETER (d35=3.5E-07)
3538       REAL d35sq
3539       PARAMETER (d35sq=d35*d35)
3540 ! volume of a 3.5 nm particle in cm**3
3541       REAL v35
3542       PARAMETER (v35=pid6*d35*d35sq)
3543 !ia rev01
3544
3545       REAL mp
3546 ! ***  conversion factors:
3547 ! mass of sulfate in a 3.5 nm particle
3548                      ! number per cubic cm.
3549       REAL ugm3_ncm3
3550 ! micrograms per cubic meter to
3551       PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3552 !ia rev01
3553 ! molecules to micrograms
3554       REAL nc_ug
3555       PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3556
3557 ! *** statement functions **************
3558
3559       REAL pdens, &
3560         rho_p
3561 ! particle density [ g / cm**3]
3562       REAL ad0, ad1, ad2, &
3563         ad3
3564 ! coefficients for density expression
3565       PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3566 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3567 !     as a function of relative humidity,
3568 !     J. Aerosol Science, 6, pp 265-271, 1975.
3569
3570 !ia rev01
3571
3572 ! fit to Nair & Vohra data
3573                 ! the mass of sulfate in a 3.5 nm particle
3574       REAL mp35
3575 ! arithmetic statement function to compute
3576       REAL a0, a1, a2, & ! coefficients for cubic in mp35
3577         a3
3578       PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3579
3580       REAL ph2so4, &                         ! for h2so4 and h2o vapor pressures [ Pa ]
3581         ph2o
3582
3583 ! arithmetic statement functions
3584       pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3585
3586       ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3587
3588       ph2so4(tt) = exp(27.78492066-10156.0/tt)
3589
3590 ! *** both ph2o and ph2so4 are  as in Kulmala et al.  paper
3591
3592 !ia rev01
3593
3594 ! *** function for the mass of sulfate in   a 3.5 nm sphere
3595 ! *** obtained from a fit to the number of sulfate monomers in
3596 !     a 3.5 nm particle. Uses data from Nair & Vohra
3597       mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3598
3599 ! *** begin code:
3600
3601 !     The 1.0e-6 factor in the following converts from MKS to cgs units
3602
3603 ! *** get water vapor concentration [ molecles / cm **3 ]
3604
3605       nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3606
3607 ! *** calculate the equilibrium h2so4 vapor concentration.
3608
3609 ! *** use Kulmala corrections:
3610
3611 ! ***
3612       nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3613
3614 ! *** convert sulfuric acid vapor concentration from micrograms
3615 !     per cubic meter to molecules per cubic centimeter.
3616
3617       nav = ugm3_ncm3*h2so4
3618
3619 ! *** calculate critical concentration of sulfuric acid vapor
3620
3621       nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3622
3623 ! *** calculate relative acidity
3624
3625       ra = nav/nav0
3626
3627 ! *** calculate temperature correction
3628
3629       delta = 1.0 + (temp-273.15)/273.14
3630
3631 ! *** calculate molar fraction
3632
3633       xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3634         0.0016*temp
3635
3636 ! *** calculate Nsulf
3637       nsulf = log(nav/nac)
3638
3639 ! *** calculate particle produtcion rate [ # / cm**3 ]
3640
3641       chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3642         2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3643
3644       jnuc = exp(chi)
3645 ! [ # / cm**3 ]
3646       ndot1 = (1.0E06)*jnuc
3647 !      write(91,*) ' inside klpnuc '
3648 !     write(91,*) ' Jnuc = ', Jnuc
3649 !     write(91,*) ' NDOT = ', NDOT1
3650
3651 ! *** calculate particle density
3652
3653       rho_p = pdens(rh)
3654
3655 !     write(91,*) ' rho_p =', rho_p
3656
3657 ! *** get the mass of sulfate in a 3.5 nm particle
3658
3659       mp = mp35(rh)                      ! in a 3.5 nm particle at ambient RH
3660
3661 ! *** calculate mass production rate [ ug / m**3]
3662 !     assume that the particles are 3.5 nm in diameter.
3663
3664 !     MDOT1 =  (1.0E12) * rho_p * v35 * Jnuc
3665
3666 !ia rev01
3667
3668 ! number of micrograms of sulfate
3669       mdot1 = mp*ndot1
3670
3671 !ia rev02
3672
3673       IF (mdot1>so4rat) THEN
3674
3675         mdot1 = &
3676           so4rat
3677 ! limit nucleated mass by available ma
3678         ndot1 = mdot1/ &
3679           mp
3680 ! adjust DNDT to this
3681       END IF
3682
3683       IF (mdot1==0.) ndot1 = 0.
3684
3685 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3686
3687       m2dot = 1.0E-04*d35sq*ndot1
3688
3689       RETURN
3690
3691 END SUBROUTINE klpnuc
3692 !------------------------------------------------------------------------------
3693
3694  SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3695         pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3696         knacc,kncor)
3697
3698 !**    DESCRIPTION:
3699 !       Calculates modal parameters and derived variables,
3700 !       log-squared of std deviation, mode mean size, Knudsen number)
3701 !       based on current values of moments for the modes.
3702 ! FSB   Now calculates the 3rd moment, mass, and density in all 3 modes.
3703 !**
3704 !**    Revision history:
3705 !       Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3706 !       Revised  7/23/96 by FSB to use COMMON blocks and small blocks
3707 !        instead of large 3-d arrays, and to assume a fixed std.
3708 !       Revised 12/06/96 by FSB to include coarse mode
3709 !       Revised 1/10/97 by FSB to have arrays passed in call vector
3710 !**********************************************************************
3711
3712 !     IMPLICIT NONE
3713
3714 !     Includes:
3715
3716 ! *** input:
3717
3718 ! dimension of arrays
3719       INTEGER blksize
3720 ! actual number of cells in arrays
3721       INTEGER numcells
3722
3723       INTEGER nspcsda
3724
3725 ! nmber of species in CBLK
3726       REAL cblk(blksize,nspcsda) ! main array of variables
3727       REAL blkta(blksize) ! Air temperature [ K ]
3728       REAL blkprs(blksize)
3729 ! *** output:
3730
3731 ! Air pressure in [ Pa ]
3732 ! concentration lower limit [ ug/m*
3733 ! lowest particle diameter ( m )
3734       REAL dgmin
3735       PARAMETER (dgmin=1.0E-09)
3736
3737 ! lowest particle density ( Kg/m**3
3738       REAL densmin
3739       PARAMETER (densmin=1.0E03)
3740
3741       REAL pmassn(blksize) ! mass concentration in nuclei mode
3742       REAL pmassa(blksize) ! mass concentration in accumulation
3743       REAL pmassc(blksize) ! mass concentration in coarse mode
3744       REAL pdensn(blksize) ! average particel density in Aitken
3745       REAL pdensa(blksize) ! average particel density in accumu
3746       REAL pdensc(blksize) ! average particel density in coarse
3747       REAL xlm(blksize) ! atmospheric mean free path [ m]
3748       REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3749       REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3750       REAL dgacc(blksize) ! accumulation
3751       REAL dgcor(blksize) ! coarse mode
3752       REAL knnuc(blksize) ! Aitken mode Knudsen number
3753       REAL knacc(blksize) ! accumulation
3754       REAL kncor(blksize)
3755
3756 ! coarse mode
3757
3758       INTEGER lcell
3759 !      WRITE(20,*) ' IN MODPAR '
3760
3761 ! *** set up  aerosol  3rd moment, mass, density
3762
3763 ! loop counter
3764       DO lcell = 1, numcells
3765
3766 ! *** Aitken-mode
3767 !        cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3768         cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3769           vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3770           vh2oai)+no3fac*cblk(lcell,vno3ai)+                   &
3771           nafac*cblk(lcell,vnaai)+  clfac*cblk(lcell,vclai)+   &
3772 !liqy
3773                   cafac*cblk(lcell,vcaai)+  kfac*cblk(lcell,vkai) + &
3774                   mgfac*cblk(lcell,vmgai)+ &
3775 !liqy-20140616
3776           orgfac*cblk(lcell, &
3777           vasoa1i)+orgfac*cblk(lcell,vasoa2i)+orgfac*cblk(lcell, &
3778           vasoa3i)+orgfac*cblk(lcell,vasoa4i)+orgfac*cblk(lcell, &
3779           vbsoa1i)+orgfac*cblk(lcell,vbsoa2i)+orgfac*cblk(lcell, &
3780           vbsoa3i)+orgfac*cblk(lcell,vbsoa4i)+orgfac*cblk(lcell, &
3781           vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
3782 !          vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan
3783
3784 ! *** Accumulation-mode
3785 !        cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3786         cblk(lcell,vac3) = so4fac*cblk(lcell, &
3787           vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
3788           vh2oaj)+no3fac*cblk(lcell,vno3aj) +                  &
3789           nafac*cblk(lcell,vnaaj)+  clfac*cblk(lcell,vclaj)+   &
3790 !liqy
3791                   cafac*cblk(lcell,vcaaj)+  kfac*cblk(lcell,vkaj) + &
3792                   mgfac*cblk(lcell,vmgaj)+ &
3793 !liqy-20140616
3794           orgfac*cblk(lcell, &
3795           vasoa1j)+orgfac*cblk(lcell,vasoa2j)+orgfac*cblk(lcell, &
3796           vasoa3j)+orgfac*cblk(lcell,vasoa4j)+orgfac*cblk(lcell, &
3797           vbsoa1j)+orgfac*cblk(lcell,vbsoa2j)+orgfac*cblk(lcell, &
3798           vbsoa3j)+orgfac*cblk(lcell,vbsoa4j)+orgfac*cblk(lcell, &
3799           vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
3800 !          vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan
3801
3802 ! *** coarse mode
3803 !        cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
3804 !          vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
3805
3806         cblk(lcell,vcor3) = soilfac*cblk(lcell, &
3807           vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
3808
3809 ! *** now get particle mass and density
3810
3811 ! *** Aitken-mode:
3812         pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
3813           vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
3814           vasoa1i)+cblk(lcell,vasoa2i)+cblk(lcell,vasoa3i)+cblk(lcell, &
3815           vasoa4i)+cblk(lcell,vbsoa1i)+cblk(lcell,vbsoa2i)+cblk(lcell, &
3816           vbsoa3i)+cblk(lcell,vbsoa4i)+cblk(lcell,vorgpai)+cblk(lcell, &
3817 !          vp25ai)+cblk(lcell,veci)))
3818 !liqy
3819           vp25ai)+cblk(lcell,veci)+cblk(lcell,vcaai)+cblk(lcell,vkai) &
3820                   +cblk(lcell,vmgai)))
3821 !liqy-20140616
3822
3823 ! *** Accumulation-mode:
3824         pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
3825           vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
3826           vasoa1j)+cblk(lcell,vasoa2j)+cblk(lcell,vasoa3j)+cblk(lcell, &
3827           vasoa4j)+cblk(lcell,vbsoa1j)+cblk(lcell,vbsoa2j)+cblk(lcell, &
3828           vbsoa3j)+cblk(lcell,vbsoa4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
3829 !          vp25aj)+cblk(lcell,vecj)))
3830 !liqy
3831           vp25aj)+cblk(lcell,vecj)+cblk(lcell,vcaaj)+cblk(lcell,vkaj) &
3832                   +cblk(lcell,vmgaj)))
3833 !liqy-20140616
3834 ! *** coarse mode:
3835         pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
3836           lcell,vantha))
3837
3838       END DO
3839 ! *** now get particle density, mean free path, and dynamic viscosity
3840
3841 ! aerosol  3rd moment and  mass
3842       DO lcell = 1, &
3843           numcells
3844 ! *** density in [ kg m**-3 ]
3845
3846 ! Density and mean free path
3847         pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
3848         pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
3849         pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
3850
3851 ! *** Calculate mean free path [ m ]:
3852         xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
3853
3854 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
3855 ! *** on page 10 of U.S. Standard Atmosphere 1962
3856
3857 ! ***   Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
3858
3859 ! *** U.S. Standard Atmosphere 1962 page 14 expression
3860 !     for dynamic viscosity is:
3861 !     dynamic viscosity =  beta * T * sqrt(T) / ( T + S)
3862 !     where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
3863
3864       amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
3865           (blkta(lcell)+110.4)
3866
3867       END DO
3868 !...............   Standard deviation fixed in both modes, so
3869 !...............   diagnose diameter from 3rd moment and number concentr
3870
3871 !  density and mean free path
3872       DO lcell = 1, &
3873           numcells
3874
3875 ! calculate diameters
3876         dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
3877           one3)
3878
3879         dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
3880           one3)
3881
3882         dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
3883           **one3)
3884
3885 ! when running with cloudborne aerosol, apply some very mild bounding
3886 ! to avoid unrealistic dg values
3887       if (cw_phase > 0) then
3888         dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2  )  !  > 0.002 um
3889         dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 )  !  < 0.10  um
3890         dgacc(lcell) = max( dgacc(lcell), dginia*0.2  )  !  > 0.014 um
3891         dgacc(lcell) = min( dgacc(lcell), dginia*10.0 )  !  < 0.7 um
3892         dgcor(lcell) = max( dgcor(lcell), dginic*0.2  )  !  > 0.2 um
3893         dgcor(lcell) = min( dgcor(lcell), dginic*10.0 )  ! < 10.0 um
3894       end if
3895
3896       END DO
3897 ! end loop on diameters
3898       DO lcell = 1, &
3899           numcells
3900 ! Calculate Knudsen numbers
3901         knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
3902
3903         knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
3904
3905         kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
3906
3907       END DO
3908
3909 ! end loop for  Knudsen numbers
3910       RETURN
3911
3912 END SUBROUTINE modpar
3913 !------------------------------------------------------------------------------
3914
3915 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
3916         blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
3917         orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
3918         fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
3919
3920 !***********************************************************************
3921 !**    DESCRIPTION:  calculates aerosol nucleation and condensational
3922 !**    growth rates using Binkowski and Shankar (1995) method.
3923
3924 ! *** In this version, the method od RPM is followed where
3925 !     the diffusivity, the average molecular ve3locity, and
3926 !     the accomodation coefficient for sulfuric acid are used for
3927 !     the organics. This is for consistency.
3928 !       Future versions will use the correct values.  FSB 12/12/96
3929
3930
3931 !**
3932 !**    Revision history:
3933 !       prototype 1/95 by Uma and Carlie
3934 !       Corrected 7/95 by Uma for condensation of mass not nucleated
3935 !       and mass conservation check
3936 !       Revised   8/95 by US to calculate air density in stmt function
3937 !                 and collect met variable stmt funcs in one include fil
3938 !       Revised 7/25/96 by FSB to use block structure.
3939 !       Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
3940 !       Revised 11/15/96 by FSB to use MKS,  and mom m^-3 units.
3941 !       Revised 1/13/97 by FSB to pass arrays and simplify code.
3942 !       Added   23/03/99 by BS growth factors for organics
3943 !**********************************************************************
3944 !     IMPLICIT NONE
3945
3946 !     Includes:
3947 ! *** arguments
3948
3949 ! *** input;
3950 !USE module_configure, only: grid_config_rec_type
3951 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
3952
3953
3954 ! dimension of arrays
3955       INTEGER blksize
3956       INTEGER layer
3957 ! number of species in CBLK
3958       INTEGER nspcsda
3959 ! actual number of cells in arrays
3960       INTEGER numcells
3961       INTEGER igrid,jgrid,kgrid
3962
3963       INTEGER ldrog_vbs
3964 ! # of organic aerosol precursor
3965       REAL cblk(blksize,nspcsda) ! main array of variables
3966 ! model time step in  SECONDS
3967       REAL dt
3968       REAL blkta(blksize) ! Air temperature [ K ]
3969       REAL blkprs(blksize) ! Air pressure in [ Pa ]
3970       REAL blkrh(blksize) ! Fractional relative humidity
3971       REAL so4rat(blksize) ! rate [  ug/m**3 /s ]
3972       REAL brrto
3973 !bs
3974 ! sulfate gas-phase production
3975 ! total # of cond. vapors & SOA spe
3976       INTEGER ncv
3977 !bs
3978       INTEGER nacv
3979 !bs * anthropogenic organic condensable vapor production rate
3980 ! # of anthrop. cond. vapors & SOA
3981       REAL drog(blksize,ldrog_vbs) !bs
3982 ! Delta ROG conc. [ppm]
3983
3984 ! anthropogenic vapor production rates
3985 REAL organt1rat(blksize)
3986 REAL organt2rat(blksize)
3987 REAL organt3rat(blksize)
3988 REAL organt4rat(blksize)
3989
3990 ! biogenic vapor production rates
3991 REAL orgbio1rat(blksize)
3992 REAL orgbio2rat(blksize)
3993 REAL orgbio3rat(blksize)
3994 REAL orgbio4rat(blksize)
3995
3996 ! biogenic organic aerosol production
3997       REAL dgnuc(blksize) ! accumulation
3998       REAL dgacc(blksize)
3999 ! *** output:
4000
4001 ! coarse mode
4002       REAL fconcn(blksize)                                 ! Aitken mode  [ 1 / s ]
4003 ! reciprocal condensation rate
4004       REAL fconca(blksize)                                 ! acclumulation mode [ 1 / s ]
4005 ! reciprocal condensation rate
4006       REAL fconcn_org(blksize)                                 ! Aitken mode  [ 1 / s ]
4007 ! reciprocal condensation rate
4008       REAL fconca_org(blksize)                                 ! acclumulation mode [ 1 / s ]
4009 ! reciprocal condensation rate
4010       REAL dmdt(blksize)                                 ! by particle formation [ ug/m**3 /s ]
4011 ! rate of production of new mass concent
4012       REAL dndt(blksize)                                 ! concentration by particle formation [#
4013 ! rate of producton of new particle numb
4014       REAL deltaso4a(blksize)                                 ! sulfate aerosol by condensation [ ug/m
4015 ! increment of concentration added to
4016       REAL cgrn3(blksize)                                 ! Aitken mode [ 3rd mom/m **3 s ]
4017 ! growth rate for 3rd moment for
4018       REAL cgra3(blksize)                                 ! Accumulation mode
4019
4020 !...........    SCRATCH local variables and their descriptions:
4021
4022 ! growth rate for 3rd moment for
4023
4024       INTEGER lcell
4025
4026 ! LOOP INDEX
4027 ! conv rate so2 --> so4 [mom-3/g/s]
4028       REAL chemrat
4029 ! conv rate for organics [mom-3/g/s]
4030       REAL chemrat_org
4031       REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
4032         am1a
4033       REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
4034         am2a
4035       REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
4036         gnc3a
4037       REAL gfm3n, & ! free-mol  fns (nuc, acc) for mom-3 den
4038         gfm3a
4039 ! total reciprocal condensation rate
4040       REAL fconc
4041
4042       REAL td
4043 ! d * tinf (cgs)
4044       REAL*8 & ! Cnstant to force 64 bit evaluation of
4045         one88
4046       PARAMETER (one88=1.0D0)
4047 !  *** variables to set up sulfate and organic condensation rates
4048
4049 ! sulfuric acid vapor at current time step
4050       REAL vapor1
4051 !                                    chemistry and emissions
4052       REAL vapor2
4053 ! Sulfuric acid vapor prior to addition from
4054 !bs
4055       REAL deltavap
4056 !bs * start update
4057 !bs
4058 ! change to vapor at previous time step
4059       REAL diffcorr
4060
4061 !bs *
4062       REAL csqt_org
4063 !bs * end update
4064 !bs
4065       REAL csqt
4066 !.......................................................................
4067 !   begin body of subroutine  NUCLCOND
4068
4069
4070 !...........   Main computational grid-traversal loop nest
4071 !...........   for computing condensation and nucleation:
4072
4073       DO lcell = 1, &
4074           numcells
4075 ! *** First moment:
4076
4077 !  1st loop over NUMCELLS
4078         am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
4079         am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
4080
4081 !..............   near-continuum factors [ 1 / sec ]
4082 !bs
4083 !bs * adopted from code of FSB
4084 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
4085 !bs
4086         diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
4087 !bs
4088         gnc3n = cconc*am1n*diffcorr
4089         gnc3a = cconc*am1a*diffcorr
4090
4091 ! *** Second moment:
4092
4093         am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
4094         am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
4095
4096         csqt = ccofm*sqrt(blkta(lcell))
4097 !...............   free molecular factors [ 1 / sec ]
4098
4099 ! put in temperature fac
4100         gfm3n = csqt*am2n
4101         gfm3a = csqt*am2a
4102
4103 ! *** Condensation factors in [ s**-1] for h2so4
4104 ! *** In the future, separate factors for condensing organics will
4105 !      be included. In this version, the h2so4 values are used.
4106
4107 !...............   Twice the harmonic mean of fm, nc functions:
4108 ! *** Force 64 bit evaluation:
4109
4110         fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4111         fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4112         fconc = fconcn(lcell) + fconca(lcell)
4113
4114 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
4115 !bs
4116 !bs * start modifications for organcis
4117 !bs
4118         gnc3n = cconc_org*am1n*diffcorr
4119         gnc3a = cconc_org*am1a*diffcorr
4120 !bs
4121         csqt_org = ccofm_org*sqrt(blkta(lcell))
4122         gfm3n = csqt_org*am2n
4123         gfm3a = csqt_org*am2a
4124 !bs
4125         fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4126         fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4127 !bs
4128 !bs * end modifications for organics
4129 !bs
4130 ! *** calculate the total change to sulfuric acid vapor from production
4131 !                      and condensation
4132
4133         vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
4134         vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
4135           dt
4136 ! vapor at prev
4137         vapor2 = max(0.0,vapor2)
4138         deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
4139
4140 ! *** Calculate increment in total sufate aerosol mass concentration
4141
4142 ! *** This follows the method of Youngblood & Kreidenweis.!bs
4143 !bs        DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
4144 !bs
4145 !bs * allow DELTASO4A to be negative, but the change must not be larger
4146 !bs * than the amount of vapor available.
4147 !bs
4148         deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
4149           so4rat(lcell)*dt-deltavap)
4150
4151 ! *** zero out growth coefficients
4152         cgrn3(lcell) = 0.0
4153         cgra3(lcell) = 0.0
4154
4155       END DO
4156
4157 ! *** Select method of nucleation
4158 ! End 1st loop over NUMCELLS
4159       IF (inucl==1) THEN
4160
4161 ! *** Do Youngblood & Kreidenweis  Nucleation
4162
4163 !         CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4164 !     &        DNDT,DMDT,NUMCELLS,BLKSIZE,
4165 !     &        VAPOR1)
4166 !       IF (firstime) THEN
4167 !         WRITE (6,*)
4168 !         WRITE (6,'(a,i2)') 'INUCL =', inucl
4169 !         WRITE (90,'(a,i2)') 'INUCL =', inucl
4170 !         firstime = .FALSE.
4171 !       END IF
4172
4173       ELSE IF (inucl==0) THEN
4174
4175 ! *** Do Kerminen & Wexler Nucleation
4176
4177 !         CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4178 !     &        DNDT,DMDT,NUMCELLS,BLKSIZE)
4179 !       IF (firstime) THEN
4180 !         WRITE (6,*)
4181 !         WRITE (6,'(a,i2)') 'INUCL =', inucl
4182 !         WRITE (90,'(a,i2)') 'INUCL =', inucl
4183 !         firstime = .FALSE.
4184 !       END IF
4185
4186       ELSE IF (inucl==2) THEN
4187
4188 !bs ** Do Kulmala et al. Nucleation
4189 !       if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
4190
4191         if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
4192            CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4193         else
4194            dndt(1)=0.
4195            dmdt(1)=0.
4196         endif
4197
4198 !       CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4199 !       if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
4200         IF (dndt(1)==0.) dmdt(1) = 0.
4201         IF (dmdt(1)==0.) dndt(1) = 0.
4202 !       IF (firstime) THEN
4203 !         WRITE (6,*)
4204 !         WRITE (6,'(a,i2)') 'INUCL =', inucl
4205 !         WRITE (90,'(a,i2)') 'INUCL =', inucl
4206 !         firstime = .FALSE.
4207 !       END IF
4208 !     ELSE
4209 !       WRITE (6,'(a)') '*************************************'
4210 !       WRITE (6,'(a,i2,a)') '  INUCL =', inucl, ',  PLEASE CHECK !!'
4211 !       WRITE (6,'(a)') '        PROGRAM TERMINATED !!'
4212 !       WRITE (6,'(a)') '*************************************'
4213 !       STOP
4214
4215       END IF
4216 !bs
4217 !bs * Secondary organic aerosol module (SOA_VBS)
4218 !bs
4219 ! end of selection of nucleation method
4220
4221       CALL soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
4222         organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
4223         nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto )
4224 !bs
4225 !bs *  Secondary organic aerosol module (SOA_VBS)
4226 !bs
4227       DO lcell = 1, numcells
4228
4229 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
4230 !     condensation factors
4231
4232         td = 1.0/(fconcn(lcell)+fconca(lcell))
4233         fconcn(lcell) = td*fconcn(lcell)
4234         fconca(lcell) = td*fconca(lcell)
4235 !bs
4236         td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
4237         fconcn_org(lcell) = td*fconcn_org(lcell)
4238         fconca_org(lcell) = td*fconca_org(lcell)
4239 !bs
4240       END DO
4241
4242 ! ***  Begin second loop over cells
4243
4244       DO lcell = 1,numcells
4245 ! *** note CHEMRAT includes  species other than sulfate.
4246
4247 ! 3rd loop on NUMCELLS
4248         chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
4249         chemrat_org = orgfac*(organt1rat(lcell)+organt2rat(lcell)+organt3rat( &
4250           lcell)+organt4rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
4251           orgbio3rat(lcell)+orgbio4rat(lcell))
4252
4253 ! *** Calculate the production rates for new particle
4254 ! [mom3 m**-3 s-
4255         cgrn3(lcell) = so4fac*dmdt(lcell)
4256 ! Rate of increase of 3rd
4257         chemrat = chemrat - cgrn3(lcell)                                            !bs 3rd moment production fro
4258
4259 !bs Remove the rate of new pa
4260         chemrat = max(chemrat,0.0)
4261 ! *** Now calculate the rate of condensation on existing particles.
4262
4263 ! Prevent CHEMRAT from being negativ
4264         cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
4265           chemrat_org*fconcn_org(lcell)
4266         cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
4267 ! ***
4268       END DO
4269 !  end 2nd loop over NUMCELLS
4270       RETURN
4271
4272     END SUBROUTINE nuclcond
4273 !------------------------------------------------------------------------------
4274
4275 ! nuclcond
4276 REAL FUNCTION poly4(a,x)
4277   REAL a(4), x
4278
4279   poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
4280   RETURN
4281 END FUNCTION poly4
4282 REAL FUNCTION poly6(a,x)
4283   REAL a(6), x
4284
4285   poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
4286   RETURN
4287 END FUNCTION poly6
4288 !-----------------------------------------------------------------------
4289
4290 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
4291     gnh3,gno3)
4292 ! Description:
4293
4294 !   ARES calculates the chemical composition of a sulfate/nitrate/
4295 !   ammonium/water aerosol based on equilibrium thermodynamics.
4296
4297 !   This code considers two regimes depending upon the molar ratio
4298 !   of ammonium to sulfate.
4299
4300 !   For values of this ratio less than 2,the code solves a cubic for
4301 !   hydrogen ion molality, HPLUS,  and if enough ammonium and liquid
4302 !   water are present calculates the dissolved nitric acid. For molal
4303 !   ionic strengths greater than 50, nitrate is assumed not to be present
4304
4305 !   For values of the molar ratio of 2 or greater, all sulfate is assumed
4306 !   to be ammonium sulfate and a calculation is made for the presence of
4307 !   ammonium nitrate.
4308
4309 !   The Pitzer multicomponent approach is used in subroutine ACTCOF to
4310 !   obtain the activity coefficients. Abandoned -7/30/97 FSB
4311
4312 !   The Bromley method of calculating the activity coefficients is used in this version
4313
4314 !   The calculation of liquid water is done in subroutine water. Details for both calculations are given
4315 !   in the respective subroutines.
4316
4317 !   Based upon MARS due to
4318 !   P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
4319 !   Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
4320
4321 !   and SCAPE due to
4322 !   Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
4323 !   Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
4324
4325 ! NOTE: All concentrations supplied to this subroutine are TOTAL
4326 !       over gas and aerosol phases
4327
4328 ! Parameters:
4329
4330 !  SO4   : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
4331 !  HNO3  : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
4332 !  NO3   : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
4333 !  NH3   : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
4334 !  NH4   : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
4335 !  RH    : Fractional relative humidity (IN)
4336 !  TEMP  : Temperature in Kelvin (IN)
4337 !  GNO3  : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
4338 !  GNH3  : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
4339 !  ASO4  : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
4340 !  ANO3  : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
4341 !  ANH4  : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
4342 !  AH2O  : Aerosol phase water in MICROGRAMS/M**3 (OUT)
4343 !  NITR  : Number of iterations for obtaining activity coefficients  (OU
4344 !  NR    : Number of real roots to the cubic in the low ammonia case (OU
4345
4346 ! Revision History:
4347 !      Who       When        Detailed description of changes
4348 !   ---------   --------  -------------------------------------------
4349 !   S.Roselle   11/10/87  Received the first version of the MARS code
4350 !   S.Roselle   12/30/87  Restructured code
4351 !   S.Roselle   2/12/88   Made correction to compute liquid-phase
4352 !                         concentration of H2O2.
4353 !   S.Roselle   5/26/88   Made correction as advised by SAI, for
4354 !                         computing H+ concentration.
4355 !   S.Roselle   3/1/89    Modified to operate with EM2
4356 !   S.Roselle   5/19/89   Changed the maximum ionic strength from
4357 !                         100 to 20, for numerical stability.
4358 !   F.Binkowski 3/3/91    Incorporate new method for ammonia rich case
4359 !                         using equations for nitrate budget.
4360 !   F.Binkowski 6/18/91   New ammonia poor case which
4361 !                         omits letovicite.
4362 !   F.Binkowski 7/25/91   Rearranged entire code, restructured
4363 !                         ammonia poor case.
4364 !   F.Binkowski 9/9/91    Reconciled all cases of ASO4 to be output
4365 !                         as SO4--
4366 !   F.Binkowski 12/6/91   Changed the ammonia defficient case so that
4367 !                         there is only neutralized sulfate (ammonium
4368 !                         sulfate) and sulfuric acid.
4369 !   F.Binkowski 3/5/92    Set RH bound on AWAS to 37 % to be in agreemen
4370 !                          with the Cohen et al. (1987)  maximum molalit
4371 !                          of 36.2 in Table III.( J. Phys Chem (91) page
4372 !                          4569, and Table IV p 4587.)
4373 !   F.Binkowski 3/9/92    Redid logic for ammonia defficient case to rem
4374 !                         possibility for denomenator becoming zero;
4375 !                         this involved solving for HPLUS first.
4376 !                         Note that for a relative humidity
4377 !                          less than 50%, the model assumes that there i
4378 !                          aerosol nitrate.
4379 !   F.Binkowski 4/17/95   Code renamed  ARES (AeRosol Equilibrium System
4380 !                          Redid logic as follows
4381 !                         1. Water algorithm now follows Spann & Richard
4382 !                         2. Pitzer Multicomponent method used
4383 !                         3. Multicomponent practical osmotic coefficien
4384 !                            use to close iterations.
4385 !                         4. The model now assumes that for a water
4386 !                            mass fraction WFRAC less than 50% there is
4387 !                            no aerosol nitrate.
4388 !   F.Binkowski 7/20/95   Changed how nitrate is calculated in ammonia p
4389 !                         case, and changed the WFRAC criterion to 40%.
4390 !                         For ammonium to sulfate ratio less than 1.0
4391 !                         all ammonium is aerosol and no nitrate aerosol
4392 !                         exists.
4393 !   F.Binkowski 7/21/95   Changed ammonia-ammonium in ammonia poor case
4394 !                         allow gas-phase ammonia to exist.
4395 !   F.Binkowski 7/26/95   Changed equilibrium constants to values from
4396 !                         Kim et al. (1993)
4397 !   F.Binkowski 6/27/96   Changed to new water format
4398 !   F.Binkowski 7/30/97   Changed to Bromley method for multicomponent
4399 !                         activity coefficients. The binary activity coe
4400 !                         are the same as the previous version
4401 !   F.Binkowski 8/1/97    Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
4402 !                         1 picogram per cubic meter
4403
4404 !-----------------------------------------------------------------------
4405 !     IMPLICIT NONE
4406 !...........INCLUDES and their descriptions
4407 !cc      INCLUDE SUBST_CONST          ! constants
4408 !...........PARAMETERS and their descriptions:
4409
4410 ! molecular weight for NaCl
4411       REAL mwnacl
4412       PARAMETER (mwnacl=58.44277)
4413
4414 ! molecular weight for NO3
4415       REAL mwno3
4416       PARAMETER (mwno3=62.0049)
4417
4418 ! molecular weight for HNO3
4419       REAL mwhno3
4420       PARAMETER (mwhno3=63.01287)
4421
4422 ! molecular weight for SO4
4423       REAL mwso4
4424       PARAMETER (mwso4=96.0576)
4425
4426 ! molecular weight for HSO4
4427       REAL mwhso4
4428       PARAMETER (mwhso4=mwso4+1.0080)
4429
4430 ! molecular weight for H2SO4
4431       REAL mh2so4
4432       PARAMETER (mh2so4=98.07354)
4433
4434 ! molecular weight for NH3
4435       REAL mwnh3
4436       PARAMETER (mwnh3=17.03061)
4437
4438 ! molecular weight for NH4
4439       REAL mwnh4
4440       PARAMETER (mwnh4=18.03858)
4441
4442 ! molecular weight for Organic Species
4443       REAL mworg
4444       PARAMETER (mworg=16.0)
4445
4446 ! molecular weight for Chloride
4447       REAL mwcl
4448       PARAMETER (mwcl=35.453)
4449
4450 ! molecular weight for AIR
4451       REAL mwair
4452       PARAMETER (mwair=28.964)
4453
4454 ! molecular weight for Letovicite
4455       REAL mwlct
4456       PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4457
4458 ! molecular weight for Ammonium Sulfa
4459       REAL mwas
4460       PARAMETER (mwas=2.0*mwnh4+mwso4)
4461
4462 ! molecular weight for Ammonium Bisul
4463       REAL mwabs
4464       PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4465
4466 !...........ARGUMENTS and their descriptions
4467
4468 !iamodels3
4469       REAL so4
4470 ! Total sulfate in micrograms / m**3
4471 ! Total nitric acid in micrograms / m
4472       REAL hno3
4473 ! Total nitrate in micrograms / m**3
4474       REAL no3
4475 ! Total ammonia in micrograms / m**3
4476       REAL nh3
4477 ! Total ammonium in micrograms / m**3
4478       REAL nh4
4479 ! Fractional relative humidity
4480       REAL rh
4481 ! Temperature in Kelvin
4482       REAL temp
4483 ! Aerosol sulfate in micrograms / m**
4484       REAL aso4
4485 ! Aerosol nitrate in micrograms / m**
4486       REAL ano3
4487 ! Aerosol liquid water content water
4488       REAL ah2o
4489 ! Aerosol ammonium in micrograms / m*
4490       REAL anh4
4491 ! Gas-phase nitric acid in micrograms
4492       REAL gno3
4493       REAL gnh3
4494 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4495
4496 ! Gas-phase ammonia in micrograms / m
4497 ! Index set to percent relative humid
4498       INTEGER irh
4499 ! Number of iterations for activity c
4500       INTEGER nitr
4501 ! Loop index for iterations
4502       INTEGER nnn
4503       INTEGER nr
4504 ! Number of roots to cubic equation f
4505       REAL*8 & ! Coefficients and roots of
4506         a0
4507       REAL*8 & ! Coefficients and roots of
4508         a1
4509       REAL*8 & ! Coefficients and roots of
4510         a2
4511 ! Coefficients and discriminant for q
4512       REAL aa
4513 ! internal variables ( high ammonia c
4514       REAL bal
4515 ! Coefficients and discriminant for q
4516       REAL bb
4517 ! Variables used for ammonia solubili
4518       REAL bhat
4519 ! Coefficients and discriminant for q
4520       REAL cc
4521 ! Factor for conversion of units
4522       REAL convt
4523 ! Coefficients and discriminant for q
4524       REAL dd
4525 ! Coefficients and discriminant for q
4526       REAL disc
4527 ! Relative error used for convergence
4528       REAL eror
4529 !  Free ammonia concentration , that
4530       REAL fnh3
4531 ! Activity Coefficient for (NH4+, HSO
4532       REAL gamaab
4533 ! Activity coefficient for (NH4+, NO3
4534       REAL gamaan
4535 ! Variables used for ammonia solubili
4536       REAL gamahat
4537 ! Activity coefficient for (H+ ,NO3-)
4538       REAL gamana
4539 ! Activity coefficient for (2H+, SO4-
4540       REAL gamas1
4541 ! Activity coefficient for (H+, HSO4-
4542       REAL gamas2
4543 ! used for convergence of iteration
4544       REAL gamold
4545 ! internal variables ( high ammonia c
4546       REAL gasqd
4547 ! Hydrogen ion (low ammonia case) (mo
4548       REAL hplus
4549 ! Equilibrium constant for ammoniua t
4550       REAL k1a
4551 ! Equilibrium constant for sulfate-bi
4552       REAL k2sa
4553 ! Dissociation constant for ammonium
4554       REAL k3
4555 ! Equilibrium constant for ammonium n
4556       REAL kan
4557 ! Variables used for ammonia solubili
4558       REAL khat
4559 ! Equilibrium constant for nitric aci
4560       REAL kna
4561 ! Henry's Law Constant for ammonia
4562       REAL kph
4563 ! Equilibrium constant for water diss
4564       REAL kw
4565 ! Internal variable using KAN
4566       REAL kw2
4567 ! Nitrate (high ammonia case) (moles
4568       REAL man
4569 ! Sulfate (high ammonia case) (moles
4570       REAL mas
4571 ! Bisulfate (low ammonia case) (moles
4572       REAL mhso4
4573 ! Nitrate (low ammonia case) (moles /
4574       REAL mna
4575 ! Ammonium (moles / kg water)
4576       REAL mnh4
4577 ! Total number of moles of all ions
4578       REAL molnu
4579 ! Sulfate (low ammonia case) (moles /
4580       REAL mso4
4581 ! Practical osmotic coefficient
4582       REAL phibar
4583 ! Previous value of practical osmotic
4584       REAL phiold
4585 ! Molar ratio of ammonium to sulfate
4586       REAL ratio
4587 ! Internal variable using K2SA
4588       REAL rk2sa
4589 ! Internal variables using KNA
4590       REAL rkna
4591 ! Internal variables using KNA
4592       REAL rknwet
4593       REAL rr1
4594       REAL rr2
4595 ! Ionic strength
4596       REAL stion
4597 ! Internal variables for temperature
4598       REAL t1
4599 ! Internal variables for temperature
4600       REAL t2
4601 ! Internal variables of convenience (
4602       REAL t21
4603 ! Internal variables of convenience (
4604       REAL t221
4605 ! Internal variables for temperature
4606       REAL t3
4607 ! Internal variables for temperature
4608       REAL t4
4609 ! Internal variables for temperature
4610       REAL t6
4611 ! Total ammonia and ammonium in micro
4612       REAL tnh4
4613 ! Total nitrate in micromoles / meter
4614       REAL tno3
4615 ! Tolerances for convergence test
4616       REAL toler1
4617 ! Tolerances for convergence test
4618       REAL toler2
4619 ! Total sulfate in micromoles / meter
4620       REAL tso4
4621 ! 2.0 * TSO4  (high ammonia case) (mo
4622       REAL twoso4
4623 ! Water mass fraction
4624       REAL wfrac
4625                                    ! micrograms / meter **3 on output
4626       REAL wh2o
4627                                    ! internally it is 10 ** (-6) kg (wat
4628                                    ! the conversion factor (1000 g = 1 k
4629                                    ! for AH2O output
4630 ! Aerosol liquid water content (inter
4631 ! internal variables ( high ammonia c
4632       REAL wsqd
4633 ! Nitrate aerosol concentration in mi
4634       REAL xno3
4635 ! Variable used in quadratic solution
4636       REAL xxq
4637 ! Ammonium aerosol concentration in m
4638       REAL ynh4
4639 ! Water variable saved in case ionic
4640       REAL zh2o
4641
4642       REAL zso4
4643 ! Total sulfate molality - mso4 + mhs
4644       REAL cat(2) ! Array for cations (1, H+); (2, NH4+
4645       REAL an(3) ! Array for anions (1, SO4--); (2, NO
4646       REAL crutes(3) ! Coefficients and roots of
4647       REAL gams(2,3) ! Array of activity coefficients
4648 ! Minimum value of sulfate laerosol c
4649       REAL minso4
4650       PARAMETER (minso4=1.0E-6/mwso4)
4651       REAL floor
4652       PARAMETER (floor=1.0E-30)
4653 !-----------------------------------------------------------------------
4654 !  begin body of subroutine RPMARES
4655
4656 !...convert into micromoles/m**3
4657 !cc      WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
4658 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
4659 ! minimum concentration
4660       tso4 = max(0.0,so4/mwso4)
4661       tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
4662       tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
4663 !cc      WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
4664
4665 !...now set humidity index IRH as a percent
4666
4667       irh = nint(100.0*rh)
4668
4669 !...Check for valid IRH
4670
4671       irh = max(1,irh)
4672       irh = min(99,irh)
4673 !cc      WRITE(10,*)'RH,IRH ',RH,IRH
4674
4675 !...Specify the equilibrium constants at  correct
4676 !...  temperature.  Also change units from ATM to MICROMOLE/M**3 (for KA
4677 !...  KPH, and K3 )
4678 !...  Values from Kim et al. (1993) except as noted.
4679
4680       convt = 1.0/(0.082*temp)
4681       t6 = 0.082E-9*temp
4682       t1 = 298.0/temp
4683       t2 = alog(t1)
4684       t3 = t1 - 1.0
4685       t4 = 1.0 + t2 - t1
4686       kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
4687       k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
4688       k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
4689       kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
4690       kph = 57.639*exp(13.79*t3-5.39*t4)*t6
4691 !cc      K3   =  5.746E-17 * EXP( -74.38 * T3 + 6.12  * T4 ) * T6 * T6
4692       khat = kph*k1a/kw
4693       kan = kna*khat
4694
4695 !...Compute temperature dependent equilibrium constant for NH4NO3
4696 !...  ( from Mozurkewich, 1993)
4697       k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
4698
4699 !...Convert to (micromoles/m**3) **2
4700       k3 = k3*convt*convt
4701       wh2o = 0.0
4702       stion = 0.0
4703       ah2o = 0.0
4704       mas = 0.0
4705       man = 0.0
4706       hplus = 0.0
4707       toler1 = 0.00001
4708       toler2 = 0.001
4709       nitr = 0
4710       nr = 0
4711       ratio = 0.0
4712       gamaan = 1.0
4713       gamold = 1.0
4714
4715 !...set the ratio according to the amount of sulfate and nitrate
4716       IF (tso4>minso4) THEN
4717         ratio = tnh4/tso4
4718
4719 !...If there is no sulfate and no nitrate, there can be no ammonium
4720 !...  under the current paradigm. Organics are ignored in this version.
4721
4722       ELSE
4723
4724         IF (tno3==0.0) THEN
4725
4726 ! *** If there is very little sulfate and no nitrate set concentrations
4727 !      to a very small value and return.
4728           aso4 = max(floor,aso4)
4729           ano3 = max(floor,ano3)
4730           wh2o = 0.0
4731           ah2o = 0.0
4732           gnh3 = max(floor,gnh3)
4733           gno3 = max(floor,gno3)
4734           RETURN
4735         END IF
4736
4737 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
4738 !...  to send the code to the high ammonia case
4739
4740         ratio = 5.0
4741       END IF
4742
4743 !....................................
4744 !......... High Ammonia Case ........
4745 !....................................
4746
4747       IF (ratio>2.0) THEN
4748
4749         gamaan = 0.1
4750
4751 !...Set up twice the sulfate for future use.
4752
4753         twoso4 = 2.0*tso4
4754         xno3 = 0.0
4755         ynh4 = twoso4
4756
4757 !...Treat different regimes of relative humidity
4758
4759 !...ZSR relationship is used to set water levels. Units are
4760 !...  10**(-6) kg water/ (cubic meter of air)
4761 !...  start with ammomium sulfate solution without nitrate
4762
4763         CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
4764         wh2o = 1.0E-3*ah2o
4765         aso4 = tso4*mwso4
4766         ano3 = 0.0
4767         anh4 = ynh4*mwnh4
4768         wfrac = ah2o/(aso4+anh4+ah2o)
4769 !cc        IF ( WFRAC .EQ. 0.0 )  RETURN   ! No water
4770         IF (wfrac<0.2) THEN
4771
4772 !... dry  ammonium sulfate and ammonium nitrate
4773 !...  compute free ammonia
4774
4775           fnh3 = tnh4 - twoso4
4776           cc = tno3*fnh3 - k3
4777
4778 !...check for not enough to support aerosol
4779
4780           IF (cc<=0.0) THEN
4781             xno3 = 0.0
4782           ELSE
4783             aa = 1.0
4784             bb = -(tno3+fnh3)
4785             disc = bb*bb - 4.0*cc
4786
4787 !...Check for complex roots of the quadratic
4788 !...  set nitrate to zero and RETURN if complex roots are found
4789
4790           IF (disc<0.0) THEN
4791             xno3 = 0.0
4792             ah2o = 1000.0*wh2o
4793             ynh4 = twoso4
4794             gno3 = tno3*mwhno3
4795             gnh3 = (tnh4-ynh4)*mwnh3
4796             aso4 = tso4*mwso4
4797             ano3 = 0.0
4798             anh4 = ynh4*mwnh4
4799             RETURN
4800           END IF
4801
4802 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
4803
4804             dd = sqrt(disc)
4805             xxq = -0.5*(bb+sign(1.0,bb)*dd)
4806
4807 !...Since both roots are positive, select smaller root.
4808
4809             xno3 = min(xxq/aa,cc/xxq)
4810
4811           END IF
4812           ah2o = 1000.0*wh2o
4813           ynh4 = 2.0*tso4 + xno3
4814           gno3 = (tno3-xno3)*mwhno3
4815           gnh3 = (tnh4-ynh4)*mwnh3
4816           aso4 = tso4*mwso4
4817           ano3 = xno3*mwno3
4818           anh4 = ynh4*mwnh4
4819           RETURN
4820
4821         END IF
4822
4823 !...liquid phase containing completely neutralized sulfate and
4824 !...  some nitrate.  Solve for composition and quantity.
4825
4826         mas = tso4/wh2o
4827         man = 0.0
4828         xno3 = 0.0
4829         ynh4 = twoso4
4830         phiold = 1.0
4831
4832 !...Start loop for iteration
4833
4834 !...The assumption here is that all sulfate is ammonium sulfate,
4835 !...  and is supersaturated at lower relative humidities.
4836
4837         DO nnn = 1, 150
4838           nitr = nnn
4839           gasqd = gamaan*gamaan
4840           wsqd = wh2o*wh2o
4841           kw2 = kan*wsqd/gasqd
4842           aa = 1.0 - kw2
4843           bb = twoso4 + kw2*(tno3+tnh4-twoso4)
4844           cc = -kw2*tno3*(tnh4-twoso4)
4845
4846 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
4847
4848           disc = bb*bb - 4.0*aa*cc
4849
4850 !...Check for complex roots, if so set nitrate to zero and RETURN
4851
4852           IF (disc<0.0) THEN
4853             xno3 = 0.0
4854             ah2o = 1000.0*wh2o
4855             ynh4 = twoso4
4856             gno3 = tno3*mwhno3
4857             gnh3 = (tnh4-ynh4)*mwnh3
4858             aso4 = tso4*mwso4
4859             ano3 = 0.0
4860             anh4 = ynh4*mwnh4
4861 !cc            WRITE( 10, * ) ' COMPLEX ROOTS '
4862             RETURN
4863           END IF
4864
4865           dd = sqrt(disc)
4866           xxq = -0.5*(bb+sign(1.0,bb)*dd)
4867           rr1 = xxq/aa
4868           rr2 = cc/xxq
4869
4870 !...Check for two non-positive roots, if so set nitrate to zero and RETURN
4871           IF (rr1 <= 0.0 .AND. rr2 <= 0.0) THEN
4872             xno3 = 0.0
4873             ah2o = 1000.0*wh2o
4874             ynh4 = twoso4
4875             gno3 = tno3*mwhno3
4876             gnh3 = (tnh4-ynh4)*mwnh3
4877             aso4 = tso4*mwso4
4878             ano3 = 0.0
4879             anh4 = ynh4*mwnh4
4880 !            WRITE(*,*) 'TWO NON-POSITIVE ROOTS!!! '
4881             RETURN
4882           END IF
4883
4884 !...choose minimum positve root
4885
4886           IF ((rr1*rr2)<0.0) THEN
4887             xno3 = max(rr1,rr2)
4888           ELSE
4889             xno3 = min(rr1,rr2)
4890           END IF
4891           xno3 = min(xno3,tno3)
4892
4893 !...This version assumes no solid sulfate forms (supersaturated )
4894 !...  Now update water
4895
4896           CALL awater(irh,tso4,ynh4,xno3,ah2o)
4897
4898 !...ZSR relationship is used to set water levels. Units are
4899 !...  10**(-6) kg water/ (cubic meter of air)
4900 !...  The conversion from micromoles to moles is done by the units of WH
4901
4902           wh2o = 1.0E-3*ah2o
4903
4904 !...Ionic balance determines the ammonium in solution.
4905
4906           man = xno3/wh2o
4907           mas = tso4/wh2o
4908           mnh4 = 2.0*mas + man
4909           ynh4 = mnh4*wh2o
4910
4911 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
4912 !...  and ammonium in molal units (moles/(kg water) ).
4913
4914           stion = 3.0*mas + man
4915           cat(1) = 0.0
4916           cat(2) = mnh4
4917           an(1) = mas
4918           an(2) = man
4919           an(3) = 0.0
4920           CALL actcof(cat,an,gams,molnu,phibar)
4921           gamaan = gams(2,2)
4922
4923 !...Use GAMAAN for convergence control
4924
4925           eror = abs(gamold-gamaan)/gamold
4926           gamold = gamaan
4927
4928 !...Check to see if we have a solution
4929
4930           IF (eror<=toler1) THEN
4931 !cc            WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
4932 !cc     &      GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
4933
4934             aso4 = tso4*mwso4
4935             ano3 = xno3*mwno3
4936             anh4 = ynh4*mwnh4
4937             gno3 = (tno3-xno3)*mwhno3
4938             gnh3 = (tnh4-ynh4)*mwnh3
4939             ah2o = 1000.0*wh2o
4940             RETURN
4941           END IF
4942
4943         END DO
4944
4945 !...If after NITR iterations no solution is found, then:
4946
4947         aso4 = tso4*mwso4
4948         ano3 = 0.0
4949         ynh4 = twoso4
4950         anh4 = ynh4*mwnh4
4951         CALL awater(irh,tso4,ynh4,xno3,ah2o)
4952         gno3 = tno3*mwhno3
4953         gnh3 = (tnh4-ynh4)*mwnh3
4954         RETURN
4955
4956       ELSE
4957 !......................................
4958 !......... Low Ammonia Case ...........
4959 !......................................
4960
4961 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
4962
4963 !...All cases covered by this logic
4964         wh2o = 0.0
4965         CALL awater(irh,tso4,tnh4,tno3,ah2o)
4966         wh2o = 1.0E-3*ah2o
4967         zh2o = ah2o
4968 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4969 !...  per cubic meter of air (1000 g = 1 kg)
4970
4971         aso4 = tso4*mwso4
4972         anh4 = tnh4*mwnh4
4973         ano3 = 0.0
4974         gno3 = tno3*mwhno3
4975         gnh3 = 0.0
4976
4977 !...Check for zero water.
4978         IF (wh2o==0.0) RETURN
4979         zso4 = tso4/wh2o
4980
4981 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
4982
4983 !cc         IF ( ZSO4 .GT. 11.0 ) THEN
4984
4985 !...do not solve for aerosol nitrate for total sulfate molality
4986 !...  greater than 11.0 because the model parameters break down
4987 !...  greater than  9.0 because the model parameters break down
4988
4989         IF (zso4>9.0) & ! 18 June 97
4990             THEN
4991           RETURN
4992         END IF
4993
4994 !...First solve with activity coeffs of 1.0, then iterate.
4995         phiold = 1.0
4996         gamana = 1.0
4997         gamas1 = 1.0
4998         gamas2 = 1.0
4999         gamaab = 1.0
5000         gamold = 1.0
5001
5002 !...All ammonia is considered to be aerosol ammonium.
5003         mnh4 = tnh4/wh2o
5004
5005 !...MNH4 is the molality of ammonium ion.
5006         ynh4 = tnh4
5007
5008 !...loop for iteration
5009         DO nnn = 1, 150
5010           nitr = nnn
5011
5012 !...set up equilibrium constants including activities
5013 !...  solve the system for hplus first then sulfate & nitrate
5014 !          print*,'gamas,gamana',gamas1,gamas2,gamana
5015           rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
5016           rkna = kna/(gamana*gamana)
5017           rknwet = rkna*wh2o
5018           t21 = zso4 - mnh4
5019           t221 = zso4 + t21
5020
5021 !...set up coefficients for cubic
5022
5023           a2 = rk2sa + rknwet - t21
5024           a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
5025           a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
5026
5027           CALL cubic(a2,a1,a0,nr,crutes)
5028
5029 !...Code assumes the smallest positive root is in CRUTES(1)
5030
5031           hplus = crutes(1)
5032           bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
5033           mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
5034           mhso4 = zso4 - & ! molality of bisulf
5035             mso4
5036           mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
5037           mna = max(0.0,mna)
5038           mna = min(mna,tno3/wh2o)
5039           xno3 = mna*wh2o
5040           ano3 = mna*wh2o*mwno3
5041           gno3 = (tno3-xno3)*mwhno3
5042
5043 !...Calculate ionic strength
5044           stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
5045
5046 !...Update water
5047           CALL awater(irh,tso4,ynh4,xno3,ah2o)
5048
5049 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
5050 !...  per cubic meter of air (1000 g = 1 kg)
5051
5052           wh2o = 1.0E-3*ah2o
5053           cat(1) = hplus
5054           cat(2) = mnh4
5055           an(1) = mso4
5056           an(2) = mna
5057           an(3) = mhso4
5058 !          print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
5059           CALL actcof(cat,an,gams,molnu,phibar)
5060
5061           gamana = gams(1,2)
5062           gamas1 = gams(1,1)
5063           gamas2 = gams(1,3)
5064           gamaan = gams(2,2)
5065
5066           gamahat = (gamas2*gamas2/(gamaab*gamaab))
5067           bhat = khat*gamahat
5068 !cc          EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
5069 !cc          PHIOLD = PHIBAR
5070           eror = abs(gamold-gamahat)/gamold
5071           gamold = gamahat
5072
5073 !...write out molalities and activity coefficient
5074 !...  and return with good solution
5075
5076           IF (eror<=toler2) THEN
5077 !cc            WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
5078 !cc            WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
5079 !cc     &                  GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
5080             RETURN
5081           END IF
5082
5083         END DO
5084
5085 !...after NITR iterations, failure to solve the system, no ANO3
5086
5087         gno3 = tno3*mwhno3
5088         ano3 = 0.0
5089         CALL awater(irh,tso4,tnh4,tno3,ah2o)
5090         RETURN
5091
5092       END IF
5093 ! ratio .gt. 2.0
5094 END SUBROUTINE rpmares_old
5095
5096 !ia*********************************************************
5097 !ia                                                        *
5098 !ia BEGIN OF AEROSOL ROUTINE                               *
5099 !ia                                                        *
5100 !ia*********************************************************
5101
5102 !***********************************************************************
5103 !       BEGIN OF AEROSOL CALCULATIONS
5104 !***********************************************************************
5105 !ia                                                                     *
5106 !ia     MAIN AEROSOL DYNAMICS ROUTINE                                   *
5107 !ia     based on MODELS3 formulation by FZB                             *
5108 !ia     Modified by IA in May 97                                        *
5109 !ia     THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
5110 !ia     CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
5111 !ia     VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
5112 !ia     CALCULATIONS.
5113 !ia     INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
5114 !ia     ONE GRID CELL!!!!
5115 !ia     and passed to dynamics calcs. subroutines.
5116 !ia                                                                     *
5117 !ia     Revision history                                                *
5118 !ia     When    WHO     WHAT                                            *
5119 !ia     ----    ----    ----                                            *
5120 !ia     ????    FZB     BEGIN                                           *
5121 !ia     05/97   IA      Adapted for use in CTM2-S                       *
5122 !ia                     Modified renaming/bug fixing                    *
5123 !ia     11/97   IA      Modified for new model version
5124 !ia                     see comments under iarev02
5125 !ia     03/98   IA      corrected error on pressure units
5126 !ia                                                                     *
5127 !ia     Called BY:      CHEM                                            *
5128 !ia                                                                     *
5129 !ia     Calls to:       OUTPUT1,AEROPRC                                 *
5130 !ia                                                                     *
5131 !ia*********************************************************************
5132
5133 ! end RPMares
5134 ! convapr_in is removed, it wasn't used indeed
5135     SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
5136         nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv, &
5137         nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,    &
5138         soilrat_in,cblk,igrid,jgrid,kgrid,brrto,do_isorropia)
5139
5140 !USE module_configure, only: grid_config_rec_type
5141 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
5142
5143 !     IMPLICIT NONE
5144
5145 !     Includes:
5146 !iarev02       INCLUDE  AEROINCL.EXT
5147 ! block size, set to 1 in column model  ciarev0
5148       INTEGER blksize
5149 !ia                       kept to 1 in current version of column model
5150 ! actual number of cells in arrays ( default is
5151       INTEGER, PARAMETER  :: numcells=1
5152
5153       INTEGER layer
5154 ! number of layer (default is 1 in
5155
5156 ! index for cell in blocked array (default is 1 in
5157       INTEGER, PARAMETER :: ncell=1
5158 ! *** inputs
5159 ! Input temperature [ K ]
5160       REAL temp
5161 ! Input relative humidity  [ fraction ]
5162       REAL relhum
5163 ! Input pressure [ hPa ]
5164       REAL pres
5165 ! Input number for Aitken mode [ m**-3 ]
5166       REAL numnuc_in
5167 ! Input number for accumulation mode [ m**-3 ]
5168       REAL numacc_in
5169 ! Input number for coarse mode  [ m**-3 ]
5170       REAL numcor_in
5171                          ! sulfuric acid [ ug m**-3 ]
5172       REAL vsulf_in
5173 ! total sulfate vapor as sulfuric acid as
5174                          ! sulfuric acid [ ug m**-3 ]
5175       REAL asulf_in
5176 ! total sulfate aerosol as sulfuric acid as
5177 ! i-mode sulfate input as sulfuric acid [ ug m*
5178       REAL asulfi_in
5179 ! ammonia gas [  ug m**-3 ]
5180       REAL nh3_in
5181 ! input value of nitric acid vapor [ ug m**-3 ]
5182       REAL nitrate_in
5183 ! Production rate of sulfuric acid   [ ug m**-3
5184       REAL so4rat_in
5185                          ! aerosol [ ug m**-3 s**-1 ]
5186       REAL soilrat_in
5187 ! Production rate of soil derived coarse
5188 ! Emission rate of i-mode EC [ug m**-3 s**-1]
5189       REAL eeci_in
5190 ! Emission rate of j-mode EC [ug m**-3 s**-1]
5191       REAL eecj_in
5192 ! Emission rate of j-mode org. aerosol [ug m**-
5193       REAL eorgi_in
5194       REAL eorgj_in
5195 ! Emission rate of j-mode org. aerosol [ug m**-
5196 ! total # of cond. vapors & SOA species
5197       INTEGER ncv
5198 ! # of anthrop. cond. vapors & SOA speci
5199       INTEGER nacv
5200 ! # of organic aerosol precursor
5201       INTEGER ldrog_vbs
5202       REAL drog_in(ldrog_vbs)                                 ! organic aerosol precursor [ppm]
5203 ! Input delta ROG concentration of
5204       REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
5205       REAL drog(blksize,ldrog_vbs)                                 ! organic aerosol precursor [ppm]
5206
5207       REAL brrto
5208       LOGICAL do_isorropia
5209 !bs
5210 ! *** Primary emissions rates: [ ug / m**3 s ]
5211
5212 ! *** emissions rates for unidentified PM2.5 mass
5213 ! Delta ROG concentration of
5214       REAL epm25i(blksize) ! Aitken mode
5215       REAL epm25j(blksize)
5216 ! *** emissions rates for primary organic aerosol
5217 ! Accumululaton mode
5218       REAL eorgi(blksize) ! Aitken mode
5219       REAL eorgj(blksize)
5220 ! *** emissions rates for elemental carbon
5221 ! Accumululaton mode
5222       REAL eeci(blksize) ! Aitken mode
5223       REAL eecj(blksize)
5224 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
5225
5226 ! Accumululaton mode
5227       REAL epm25(blksize) ! emissions rate for PM2.5 mass
5228       REAL esoil(blksize) ! emissions rate for soil derived coarse a
5229       REAL eseas(blksize) ! emissions rate for marine coarse aerosol
5230       REAL epmcoarse(blksize)
5231 ! emissions rate for anthropogenic coarse
5232
5233       REAL dtsec
5234 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
5235
5236       REAL newm3
5237       REAL totaersulf
5238 ! total aerosol sulfate
5239 ! loop index for time steps
5240       INTEGER numsteps
5241       REAL step
5242
5243 ! *** arrays for aerosol model codes:
5244
5245 ! synchronization time  [s]
5246
5247       INTEGER nspcsda
5248
5249 ! number of species in CBLK ciarev02
5250       REAL cblk(blksize,nspcsda)
5251
5252 ! *** Meteorological information in blocked arays:
5253
5254 ! *** Thermodynamic variables:
5255
5256 ! main array of variables
5257       REAL blkta(blksize) ! Air temperature [ K ]
5258       REAL blkprs(blksize) ! Air pressure in [ Pa ]
5259       REAL blkdens(blksize) ! Air density  [ kg m^-3 ]
5260       REAL blkrh(blksize)
5261
5262 ! *** Chemical production rates [ ug m**-3 s -1 ] :
5263
5264 ! Fractional relative humidity
5265       REAL so4rat(blksize)                                 ! rate [ug/m^3/s]
5266 ! sulfuric acid vapor-phase production
5267       REAL organt1rat(blksize)                                 ! production rate from aromatics [ ug /
5268 ! anthropogenic organic aerosol mass
5269       REAL organt2rat(blksize)                                 ! production rate from aromatics [ ug /
5270 ! anthropogenic organic aerosol mass
5271       REAL organt3rat(blksize)                                 ! rate from alkanes & others [ ug / m^3
5272 ! anthropogenic organic aerosol mass pro
5273       REAL organt4rat(blksize)                                 ! rate from alkanes & others [ ug / m^3
5274 ! anthropogenic organic aerosol mass pro
5275       REAL orgbio1rat(blksize)                                 ! rate [ ug / m^3 s ]
5276 ! biogenic organic aerosol production
5277       REAL orgbio2rat(blksize)                                 ! rate [ ug / m^3 s ]
5278 ! biogenic organic aerosol production
5279       REAL orgbio3rat(blksize)                                 ! rate [ ug / m^3 s ]
5280 ! biogenic organic aerosol production
5281       REAL orgbio4rat(blksize)                                 ! rate [ ug / m^3 s ]
5282 !bs
5283 ! *** atmospheric properties
5284
5285 ! biogenic organic aerosol production
5286       REAL xlm(blksize) ! atmospheric mean free path [ m ]
5287       REAL amu(blksize)
5288 ! *** aerosol properties:
5289
5290 ! *** modal diameters:
5291
5292 ! atmospheric dynamic viscosity [ kg
5293       REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
5294       REAL dgacc(blksize) ! accumulation geometric mean diamet
5295       REAL dgcor(blksize)
5296
5297 ! *** Modal mass concentrations [ ug m**3 ]
5298
5299 ! coarse mode geometric mean diamete
5300       REAL pmassn(blksize) ! mass concentration in Aitken mode
5301       REAL pmassa(blksize) ! mass concentration in accumulation
5302       REAL pmassc(blksize)
5303 ! *** average modal particle densities  [ kg/m**3 ]
5304
5305 ! mass concentration in coarse mode
5306       REAL pdensn(blksize) ! average particle density in nuclei
5307       REAL pdensa(blksize) ! average particle density in accumu
5308       REAL pdensc(blksize)
5309 ! *** average modal Knudsen numbers
5310
5311 ! average particle density in coarse
5312       REAL knnuc(blksize) ! nuclei mode  Knudsen number
5313       REAL knacc(blksize) ! accumulation Knudsen number
5314       REAL kncor(blksize)
5315 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
5316
5317 ! coarse mode  Knudsen number
5318       REAL fconcn(blksize)
5319 ! reciprocal condensation rate Aitke
5320       REAL fconca(blksize) !bs
5321 ! reciprocal condensation rate acclu
5322       REAL fconcn_org(blksize)
5323       REAL fconca_org(blksize)
5324
5325 ! *** Rates for secondary particle formation:
5326
5327 ! *** production of new mass concentration [ ug/m**3 s ]
5328       REAL dmdt(blksize) !                                 by particle formation
5329
5330 ! *** production of new number concentration [ number/m**3 s ]
5331
5332 ! rate of production of new mass concen
5333       REAL dndt(blksize) !                                 by particle formation
5334 ! *** growth rate for third moment by condensation of precursor
5335 !      vapor on existing particles [ 3rd mom/m**3 s ]
5336
5337 ! rate of producton of new particle num
5338       REAL cgrn3(blksize) !  Aitken mode
5339       REAL cgra3(blksize)
5340 ! *** Rates for coaglulation: [ m**3/s ]
5341
5342 ! *** Unimodal Rates:
5343
5344 !  Accumulation mode
5345       REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
5346       REAL ura00(blksize)
5347
5348 ! *** Bimodal Rates:  Aitken mode with accumulation mode ( Aitken mode)
5349 ! accumulation mode 0th moment self-coagulat
5350       REAL brna01(blksize) ! rate for 0th moment
5351       REAL brna31(blksize)
5352 ! *** other processes
5353
5354 ! rate for 3rd moment
5355       REAL deltaso4a(blksize) !                                  sulfate aerosol by condensation   [ u
5356
5357 ! *** housekeeping variables:
5358 ! increment of concentration added to
5359       INTEGER unit
5360       PARAMETER (unit=30)
5361       CHARACTER*16 pname
5362       PARAMETER (pname=' BOX            ')
5363       INTEGER isp,igrid,jgrid,kgrid
5364
5365 ! loop index for species.
5366       INTEGER ii, iimap(8)
5367       DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
5368
5369 !   begin body  of program box
5370
5371 ! *** Set up files and other info
5372 ! *** set up experimental conditions
5373 ! *** initialize model variables
5374 !ia *** not required any more
5375
5376 !ia       DO ISP = 1, NSPCSDA
5377 !ia       CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
5378 !ia       END DO
5379
5380       step = dtsec    ! set time step
5381
5382       blkta(blksize) = temp     ! T in Kelvin
5383
5384       blkprs(blksize)= pres*100. ! P in  Pa (pres is given in
5385
5386       blkrh(blksize) = relhum ! fractional RH
5387
5388       blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize))   !rs      CBLK(BLKSIZE,VSULF) = vsulf_in
5389
5390 !rs      CBLK(BLKSIZE,VHNO3) = nitrate_in
5391 !rs      CBLK(BLKSIZE,VNH3) =  nh3_in
5392 !bs
5393 !rs      CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
5394 !rs      CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
5395 !rs      CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
5396 !rs      CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
5397 !rs      CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
5398 !rs      CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
5399 !rs      CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
5400 !rs      CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
5401
5402       DO isp = 1, ldrog_vbs
5403         drog(blksize,isp) = drog_in(isp)
5404       END DO
5405
5406 !      print*,'drog in rpm',drog
5407 !bs
5408 !ia *** 27/05/97 the following variables are transported quantities
5409 !ia *** of the column-model now and thuse do not need this init.
5410 !ia *** step.
5411
5412 !     CBLK(BLKSIZE,VNU0) = numnuc_in
5413 !     CBLK(BLKSIZE,VAC0) = numacc_in
5414 !     CBLK(BLKSIZE,VSO4A) =  asulf_in
5415 !     CBLK(BLKSIZE,VSO4AI) = asulfi_in
5416 !     CBLK(BLKSIZE, VCORN) = numcor_in
5417
5418       so4rat(blksize) = so4rat_in
5419
5420 !...INITIALISE EMISSION RATES
5421
5422 !     epm25i(blksize) = & ! unidentified PM2.5 mass
5423 !       0.0
5424 !     epm25j(blksize) = &
5425 !       0.0
5426 ! unidentified PM2.5 m
5427       eorgi(blksize) = & ! primary organic
5428         eorgi_in
5429       eorgj(blksize) = &
5430         eorgj_in
5431 ! primary organic
5432       eeci(blksize) = & ! elemental carbon
5433         eeci_in
5434       eecj(blksize) = &
5435         eecj_in
5436 ! elemental carbon
5437       epm25(blksize) = & !currently from input file ACTIONIA
5438         0.0
5439       esoil(blksize) = & ! ACTIONIA
5440         soilrat_in
5441       eseas(blksize) = & !currently from input file ACTIONIA
5442         0.0
5443 !     epmcoarse(blksize) = & !currently from input file ACTIONIA
5444 !       0.0
5445       dgnuc(blksize) = dginin
5446       dgacc(blksize) = dginia
5447       dgcor(blksize) = dginic
5448       newm3 = 0.0
5449
5450 ! *** Set up initial total 3rd moment factors
5451
5452       totaersulf = 0.0
5453       newm3 = 0.0
5454 ! ***  time loop
5455 ! write(50,*) ' numsteps dgnuc dgacc ', ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5456
5457 ! *** Call aerosol routines
5458       CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5459         blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat, &
5460         organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5461         nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5462         amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5463         knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5464         urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid,brrto,do_isorropia)
5465
5466 ! *** write output
5467 !      WRITE(UNIT,*) ' AFTER AEROPROC '
5468 !      WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5469
5470 ! *** Write out file for graphing.
5471
5472 !     write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5473
5474
5475 ! *** update sulfuric acid vapor
5476 !ia 21.04.98 this update is not required here
5477 !ia artefact from box model
5478 !       CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5479 !    &            SO4RAT(BLKSIZE) * STEP
5480
5481       RETURN
5482 END SUBROUTINE rpmmod3
5483 !---------------------------------------------------------------------------
5484 SUBROUTINE soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat,  &
5485     organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5486     nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto)
5487
5488 !***** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM *!
5489 !bs  Description:                                                      !
5490 !bs                                                                    !
5491 !bs  SOA_VBS calculates the formation and partitioning of secondary  !
5492 !bs  organic aerosol based on (pseudo-)ideal solution thermodynamics.  !
5493 !bs                                                                    !
5494 !sam The original Schell model (JGR, vol. 106, D22, 28275-28293, 2001) !
5495 !sam is modified drastically to incorporate the SOA vapor-pressure     !
5496 !sam basis set approach developed by Carnegie Mellon folks.            !
5497 !sam Recommended changes according to Allen Robinson, 9/15/09          !
5498 !sam The treatment is done very similar to Lane et al., Atmos. Envrn., !
5499 !sam vol 42, 7439-7451, 2008.                                          !
5500 !sam Four basis vapor-pressures for anthropogenic and 4 basis vp's     !
5501 !sam for biogenic SOA are used.  The SAPRC-99 yield information for    !
5502 !sam low and high NOx conditions (Lane, Donahue and Pandis, ES&T,      !
5503 !sam vol. 42, 6022-6027, 2008) are mapped to RADM2/RACM species.       !
5504 !sam                                                                   !
5505 !sam Basis vapor pressures (@ 300K)                                    !
5506 !sam Anthro (1 ug/m3)   -    asoa1   Biogenic (1 ug/m3)   -    bsoa1   !
5507 !sam Anthro (10 ug/m3)  -    asoa2   Biogenic (10 ug/m3)  -    bsoa2   !
5508 !sam Anthro (100 ug/m3) -    asoa3   Biogenic (100 ug/m3) -    bsoa3   !
5509 !sam Anthro (1000 ug/m3)-    asoa4   Biogenic (1000 ug/m3)-    bsoa4   !
5510 !bs                                                                    !
5511 !bs  This code considers two cases:                                    !
5512 !bs   i) initil absorbing mass is existend in the aerosol phase        !
5513 !bs  ii) a threshold has to be exeeded before partitioning (even below !
5514 !bs      saturation) will take place.                                  !
5515 !bs                                                                    !
5516 !bs  The temperature dependence of the saturation concentrations are   !
5517 !bs  calculated using the Clausius-Clapeyron equation.                 !
5518 !bs                                                                    !
5519 !bs  If there is no absorbing mass at all the Pandis method is applied !
5520 !bs  for the first steps.                                              !
5521 !bs                                                                    !
5522 !bs  References:                                                       !
5523 !bs    Pankow (1994):                                                  !
5524 !bs     An absorption model of the gas/aerosol                         !
5525 !bs     partitioning involved in the formation of                      !
5526 !bs     secondary organic aerosol, Atmos. Environ. 28(2),              !
5527 !bs     189-193.                                                       !
5528 !bs    Odum et al. (1996):                                             !
5529 !bs     Gas/particle partitioning and secondary organic                !
5530 !bs     aerosol yields,  Environ. Sci. Technol. 30,                    !
5531 !bs     2580-2585.                                                     !
5532 !bs    see also                                                        !
5533 !bs    Bowman et al. (1997):                                           !
5534 !bs     Mathematical model for gas-particle partitioning               !
5535 !bs     of secondary organic aerosols, Atmos. Environ.                 !
5536 !bs     31(23), 3921-3931.                                             !
5537 !bs    Seinfeld and Pandis (1998):                                     !
5538 !bs     Atmospheric Chemistry and Physics (0-471-17816-0)              !
5539 !bs     chapter 13.5.2 Formation of binary ideal solution              !
5540 !bs     with -- preexisting aerosol                                    !
5541 !bs          -- other organic vapor                                    !
5542 !bs                                                                    !
5543 !bs  Called by:     SOA_VBS                                             !
5544 !bs                                                                    !
5545 !bs  Calls:         None                                               !
5546 !bs                                                                    !
5547 !bs  Arguments:     LAYER,                                             !
5548 !bs                 BLKTA, BLKPRS,                                     !
5549 !bs                 ORGARO1RAT, ORGARO2RAT,                            !
5550 !bs                 ORGALK1RAT, ORGOLE1RAT,                            !
5551 !bs                 ORGBIO1RAT, ORGBIO2RAT,                            !
5552 !bs                 ORGBIO3RAT, ORGBIO4RAT,                            !
5553 !bs                 DROG, LDROG, NCV, NACV,                            !
5554 !bs                 CBLK, BLKSIZE, NSPCSDA, NUMCELLS,                  !
5555 !bs                 DT                                                 !
5556 !bs                                                                    !
5557 !bs  Include files: AEROSTUFF.EXT                                      !
5558 !bs                 AERO_internal.EXT                                  !
5559 !bs                                                                    !
5560 !bs  Data:          None                                               !
5561 !bs                                                                    !
5562 !bs  Input files:   None                                               !
5563 !bs                                                                    !
5564 !bs  Output files:  None                                               !
5565 !bs                                                                    !
5566 !bs--------------------------------------------------------------------!
5567 !bs                                                                    !
5568 !bs  History:                                                          !
5569 !bs   No    Date    Author           Change                            !
5570 !bs  ____  ______  ________________  _________________________________ !
5571 !     01   052011   McKeen/Ahmadov   Subroutine development            !
5572
5573       USE module_configure, only: grid_config_rec_type
5574
5575       ! model layer
5576       INTEGER layer
5577       ! dimension of arrays
5578       INTEGER blksize
5579       ! number of species in CBLK
5580       INTEGER nspcsda   ! actual number of cells in arrays
5581       INTEGER numcells  ! # of organic aerosol precursor
5582       INTEGER ldrog_vbs     ! total # of cond. vapors & SOA sp
5583       INTEGER ncv       ! # of anthrop. cond. vapors & SOA
5584       INTEGER nacv
5585       INTEGER igrid,jgrid,kgrid
5586
5587       REAL cblk(blksize,nspcsda) ! main array of variables
5588       REAL dt              ! model time step in  SECONDS
5589       REAL blkta(blksize)  ! Air temperature [ K ]
5590       REAL blkprs(blksize) ! Air pressure in [ Pa ]
5591
5592       REAL, INTENT(OUT) :: brrto   ! branching ratio for NOx conditions
5593
5594       ! anthropogenic organic vapor production rates
5595
5596       REAL organt1rat(blksize)                                       ! rates from
5597       REAL organt2rat(blksize)                                       ! rates from
5598       REAL organt3rat(blksize)                                       ! rates from
5599       REAL organt4rat(blksize)                                       ! rates from
5600
5601       ! biogenic organic vapor production rates
5602       REAL orgbio1rat(blksize)
5603       REAL orgbio2rat(blksize)
5604       REAL orgbio3rat(blksize)
5605       REAL orgbio4rat(blksize)
5606       REAL drog(blksize,ldrog_vbs) !blksize=1, ldrog_vbs=9+1, the last ldrog_vbs is actually is the branching ratio
5607
5608       !bs * local variable declaration
5609       ! Delta ROG conc. [ppm]
5610       !bs numerical value for a minimum thresh
5611       REAL,PARAMETER :: thrsmin=1.E-19
5612       !bs numerical value for a minimum thresh
5613       !bs
5614       !bs universal gas constant [J/mol-K]
5615       REAL, PARAMETER :: rgas=8.314510
5616
5617       !sam reference temperature T0 = 300 K, a change from original 298K
5618       REAL, PARAMETER :: tnull=300.
5619
5620       !bs molecular weight for C
5621       REAL, PARAMETER :: mwc=12.0
5622       !bs molecular weight for organic species
5623       REAL, PARAMETER :: mworg=175.0
5624       !bs molecular weight for SO4
5625       REAL, PARAMETER :: mwso4=96.0576
5626       !bs molecular weight for NH4
5627       REAL, PARAMETER :: mwnh4=18.03858
5628       !bs molecular weight for NO3
5629       REAL, PARAMETER :: mwno3=62.01287
5630       ! molecular weight for AIR
5631
5632 !     REAL mwair
5633 !     PARAMETER (mwair=28.964)
5634       !bs relative tolerance for mass check
5635       REAL, PARAMETER :: CABSMIN=.00001   ! Minimum amount of absorbing material - needed in iteration method
5636       !sm number of basis set variables in CMU partitioning scheme
5637       INTEGER, PARAMETER :: nbin=4  ! we use 4 bin volatility according to Robinson A. et al.
5638
5639       ! we have 2 type of SOA - anthropogenic and biogenic
5640       !sm number of SAPRC species variables in CMU lumped partitioning table
5641       !sm 1=ALK4(hc5),2=ALK5(hc8),3=OLE1(ol2),4=OLE2(oli),5=ARO1(tol)
5642       !sm 6=AOR2(xyl),7=ISOP(iso),8=SESQ(?),9=TERP(alp)
5643       INTEGER, PARAMETER :: nsaprc=9   ! number of precursor classes
5644
5645       !bs loop indices
5646       INTEGER lcell, n, l, ll, bn, cls
5647       !bs conversion factor ppm --> ug/m^3
5648       REAL convfac
5649       !bs difference of inverse temperatures
5650       REAL ttinv
5651       !bs initial organic absorbing mass [ug/m^3]
5652       REAL minit
5653       !bs inorganic mass [ug/m^3]
5654       REAL mnono
5655       !bs total organic mass [ug/m^3]
5656       REAL mtot
5657
5658 !     REAL msum(ncv)  !bs input total mass [ug/m^3]
5659       REAL mwcv(ncv)  !bs molecular weight of cond. vapors [g/
5660       REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
5661       REAL dhvap(ncv) !bs heat of vaporisation of compound i [
5662       REAL pvap(ncv)  !bs vapor pressure cond. vapor [Pa]
5663       REAL ctot(ncv)  !bs total conc. of cond. vapor aerosol +
5664       REAL cgas(ncv)  !bs gasphase concentration of cond. vapors
5665       REAL caer(ncv)  !bs aerosolphase concentration of cond.
5666       REAL asav(ncv)  !bs saved CAER for iteration
5667       REAL aold(ncv)  !bs saved CAER for rate determination
5668       REAL csat(ncv)  !bs saturation conc. of cond. vapor ug/,
5669
5670       ! in basis set approach we need only 4 csat
5671       REAL ccsat(nbin)
5672       REAL ccaer(nbin)
5673       REAL cctot(nbin)
5674       REAL w1(nbin), w2(nbin)
5675
5676       REAL prod(ncv)  !bs production of condensable vapor ug/
5677       REAL p(ncv)     !bs PROD(L) * TIMEFAC [ug/m^3]
5678       REAL f(ldrog_vbs)   !bs scaling factor for ind. oxidant
5679
5680       REAL alphlowN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors low NOx condition
5681       REAL alphhiN(nbin,nsaprc)  ! sm normalized (1 g/m3 density) yield for condensable vapors high NOx condition
5682       REAL alphai(nbin,nsaprc)   ! mass-based stoichometric yield for product i and csti is the effective saturation
5683       ! concentration in ug m^-3
5684       REAL mwvoc(nsaprc)         ! molecular weight of the SOA precusors
5685
5686       REAL PnGtotal,DUM,FMTOT,FMTOT2,DUM2    ! Real constants used in Newton iteration
5687       integer, save :: icall
5688
5689       ! this is a correction factor to take into account the density of aerosols, from Murphy et al. (2009)
5690       ! Now it's determined by namelist
5691
5692       ! in the preliminary version we use alphlowN only to check what would be the maximum yeild
5693       ! SAM:  from Murphy et al. 2009
5694       DATA alphlowN /   &
5695       0.0000, 0.0750, 0.0000, 0.0000,   & ! ALK4
5696       0.0000, 0.3000, 0.0000, 0.0000,   & ! ALK5
5697       0.0045, 0.0090, 0.0600, 0.2250,   & ! OLE1
5698       0.0225, 0.0435, 0.1290, 0.3750,   & ! OLE2
5699       0.0750, 0.2250, 0.3750, 0.5250,   & ! ARO1
5700       0.0750, 0.3000, 0.3750, 0.5250,   & ! ARO2
5701       0.0090, 0.0300, 0.0150, 0.0000,   & ! ISOP
5702       0.0750, 0.1500, 0.7500, 0.9000,   & ! SESQ
5703       0.1073, 0.0918, 0.3587, 0.6075/     ! TERP
5704
5705       DATA alphhiN /    &
5706       0.0000, 0.0375, 0.0000, 0.0000,   & ! ALK4
5707       0.0000, 0.1500, 0.0000, 0.0000,   & ! ALK5
5708       0.0008, 0.0045, 0.0375, 0.1500,   & ! OLE1
5709       0.0030, 0.0255, 0.0825, 0.2700,   & ! OLE2
5710       0.0030, 0.1650, 0.3000, 0.4350,   & ! ARO1
5711       0.0015, 0.1950, 0.3000, 0.4350,   & ! ARO2
5712       0.0003, 0.0225, 0.0150, 0.0000,   & ! ISOP
5713       0.0750, 0.1500, 0.7500, 0.9000,   & ! SESQ
5714       0.0120, 0.1215, 0.2010, 0.5070/     ! TERP
5715
5716       DATA mwvoc /  &
5717                     73.23,   &    ! ALK4
5718                     106.97,  &    ! ALK5
5719                     61.68,   &    ! OLE1
5720                     79.05,   &    ! OLE2
5721                     100.47,  &    ! ARO1
5722                     113.93,  &    ! ARO2
5723                     68.12,   &    ! ISOP
5724                     204.0,   &    ! SESQ
5725                     136.24   /    ! TERP
5726
5727 !bs * initialisation
5728 !bs
5729 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
5730 !bs *      acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5731 !bs *      Eniron. Sci. Technol. 1989, 23, 1519-1523.
5732 !bs *      average value is 156 kJ/mol
5733 !
5734 !sam changed 156kJ/mol to 30.kJ/mol as in Lane et al., AE, 2008
5735       dhvap(pasoa1) = 30.0E03
5736       dhvap(pasoa2) = 30.0E03
5737       dhvap(pasoa3) = 30.0E03
5738       dhvap(pasoa4) = 30.0E03
5739
5740       dhvap(pbsoa1) = 30.0E03
5741       dhvap(pbsoa2) = 30.0E03
5742       dhvap(pbsoa3) = 30.0E03
5743       dhvap(pbsoa4) = 30.0E03
5744 !----------------------------------------------------------------
5745 !bs
5746 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
5747 !bs *      acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5748 !bs *      Eniron. Sci. Technol. 1989, 23, 1519-1523.
5749 !bs *      average value is 222.5 g/mol
5750 !bs *
5751 !bs * molecular weights used are estimates taking the origin (reactants)
5752 !bs *      into account. This should be updated if more information about
5753 !bs *      the products is available.
5754 !bs *      First hints are taken from Forstner et al. (1997), Environ. S
5755 !bs *        Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmos.
5756 !bs *        Environ. 31(13), 1953-1964.
5757 !bs *
5758 ! Molecular weights of OCVs as in Murphy and Pandis, 2009
5759       mwcv(pasoa1) = 150.
5760       mwcv(pasoa2) = 150.
5761       mwcv(pasoa3) = 150.
5762       mwcv(pasoa4) = 150.
5763
5764       mwcv(pbsoa1) = 180.
5765       mwcv(pbsoa2) = 180.
5766       mwcv(pbsoa3) = 180.
5767       mwcv(pbsoa4) = 180.
5768
5769 ! In Shell partitioned aerosols according to their precursors, but we do as Allen due to the saturation concentrations
5770 ! We have 2 sets for anthropogenic and biogenic and therefore we use the same denotation
5771       pnull(pasoa1) = 1.
5772       pnull(pasoa2) = 10.
5773       pnull(pasoa3) = 100.
5774       pnull(pasoa4) = 1000.
5775
5776       pnull(pbsoa1) = 1.
5777       pnull(pbsoa2) = 10.
5778       pnull(pbsoa3) = 100.
5779       pnull(pbsoa4) = 1000.
5780
5781 ! scaling factors, for testing purposes, check TOL and ISO only
5782 ! 05/23/2011: for testing all are zero!
5783 f(palk4) = 1.
5784 f(palk5) = 1.
5785 f(pole1) = 1.
5786 f(pole2) = 1.
5787 f(paro1) = 1.
5788 f(paro2) = 1.
5789 f(pisop) = 1.
5790 f(pterp) = 1.
5791 f(psesq) = 1.
5792
5793 loop_cells: DO lcell = 1, numcells  ! numcells=1
5794                 DO l= 1, ldrog_vbs-1
5795                    drog(lcell,l) = f(l)*drog(lcell,l)
5796                 END DO
5797
5798                 ! calculation of the yields using the branching ratio
5799                 brrto= drog(lcell,pbrch) ! temporary variable for the branching ratio
5800                 DO bn=1,nbin  ! bins
5801                    DO cls=1,nsaprc ! classes
5802                       alphai(bn,cls)= mwvoc(cls)*( alphhiN(bn,cls)*brrto + alphlowN(bn,cls)*(1.-brrto) )
5803                    ENDDO
5804                 ENDDO
5805
5806                 ttinv = 1./tnull - 1./blkta(lcell)
5807                 convfac = blkprs(lcell)/(rgas*blkta(lcell))
5808
5809                 ! cblk for gases comes in ppmv, we get the density in ug/m3 (microgram/m3)
5810                 ! by multiplying it by (convfac=rho_air/mu_air)x mwcv
5811                 cgas(pasoa1) = cblk(lcell,vcvasoa1)*convfac*mwcv(pasoa1)
5812                 cgas(pasoa2) = cblk(lcell,vcvasoa2)*convfac*mwcv(pasoa2)
5813                 cgas(pasoa3) = cblk(lcell,vcvasoa3)*convfac*mwcv(pasoa3)
5814                 cgas(pasoa4) = cblk(lcell,vcvasoa4)*convfac*mwcv(pasoa4)
5815
5816                 cgas(pbsoa1) = cblk(lcell,vcvbsoa1)*convfac*mwcv(pbsoa1)
5817                 cgas(pbsoa2) = cblk(lcell,vcvbsoa2)*convfac*mwcv(pbsoa2)
5818                 cgas(pbsoa3) = cblk(lcell,vcvbsoa3)*convfac*mwcv(pbsoa3)
5819                 cgas(pbsoa4) = cblk(lcell,vcvbsoa4)*convfac*mwcv(pbsoa4)
5820
5821                 ! cblk for aerosols come in density (ug/m3), converted already in soa_vbs_driver
5822                 caer(pasoa1) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)
5823                 caer(pasoa2) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)
5824                 caer(pasoa3) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)
5825                 caer(pasoa4) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)
5826
5827                 caer(pbsoa1) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)
5828                 caer(pbsoa2) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)
5829                 caer(pbsoa3) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)
5830                 caer(pbsoa4) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)
5831
5832    !             #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
5833                 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5834                 !SAM  diagnostics
5835                 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5836 !                        if (igrid .eq. 1 .AND. jgrid .eq. 18) then
5837 !                            if (kgrid .eq. 1 )then
5838 !                                write(6,*)'drog', drog
5839 !                                write(6,*)'caer(pasoa1)',caer(pasoa1)
5840 !                                write(6,*)'caer(pasoa4)',caer(pasoa4)
5841 !                                write(6,*)'caer(pbsoa1)',caer(pbsoa1)
5842 !                            endif
5843 !                        endif
5844                 !SAM end print of aerosol physical parameter diagnostics
5845                 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5846    !             #endif
5847                 ! Production of SOA by oxidation of VOCs
5848                 ! There are 6 classes of the precursors for ansthropogenic SOA
5849                 prod(pasoa1) = alphai(1,1)*drog(lcell,palk4) + alphai(1,2)*drog(lcell,palk5) + &
5850                                alphai(1,3)*drog(lcell,pole1) + alphai(1,4)*drog(lcell,pole2) + &
5851                                alphai(1,5)*drog(lcell,paro1) + alphai(1,6)*drog(lcell,paro2)
5852
5853                 prod(pasoa2) = alphai(2,1)*drog(lcell,palk4) + alphai(2,2)*drog(lcell,palk5) + &
5854                                alphai(2,3)*drog(lcell,pole1) + alphai(2,4)*drog(lcell,pole2) + &
5855                                alphai(2,5)*drog(lcell,paro1) + alphai(2,6)*drog(lcell,paro2)
5856
5857                 prod(pasoa3) = alphai(3,1)*drog(lcell,palk4) + alphai(3,2)*drog(lcell,palk5) + &
5858                                alphai(3,3)*drog(lcell,pole1) + alphai(3,4)*drog(lcell,pole2) + &
5859                                alphai(3,5)*drog(lcell,paro1) + alphai(3,6)*drog(lcell,paro2)
5860
5861                 prod(pasoa4) = alphai(4,1)*drog(lcell,palk4) + alphai(4,2)*drog(lcell,palk5) + &
5862                                alphai(4,3)*drog(lcell,pole1) + alphai(4,4)*drog(lcell,pole2) + &
5863                                alphai(4,5)*drog(lcell,paro1) + alphai(4,6)*drog(lcell,paro2)
5864
5865                 ! There are 3 classes of the precursors for biogenic SOA
5866                 prod(pbsoa1) = alphai(1,7)*drog(lcell,pisop) + alphai(1,8)*drog(lcell,psesq) + &
5867                                alphai(1,9)*drog(lcell,pterp)
5868
5869                 prod(pbsoa2) = alphai(2,7)*drog(lcell,pisop) + alphai(2,8)*drog(lcell,psesq) + &
5870                                alphai(2,9)*drog(lcell,pterp)
5871
5872                 prod(pbsoa3) = alphai(3,7)*drog(lcell,pisop) + alphai(3,8)*drog(lcell,psesq) + &
5873                                alphai(3,9)*drog(lcell,pterp)
5874
5875                 prod(pbsoa4) = alphai(4,7)*drog(lcell,pisop) + alphai(4,8)*drog(lcell,psesq) + &
5876                                alphai(4,9)*drog(lcell,pterp)
5877
5878 !bs * calculate actual production from gasphase reactions [ug/m^3]
5879 !bs * calculate vapor pressure of pure compound as a liquid using the Clausius-Clapeyron equation and the actual saturation concentration.
5880 !bs * calculate the threshold for partitioning if no initial mass is present to partition into.
5881
5882     loop_cc:    DO  l = 1,ncv             ! we've total ncv=4*2 bins, no alpha is needed here
5883                     prod(l) =  convfac*prod(l)  ! get in density units (ug/m3) from ppmv, (convfac=rho_air/mu_air)
5884                     ctot(l) =  prod(l) + cgas(l) + caer(l)
5885                     aold(l) =  caer(l)
5886
5887                     ! csat should be calculated 4 times, since pnull is the same for biogenic!
5888                     csat(l) =  pnull(l)*tnull/blkta(lcell)*exp(dhvap(l)/rgas*ttinv)
5889                 END DO loop_cc
5890
5891 ! when we solve the nonlinear equation to determine "caer" we need to combine
5892 ! asoa(n) and bsoa(n), since they have the same saturation concentrations, hence the equilibrium should cover the same bins
5893
5894 PnGtotal=0.  ! track total Condensed Vapors&SOA over bins for limits on Newton Iteration of total SOA mass
5895 do ll=1,nbin
5896         ccsat(ll)= csat(ll)
5897         ccaer(ll)= caer(ll) + caer(ll+4)
5898         cctot(ll)= ctot(ll) + ctot(ll+4)
5899         PnGtotal=PnGtotal+cctot(ll)
5900         w1(ll)= ctot(ll)/cctot(ll)    ! Anthropogenic fraction to total
5901         w2(ll)= 1. - w1(ll)           ! Biogenic fraction of total
5902 end do
5903
5904 !bs
5905 !bs * small amount of non-volatile absorbing mass is assumed to be
5906 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
5907 !bs * mass in each size section, here mode)
5908 !bs
5909 ! inorganic mass isn't needed here
5910             !mnono  = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+ cblk(lcell,vno3aj))
5911             !mnono  = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+ cblk(lcell,vno3ai))
5912
5913 ! they're assigned to zero at the next step
5914 ! test with minit=0
5915  !    minit  = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) !+ mnono
5916  minit= 1.4*( cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) ) ! exclude EC from absorbing mass
5917
5918 ! minit is taken into account
5919
5920 !bs * If MINIT is set to zero partitioning will occur if the pure
5921 !bs * saturation concentation is exceeded (Pandis et al. 1992).
5922 !bs * If some amount of absorbing organic mass is formed gas/particle
5923 !bs * partitioning will follow the ideal solution approach.
5924 !bs
5925 !SAM 9/8/09 - Include absorbing SOA material within aerosols in calculation !
5926
5927      minit = AMAX1(minit,CABSMIN)
5928
5929 ! mtot is initial guess to SOA mass (aerosol plus extra absorbing mass (minit))
5930      mtot = 0.
5931      DO L=1,NBIN
5932         mtot = mtot + AMIN1(1.,CCTOT(L)/CCSAT(L))*CCTOT(L)
5933      ENDDO
5934      mtot = mtot + minit
5935 !
5936 ! debugging
5937 !if (igrid .eq. 8 .AND. jgrid .eq. 18) then
5938 !    if (kgrid .eq. 1 )then
5939 !         write(6,*)'before Newton iteration'
5940 !         write(6,*)'MTOT=',MTOT
5941 !         write(6,*)'minit=',minit
5942 !         write(6,*)'w1=',w1,'w2=',w2
5943 !         write(6,*)'cctot=',cctot
5944 !         write(6,*)'ccaer=',ccaer
5945 !         write(6,*)'ccsat=',ccsat
5946 !         write(6,*)'nbin=',nbin
5947 !    endif
5948 !endif
5949
5950 !SAM: Find total SOA mass from newton iteration, needs only 5 iterations for exact solution
5951 loop_newt:  DO LL=1,5   ! Fixed Newton iteration number
5952                FMTOT=0.
5953                FMTOT2=0.
5954                DO L=1,NBIN
5955                   DUM=CCTOT(L)/(1.+CCSAT(L)/MTOT)
5956                   FMTOT=FMTOT+DUM
5957                   FMTOT2=FMTOT2+DUM**2
5958                ENDDO
5959                FMTOT=FMTOT+MINIT   ! Forecast total SOA mass
5960                DUM=MTOT-FMTOT
5961                DUM2=((FMTOT-MINIT)/MTOT)-MTOT*FMTOT2
5962                MTOT=MTOT-DUM/(1.-DUM2)
5963                MTOT=AMAX1(MTOT,MINIT)  ! Limit MTOT to min possible in case of instability
5964                MTOT=AMIN1(MTOT,PnGtotal+minit)  ! Limit MTOT to max possible in case of instability
5965 END DO  loop_newt   ! LL iteration number loop
5966
5967 ! Have total mass MTOT, get aerosol mass from semi-ideal partitioning equation
5968       DO L=1,NBIN
5969          CCAER(L)=CCTOT(L)*MTOT/(MTOT+CCSAT(L))
5970       ENDDO
5971 !
5972
5973 do ll=1,nbin
5974      caer(ll)= AMAX1(w1(ll)*ccaer(ll),CONMIN)
5975      caer(ll+4)= AMAX1(w2(ll)*ccaer(ll),CONMIN)
5976      cgas(ll)= w1(ll)*(cctot(ll) - ccaer(ll))
5977      cgas(ll+4)= w2(ll)*(cctot(ll) - ccaer(ll))
5978 end do
5979
5980       ! assigning values to CBLK array (gases), convert to ppm since it goes to chem
5981         cblk(lcell,vcvasoa1) = max(cgas(pasoa1),conmin)/convfac/mwcv(pasoa1)
5982         cblk(lcell,vcvasoa2) = max(cgas(pasoa2),conmin)/convfac/mwcv(pasoa2)
5983         cblk(lcell,vcvasoa3) = max(cgas(pasoa3),conmin)/convfac/mwcv(pasoa3)
5984         cblk(lcell,vcvasoa4) = max(cgas(pasoa4),conmin)/convfac/mwcv(pasoa4)
5985
5986         cblk(lcell,vcvbsoa1) = max(cgas(pbsoa1),conmin)/convfac/mwcv(pbsoa1)
5987         cblk(lcell,vcvbsoa2) = max(cgas(pbsoa2),conmin)/convfac/mwcv(pbsoa2)
5988         cblk(lcell,vcvbsoa3) = max(cgas(pbsoa3),conmin)/convfac/mwcv(pbsoa3)
5989         cblk(lcell,vcvbsoa4) = max(cgas(pbsoa4),conmin)/convfac/mwcv(pbsoa4)
5990
5991         organt1rat(lcell)    = (caer(pasoa1)-aold(pasoa1))/dt
5992         organt2rat(lcell)    = (caer(pasoa2)-aold(pasoa2))/dt
5993         organt3rat(lcell)    = (caer(pasoa3)-aold(pasoa3))/dt
5994         organt4rat(lcell)    = (caer(pasoa4)-aold(pasoa4))/dt
5995
5996         orgbio1rat(lcell)    = (caer(pbsoa1)-aold(pbsoa1))/dt
5997         orgbio2rat(lcell)    = (caer(pbsoa2)-aold(pbsoa2))/dt
5998         orgbio3rat(lcell)    = (caer(pbsoa3)-aold(pbsoa3))/dt
5999         orgbio4rat(lcell)    = (caer(pbsoa4)-aold(pbsoa4))/dt
6000   END DO loop_cells
6001   RETURN
6002 END SUBROUTINE soa_vbs
6003 !
6004 ! *** this routine calculates the dry deposition and sedimentation
6005 !     velocities for the three modes.
6006 !     coded 1/23/97 by Dr. Francis S. Binkowski. Follows
6007 !     FSB's original method, i.e. uses Jon Pleim's expression for deposition
6008 !     velocity but includes Marv Wesely's wstar contribution.
6009 !ia eliminated Stokes term for coarse mode deposition calcs.,
6010 !ia see comments below
6011
6012        SUBROUTINE VDVG(  BLKSIZE, NSPCSDA, NUMCELLS,           &
6013                      LAYER,                                    &
6014                      CBLK,                                     &
6015                      BLKTA, BLKDENS, RA, USTAR, WSTAR,  AMU,   &
6016                      DGNUC, DGACC, DGCOR,                      &
6017                      KNNUC, KNACC,KNCOR,                       &
6018                      PDENSN, PDENSA, PDENSC,                   &
6019                      VSED, VDEP )
6020
6021 ! *** calculate size-averaged particle dry deposition and
6022 !     size-averaged sedimentation velocities.
6023
6024
6025 !     IMPLICIT NONE
6026
6027       INTEGER BLKSIZE                  ! dimension of arrays
6028       INTEGER NSPCSDA                  ! number of species in CBLK
6029       INTEGER NUMCELLS                ! actual number of cells in arrays
6030       INTEGER LAYER                   ! number of layer
6031
6032       REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6033       REAL BLKTA( BLKSIZE )         ! Air temperature [ K ]
6034       REAL BLKDENS(BLKSIZE) ! Air density  [ kg m^-3 ]
6035       REAL RA(BLKSIZE )             ! aerodynamic resistance [ s m**-1 ]
6036       REAL USTAR( BLKSIZE )         ! surface friction velocity [ m s**-1 ]
6037       REAL WSTAR( BLKSIZE )         ! convective velocity scale [ m s**-1 ]
6038       REAL AMU( BLKSIZE )           ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6039       REAL DGNUC( BLKSIZE )         ! nuclei mode mean diameter [ m ]
6040       REAL DGACC( BLKSIZE )         ! accumulation
6041       REAL DGCOR( BLKSIZE )         ! coarse mode
6042       REAL KNNUC( BLKSIZE )         ! nuclei mode Knudsen number
6043       REAL KNACC( BLKSIZE )         ! accumulation
6044       REAL KNCOR( BLKSIZE )         ! coarse mode
6045       REAL PDENSN( BLKSIZE )        ! average particel density in nuclei mode [ kg / m**3 ]
6046       REAL PDENSA( BLKSIZE )        ! average particel density in accumulation mode [ kg / m**3 ]
6047       REAL PDENSC( BLKSIZE )        ! average particel density in coarse mode [ kg / m**3 ]
6048
6049
6050 ! *** modal particle diffusivities for number and 3rd moment, or mass:
6051
6052       REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
6053       REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
6054
6055 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
6056
6057       REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
6058       REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
6059
6060 ! *** deposition and sedimentation velocities
6061
6062       REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
6063       REAL VSED( BLKSIZE, NASPCSSED)  ! deposition  velocity [ m s**-1 ]
6064
6065
6066       INTEGER LCELL
6067       REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
6068       REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
6069       REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
6070       REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
6071       REAL ST0N, ST0A, ST0C ! Stokes numbers for number
6072       REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
6073       REAL RD0N, RD0A, RD0C    ! canopy resistance for number
6074       REAL RD3N, RD3A, RD3C    ! canopy resisteance for 3rd moment
6075       REAL UTSCALE   ! scratch function of USTAR and WSTAR.
6076       REAL NU        !kinematic viscosity [ m**2 s**-1 ]
6077       REAL USTFAC      ! scratch function of USTAR, NU, and GRAV
6078       REAL BHAT
6079       PARAMETER( BHAT =  1.246 ) ! Constant from Cunningham slip correction.
6080
6081
6082 ! *** check layer value.
6083
6084          IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
6085 !                                    sedimentation velocities
6086
6087          DO LCELL = 1, NUMCELLS
6088
6089             DCONST1 = BOLTZ * BLKTA(LCELL) /                                         &
6090                     ( THREEPI * AMU(LCELL) )
6091             DCONST1N = DCONST1 / DGNUC( LCELL )
6092             DCONST1A = DCONST1 / DGACC( LCELL )
6093             DCONST1C = DCONST1 / DGCOR( LCELL )
6094             DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6095             DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6096             DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6097             DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6098
6099 ! *** i-mode
6100
6101             DCHAT0N(LCELL) =  DCONST1N                             &
6102                * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
6103
6104             DCHAT3N(LCELL) =  DCONST1N                             &
6105                * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
6106
6107             VGHAT0N(LCELL) = DCONST3N                             &
6108                * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6109
6110             VGHAT3N(LCELL) = DCONST3N                             &
6111                * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6112
6113 ! *** j-mode
6114
6115             DCHAT0A(LCELL) =  DCONST1A                             &
6116               * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
6117
6118             DCHAT3A(LCELL) =  DCONST1A                             &
6119                * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
6120
6121             VGHAT0A(LCELL) = DCONST3A                             &
6122               * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6123
6124             VGHAT3A(LCELL) = DCONST3A                             &
6125               * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6126
6127
6128 ! *** coarse mode
6129
6130             DCHAT0C(LCELL)=  DCONST1C                             &
6131               * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
6132
6133             DCHAT3C(LCELL) = DCONST1C                             &
6134               * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
6135
6136             VGHAT0C(LCELL) = DCONST3C                             &
6137               * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6138
6139             VGHAT3C(LCELL) = DCONST3C                             &
6140               * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6141
6142         END DO
6143
6144 ! *** now calculate the deposition and sedmentation velocities
6145
6146 !ia  07.05.98
6147 ! *** NOTE In the deposition velocity for coarse mode,
6148 !     the impaction term  10.0 ** (-3.0 / st) is eliminated because
6149 !     coarse particles are likely to bounce on impact and the current
6150 !     formulation does not account for this.
6151
6152
6153         DO LCELL = 1, NUMCELLS
6154
6155          NU = AMU(LCELL) / BLKDENS(LCELL)
6156          USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
6157          UTSCALE = USTAR(LCELL) +                             &
6158                  0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
6159
6160 ! *** first do number
6161
6162 ! *** nuclei or Aitken mode  ( no sedimentation velocity )
6163
6164         SC0N = NU / DCHAT0N(LCELL)
6165         ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
6166         RD0N = 1.0 / ( UTSCALE *                             &
6167                   ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
6168
6169         VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) +                             &
6170                1.0 / (                             &
6171            RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
6172
6173         VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6174
6175 ! *** accumulation mode
6176
6177         SC0A = NU / DCHAT0A(LCELL)
6178         ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
6179         RD0A = 1.0 / ( UTSCALE *                             &
6180                   ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
6181
6182         VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) +                             &
6183                1.0 / (                             &
6184            RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
6185
6186         VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6187
6188 ! *** coarse mode
6189
6190         SC0C = NU / DCHAT0C(LCELL)
6191 !ia        ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
6192 !ia        RD0C = 1.0 / ( UTSCALE *
6193 !ia     &            ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
6194
6195          RD0C = 1.0 / ( UTSCALE *                            &
6196                       ( SC0C ** ( -TWO3 )  ) ) ! eliminate impaction term
6197
6198         VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) +                             &
6199                1.0 / (                             &
6200            RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
6201
6202         VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6203
6204 ! *** now do m3 for the deposition of mass
6205
6206 ! *** nuclei or Aitken mode
6207
6208         SC3N = NU / DCHAT3N(LCELL)
6209         ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
6210         RD3N = 1.0 / ( UTSCALE *                             &
6211                   ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
6212
6213         VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) +                             &
6214                1.0 / (                             &
6215            RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
6216
6217         VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
6218
6219 ! *** accumulation mode
6220
6221         SC3A = NU / DCHAT3A(LCELL)
6222         ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
6223         RD3A = 1.0 / ( UTSCALE *                             &
6224                   ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
6225
6226        VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) +                            &
6227                1.0 / (                            &
6228                RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
6229
6230
6231 ! *** fine mass deposition velocity: combine Aitken and accumulation
6232 !     mode deposition velocities. Assume density is the same
6233 !     for both modes.
6234
6235
6236 !       VDEP(LCELL,VDMFINE) = (
6237 !    &    CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
6238 !    &    CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
6239 !    &    ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
6240
6241
6242 ! *** fine mass sedimentation velocity
6243
6244 !       VSED( LCELL, VSMFINE) = (
6245 !    &    CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6246 !    &     CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6247 !    &    ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3)  )
6248
6249         VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
6250
6251 ! *** coarse mode
6252
6253         SC3C = NU / DCHAT3C(LCELL)
6254 !ia        ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
6255 !ia        RD3C = 1.0 / ( UTSCALE *
6256 !ia     &            ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
6257
6258         RD3C = 1.0 / ( UTSCALE *                            &
6259                      ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
6260         VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) +                             &
6261                1.0 / (                             &
6262            RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
6263
6264 ! *** coarse mode sedmentation velocity
6265
6266         VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6267
6268
6269
6270         END DO
6271
6272         ELSE   ! LAYER greater than 1
6273
6274 ! *** for layer greater than 1 calculate  sedimentation velocities only
6275
6276          DO LCELL = 1, NUMCELLS
6277
6278             DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6279
6280             DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6281             DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6282             DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6283
6284             VGHAT0N(LCELL) = DCONST3N                             &
6285                * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6286
6287 ! *** nucleation mode number sedimentation velocity
6288
6289             VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6290
6291             VGHAT3N(LCELL) = DCONST3N                             &
6292                * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6293
6294 ! *** nucleation mode volume sedimentation velocity
6295
6296             VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
6297
6298             VGHAT0A(LCELL) = DCONST3A                             &
6299               * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6300
6301 ! *** accumulation mode number sedimentation velocity
6302
6303             VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6304
6305             VGHAT3A(LCELL) = DCONST3A                            &
6306               * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6307
6308 ! *** fine mass sedimentation velocity
6309
6310 !           VSED( LCELL, VSMFINE) = (
6311 !    &       CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6312 !    &        CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6313 !    &       ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3)  )
6314
6315             VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
6316
6317             VGHAT0C(LCELL) = DCONST3C                            &
6318               * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6319
6320 ! *** coarse mode sedimentation velocity
6321
6322             VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6323
6324
6325             VGHAT3C(LCELL) = DCONST3C                             &
6326               * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6327
6328 ! *** coarse mode mass sedimentation velocity
6329
6330             VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6331
6332          END DO
6333
6334          END IF ! check on layer
6335
6336 END SUBROUTINE VDVG
6337 !
6338 !---------------------------------------------------------------------------
6339 !
6340 ! *** this routine calculates the dry deposition and sedimentation
6341 !     velocities for the three modes.
6342 !   Stu McKeen 10/13/08
6343 !   Gaussian Quadrature numerical integration over diameter range for each mode.
6344 ! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10
6345 ! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv
6346 !   Numerical Integration allows more complete discription of the
6347 !   Cunningham Slip correction factor, Interception Term (not included previously),
6348 !   and the correction due to rebound for higher diameter particles.
6349 !   Sedimentation velocities the same as original Binkowski code, also the
6350 !   Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the
6351 !   same as Binkowski.
6352 !   Stokes number, and efficiency dependence on Stokes number now according to
6353 !   Peters and Eiden (1992).  Interception term taken from Slinn (1982) with
6354 !   efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy
6355 !   for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction
6356 !   term is that of Slinn (1982)
6357 !
6358 !     Original code 1/23/97 by Dr. Francis S. Binkowski. Follows
6359 !     FSB's original method, i.e. uses Jon Pleim's expression for deposition
6360 !     velocity but includes Marv Wesely's wstar contribution.
6361 !ia eliminated Stokes term for coarse mode deposition calcs.,
6362 !ia see comments below
6363
6364 ! CBLK is eliminated since the subroutine doesn't use it!
6365 SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,         &
6366              LAYER,                                    &
6367              BLKTA, BLKDENS,                           &
6368              RA, USTAR, PBLH, ZNTT, RMOLM,  AMU,       &
6369              DGNUC, DGACC, DGCOR, XLM,                 &
6370              KNNUC, KNACC,KNCOR,                       &
6371              PDENSN, PDENSA, PDENSC,                   &
6372              VSED, VDEP)
6373
6374 ! *** calculate size-averaged particle dry deposition and
6375 !     size-averaged sedimentation velocities.
6376 !     IMPLICIT NONE
6377
6378       INTEGER BLKSIZE                 ! dimension of arrays
6379       INTEGER NSPCSDA                 ! number of species in CBLK
6380       INTEGER NUMCELLS                ! actual number of cells in arrays
6381       INTEGER LAYER                   ! number of layer
6382       INTEGER, PARAMETER :: iprnt = 0
6383
6384 !     REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6385       REAL BLKTA( BLKSIZE )         ! Air temperature [ K ]
6386       REAL BLKDENS(BLKSIZE)         ! Air density  [ kg m^-3 ]
6387       REAL RA(BLKSIZE )             ! aerodynamic resistance [ s m**-1 ]
6388       REAL USTAR( BLKSIZE )         ! surface friction velocity [ m s**-1 ]
6389       REAL PBLH( BLKSIZE )          ! PBL height (m)
6390       REAL ZNTT( BLKSIZE )          ! Surface roughness length (m)
6391       REAL RMOLM( BLKSIZE )         ! Inverse of Monin-Obukhov length (1/m)
6392       REAL AMU( BLKSIZE )           ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6393       REAL XLM( BLKSIZE )           ! mean free path of dry air [ m ]
6394       REAL DGNUC( BLKSIZE )         ! nuclei mode mean diameter [ m ]
6395       REAL DGACC( BLKSIZE )         ! accumulation
6396       REAL DGCOR( BLKSIZE )         ! coarse mode
6397       REAL KNNUC( BLKSIZE )         ! nuclei mode Knudsen number
6398       REAL KNACC( BLKSIZE )         ! accumulation
6399       REAL KNCOR( BLKSIZE )         ! coarse mode
6400       REAL PDENSN( BLKSIZE )        ! average particle density in nuclei mode [ kg / m**3 ]
6401       REAL PDENSA( BLKSIZE )        ! average particle density in accumulation mode [ kg / m**3 ]
6402       REAL PDENSC( BLKSIZE )        ! average particle density in coarse mode [ kg / m**3 ]
6403
6404 ! *** deposition and sedimentation velocities
6405
6406       REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimentation velocity [ m s**-1 ]
6407       REAL VSED( BLKSIZE, NASPCSSED) ! deposition  velocity [ m s**-1 ]
6408
6409       INTEGER LCELL,N
6410       REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C
6411       REAL UTSCALE,CZH   ! scratch functions of USTAR and WSTAR.
6412       REAL NU            !kinematic viscosity [ m**2 s**-1 ]
6413       REAL BHAT
6414       PARAMETER( BHAT =  1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction.
6415       REAL COLCTR_BIGD,COLCTR_SMALD
6416       PARAMETER ( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6 )  ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest)
6417       REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim
6418       REAL Eff_dif, Eff_imp, Eff_int, RBcor
6419       INTEGER ISTOPvd0,IdoWesCor
6420       PARAMETER (ISTOPvd0 = 0)  ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs.
6421
6422       ! no Wesley deposition, otherwise EC is too low
6423       PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means don't do correction
6424       IF (ISTOPvd0.EQ.1)THEN
6425       RETURN
6426       ENDIF
6427 ! *** check layer value.
6428
6429       IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER
6430          IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and sedimentation velocities
6431
6432          DO LCELL = 1, NUMCELLS
6433             DCONST1 = BOLTZ * BLKTA(LCELL) /                                         &
6434                     ( THREEPI * AMU(LCELL) )
6435             DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6436             DCONST3 =  USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD)
6437
6438 ! *** now calculate the deposition velocities at layer 1
6439
6440          NU = AMU(LCELL) / BLKDENS(LCELL)
6441
6442          UTSCALE =  1.
6443         IF (IdoWesCor.EQ.1)THEN
6444 ! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08)
6445            IF(RMOLM(LCELL).LT.0.)THEN
6446                 CZH = -1.*PBLH(LCELL)*RMOLM(LCELL)
6447                 IF(CZH.GT.30.0)THEN
6448                   UTSCALE=0.45*CZH**0.6667
6449                 ELSE
6450                   UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667
6451                 ENDIF
6452            ENDIF
6453         ENDIF   ! end of (IdoWesCor.EQ.1) test
6454
6455         UTSCALE = USTAR(LCELL)*UTSCALE
6456       IF(iprnt.eq.1)THEN
6457           print *,'NGAUSdv,xxlsga,USTAR,UTSCALE'
6458           print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE
6459           print *,'DCONST2,PDENSA,DGACC,GRAV,AMU'
6460           print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL)
6461       endif
6462
6463 ! *** nuclei mode
6464
6465         SUM0=0.
6466         SUM3=0.
6467         DO N=1,NGAUSdv
6468          DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn)  ! Diameter (m) at quadrature point
6469             KNQ=2.*XLM(LCELL)/DQ  ! Knudsen number at quadrature point
6470             CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ))  ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6471             VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ  ! Gravitational sedimentation velocity m/s
6472             SCQ=NU*DQ/DCONST1/CUNQ  ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6473             Eff_dif=SCQ**(-TWO3)    ! Efficiency term for diffusion - Same as Binkowski and Shankar
6474             STQ=DCONST3*PDENSN(LCELL)*DQ**2  ! Stokes number, Peters and Eiden (1992)
6475             Eff_imp=(STQ/(0.8+STQ))**2   ! Efficiency term for impaction - Peters and Eiden (1992)
6476     !       Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6477             Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn trm, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6478             RBcor=1. ! Rebound correction factor
6479             vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6480     !       vdplim=.002*UTSCALE
6481             vdplim=min(vdplim,.02)
6482             RSURFQ=RA(LCELL)+1./vdplim
6483     !       RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6484     !
6485 !   limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6486 !
6487     !       RSURFQ=max(RSURFQ,50.)
6488             SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ)  ! Quadrature sum for 0 moment
6489             SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3  ! Quadrature sum for 3rd moment
6490             ENDDO
6491             VDEP(LCELL, VDNNUC) = SUM0/sqrtpi  ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6492             VDEP(LCELL, VDMNUC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgn)**2)*DGNUC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6493
6494 ! *** accumulation mode
6495
6496             SUM0=0.
6497             SUM3=0.
6498             DO N=1,NGAUSdv
6499             DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga)  ! Diameter (m) at quadrature point
6500             KNQ=2.*XLM(LCELL)/DQ  ! Knudsen number at quadrature point
6501             CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ))  ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6502             VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ  ! Gravitational sedimentation velocity m/s
6503             SCQ=NU*DQ/DCONST1/CUNQ  ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6504             Eff_dif=SCQ**(-TWO3)    ! Efficiency term for diffusion - Same as Binkowski and Shankar
6505             STQ=DCONST3*PDENSA(LCELL)*DQ**2  ! Stokes number, Peters and Eiden (1992)
6506             Eff_imp=(STQ/(0.8+STQ))**2   ! Efficiency term for impaction - Peters and Eiden (1992)
6507     !       Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6508             Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6509             RBcor=1. ! Rebound correction factor
6510             vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6511             vdplim=min(vdplim,.02)
6512             RSURFQ=RA(LCELL)+1./vdplim
6513 !       RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6514 !
6515 !   limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6516 !
6517 !       RSURFQ=max(RSURFQ,50.)
6518         SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ)  ! Quadrature sum for 0 moment
6519         SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3  ! Quadrature sum for 3rd moment
6520           IF(iprnt.eq.1)THEN
6521               print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ'
6522               print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ
6523               print *,'N,Eff_dif,imp,int,SUM0,SUM3'
6524               print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3
6525           endif
6526         ENDDO
6527         VDEP(LCELL, VDNACC) = SUM0/sqrtpi  ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6528         VDEP(LCELL, VDMACC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsga)**2)*DGACC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6529
6530 ! *** coarse mode
6531
6532         SUM0=0.
6533         SUM3=0.
6534         DO N=1,NGAUSdv
6535            DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc)  ! Diameter (m) at quadrature point
6536            KNQ=2.*XLM(LCELL)/DQ  ! Knudsen number at quadrature point
6537            CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ))  ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6538            VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ  ! Gravitational sedimentation velocity m/s
6539            SCQ=NU*DQ/DCONST1/CUNQ  ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6540            Eff_dif=SCQ**(-TWO3)    ! Efficiency term for diffusion - Same as Binkowski and Shankar
6541            STQ=DCONST3*PDENSC(LCELL)*DQ**2  ! Stokes number, Peters and Eiden (1992)
6542            Eff_imp=(STQ/(0.8+STQ))**2   ! Efficiency term for impaction - Peters and Eiden (1992)
6543 !          Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6544            Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Interception term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6545            EFF_int=min(1.,EFF_int)
6546            RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982)
6547            vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6548            vdplim=min(vdplim,.02)
6549            RSURFQ=RA(LCELL)+1./vdplim
6550 !       RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6551 !
6552 !   limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6553 !
6554 !       RSURFQ=max(RSURFQ,50.)
6555            SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ)  ! Quadrature sum for 0 moment
6556            SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3  ! Quadrature sum for 3rd moment
6557         ENDDO
6558             VDEP(LCELL, VDNCOR) = SUM0/sqrtpi  ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6559             VDEP(LCELL, VDMCOR) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgc)**2)*DGCOR(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6560         END DO
6561
6562         ENDIF  ! ENDOF LAYER = 1 test
6563
6564 ! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995)
6565
6566          DO LCELL = 1, NUMCELLS
6567
6568             DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6569             DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6570             DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6571             DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6572
6573 ! *** nucleation mode number and mass sedimentation velociticies
6574             VSED( LCELL, VSNNUC) = DCONST3N                         &
6575                * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6576             VSED( LCELL, VSMNUC) = DCONST3N                         &
6577                * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6578
6579 ! *** accumulation mode number and mass sedimentation velociticies
6580             VSED( LCELL, VSNACC) = DCONST3A                          &
6581               * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6582             VSED( LCELL, VSMACC) = DCONST3A                          &
6583               * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6584
6585 ! *** coarse mode number and mass sedimentation velociticies
6586             VSED( LCELL, VSNCOR) = DCONST3C                          &
6587               * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6588             VSED( LCELL, VSMCOR) = DCONST3C                          &
6589               * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6590          END DO
6591 END SUBROUTINE VDVG_2
6592 !------------------------------------------------------------------------------
6593
6594 SUBROUTINE         aerosols_soa_vbs_init(chem,convfac,z_at_w,                   &
6595                    pm2_5_dry,pm2_5_water,pm2_5_dry_ec,                         &
6596                    chem_in_opt,aer_ic_opt, is_aerosol,                         &
6597                    ids,ide, jds,jde, kds,kde,                                  &
6598                    ims,ime, jms,jme, kms,kme,                                  &
6599                    its,ite, jts,jte, kts,kte, config_flags                     )
6600
6601     USE module_configure, only: grid_config_rec_type
6602 !!! TUCCELLA (BUG, commented the line below)
6603     !USE module_prep_wetscav_sorgam,only: aerosols_soa_vbs_init_aercld_ptrs
6604
6605    implicit none
6606    INTEGER,      INTENT(IN   ) ::  chem_in_opt,aer_ic_opt
6607    INTEGER,      INTENT(IN   ) ::  ids,ide, jds,jde, kds,kde,    &
6608                                    ims,ime, jms,jme, kms,kme,    &
6609                                    its,ite, jts,jte, kts,kte
6610    LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
6611    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) ,     &
6612           INTENT(INOUT   ) ::                                      &
6613                               chem
6614    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
6615           INTENT(INOUT      ) ::                                   &
6616                      pm2_5_dry,pm2_5_water,pm2_5_dry_ec
6617    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
6618           INTENT(IN      ) ::                                      &
6619                    convfac
6620    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
6621           INTENT(IN         ) ::                                   &
6622                      z_at_w
6623    TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
6624
6625
6626      integer i,j,k,l,ii,jj,kk
6627      real tempfac,mwso4,zz
6628 !    real,dimension(its:ite,kts:kte,jts:jte) :: convfac
6629       REAL splitfac
6630                         !between gas and aerosol phase
6631       REAL so4vaptoaer
6632 !factor for splitting initial conc. of SO4
6633 !3rd moment i-mode [3rd moment/m^3]
6634       REAL m3nuc
6635 !3rd MOMENT j-mode [3rd moment/m^3]
6636       REAL m3acc
6637 !       REAL ESN36
6638       REAL m3cor
6639       DATA splitfac/.98/
6640       DATA so4vaptoaer/.999/
6641
6642 ! *** Compute these once and they will all  be saved in COMMON
6643         xxlsgn = log(sginin)
6644         xxlsga = log(sginia)
6645         xxlsgc = log(sginic)
6646
6647         l2sginin = xxlsgn**2
6648         l2sginia = xxlsga**2
6649         l2sginic = xxlsgc**2
6650
6651         en1 = exp(0.125*l2sginin)
6652         ea1 = exp(0.125*l2sginia)
6653         ec1 = exp(0.125*l2sginic)
6654
6655         esn04 = en1**4
6656         esa04 = ea1**4
6657         esc04 = ec1**4
6658
6659         esn05 = esn04*en1
6660         esa05 = esa04*ea1
6661
6662         esn08 = esn04*esn04
6663         esa08 = esa04*esa04
6664         esc08 = esc04*esc04
6665
6666         esn09 = esn04*esn05
6667         esa09 = esa04*esa05
6668
6669         esn12 = esn04*esn04*esn04
6670         esa12 = esa04*esa04*esa04
6671         esc12 = esc04*esc04*esc04
6672
6673         esn16 = esn08*esn08
6674         esa16 = esa08*esa08
6675         esc16 = esc08*esc08
6676
6677         esn20 = esn16*esn04
6678         esa20 = esa16*esa04
6679         esc20 = esc16*esc04
6680
6681         esn24 = esn12*esn12
6682         esa24 = esa12*esa12
6683         esc24 = esc12*esc12
6684
6685         esn25 = esn16*esn09
6686         esa25 = esa16*esa09
6687
6688         esn28 = esn20*esn08
6689         esa28 = esa20*esa08
6690         esc28 = esc20*esc08
6691
6692
6693         esn32 = esn16*esn16
6694         esa32 = esa16*esa16
6695         esc32 = esc16*esc16
6696
6697         esn36 = esn16*esn20
6698         esa36 = esa16*esa20
6699         esc36 = esc16*esc20
6700
6701         esn49 = esn25*esn20*esn04
6702         esa49 = esa25*esa20*esa04
6703
6704         esn52 = esn16*esn36
6705         esa52 = esa16*esa36
6706
6707         esn64 = esn32*esn32
6708         esa64 = esa32*esa32
6709         esc64 = esc32*esc32
6710
6711         esn100 = esn36*esn64
6712
6713         esnm20 = 1.0/esn20
6714         esam20 = 1.0/esa20
6715         escm20 = 1.0/esc20
6716
6717         esnm32 = 1.0/esn32
6718         esam32 = 1.0/esa32
6719         escm32 = 1.0/esc32
6720
6721         xxm3 = 3.0*xxlsgn/ sqrt2
6722 ! factor used in error function cal
6723         nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
6724
6725         nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
6726
6727         nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
6728
6729 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
6730 !     size distribution , then
6731
6732 !        vol = (p/6) * density * num * (dgemv_xx**3) *
6733 !                            exp(- 4.5 * log( sgem_xx)**2 ) )
6734 !        note minus sign!!
6735
6736         factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
6737         factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
6738         factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
6739         ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
6740         ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
6741         mwso4=96.03
6742
6743 !   initialize pointers used by aerosol-cloud-interaction routines
6744 ! TUCCELLA (BUG, now aerosols_soa_vbs_aercld_ptrs is called chemics_init.F !
6745 !                and was moved to module_prep_wetscav_sorgam.F)
6746
6747         !call aerosols_soa_vbs_init_aercld_ptrs( &
6748         !   num_chem, is_aerosol, config_flags )
6749
6750         pm2_5_dry(its:ite, kts:kte-1, jts:jte)    = 0.
6751         pm2_5_water(its:ite, kts:kte-1, jts:jte)  = 0.
6752         pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
6753
6754 !SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv
6755
6756         Y_GQ(1)=-2.651961356835233
6757         WGAUS(1)=0.0009717812450995
6758         Y_GQ(2)=-1.673551628767471
6759         WGAUS(2)=0.05451558281913
6760         Y_GQ(3)=-0.816287882858965
6761         WGAUS(3)=0.4256072526101
6762         Y_GQ(4)=-0.0
6763         WGAUS(4)=0.8102646175568
6764         Y_GQ(5)=0.816287882858965
6765         WGAUS(5)=WGAUS(3)
6766         Y_GQ(6)=1.673551628767471
6767         WGAUS(6)=WGAUS(2)
6768         Y_GQ(7)=2.651961356835233
6769         WGAUS(7)=WGAUS(1)
6770 !
6771 !  IF USING OLD SIMULATION, DO NOT REINITIALIZE!
6772 !
6773         if(chem_in_opt == 1  .OR. config_flags%restart) return
6774         do l=p_so4aj,num_chem
6775            chem(ims:ime,kms:kme,jms:jme,l)=epsilc
6776         enddo
6777         chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
6778         chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
6779         do j=jts,jte
6780            jj=min(jde-1,j)
6781         do k=kts,kte-1
6782            kk=min(kde-1,k)
6783         do i=its,ite
6784            ii=min(ide-1,i)
6785
6786 !Option for alternate ic's
6787         if( aer_ic_opt == AER_IC_DEFAULT ) then
6788           chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer
6789           chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*(1.-splitfac)*so4vaptoaer
6790           chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
6791           chem(i,k,j,p_nh4aj) = 10.E-05
6792           chem(i,k,j,p_nh4ai) = 10.E-05
6793           chem(i,k,j,p_no3aj) = 10.E-05
6794           chem(i,k,j,p_no3ai) = 10.E-05
6795           chem(i,k,j,p_naaj)  = 10.E-05
6796           chem(i,k,j,p_naai)  = 10.E-05
6797           chem(i,k,j,p_claj)  = 10.E-05
6798           chem(i,k,j,p_clai)  = 10.E-05
6799 !liqy
6800           chem(i,k,j,p_caaj)  = 10.E-05
6801           chem(i,k,j,p_caai)  = 10.E-05
6802           chem(i,k,j,p_kaj)   = 10.E-05
6803           chem(i,k,j,p_kai)   = 10.E-05
6804           chem(i,k,j,p_mgaj)  = 10.E-05
6805           chem(i,k,j,p_mgai)  = 10.E-05
6806 !liqy-20140619
6807 !        elseif( aer_ic_opt == AER_IC_PNNL ) then
6808 !           zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5
6809 !           call soa_vbs_init_aer_ic_pnnl(   &
6810 !                chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
6811         else
6812            call wrf_error_fatal(   &
6813                 "aerosols_soa_vbs_init: unable to parse aer_ic_opt" )
6814         end if
6815
6816 !... i-mode
6817       m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
6818         no3fac*chem(i,k,j,p_no3ai) +                                    &
6819         nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) +           &
6820 !liqy
6821         cafac*chem(i,k,j,p_caai) + kfac*chem(i,k,j,p_kai) + &
6822                 mgfac*chem(i,k,j,p_mgai) +              &
6823 !liqy-20140619
6824         orgfac*chem(i,k,j,p_asoa1i) + &
6825         orgfac*chem(i,k,j,p_asoa2i) + orgfac*chem(i,k,j,p_asoa3i) + &
6826         orgfac*chem(i,k,j,p_asoa4i) + orgfac*chem(i,k,j,p_bsoa1i) + &
6827         orgfac*chem(i,k,j,p_bsoa2i) + orgfac*chem(i,k,j,p_bsoa3i) + &
6828         orgfac*chem(i,k,j,p_bsoa4i) + orgfac*chem(i,k,j,p_orgpai) + &
6829         anthfac*chem(i,k,j,p_p25i)  + anthfac*chem(i,k,j,p_eci)
6830
6831 !... j-mode
6832       m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + &
6833         no3fac*chem(i,k,j,p_no3aj)  +                                    &
6834         nafac*chem(i,k,j,p_naaj)    + clfac*chem(i,k,j,p_claj) +         &
6835 !liqy
6836         cafac*chem(i,k,j,p_caaj) + kfac*chem(i,k,j,p_kaj) + &
6837                 mgfac*chem(i,k,j,p_mgaj) +              &
6838 !liqy-20140619
6839         orgfac*chem(i,k,j,p_asoa1j) + &
6840         orgfac*chem(i,k,j,p_asoa2j) + orgfac*chem(i,k,j,p_asoa3j) + &
6841         orgfac*chem(i,k,j,p_asoa4j) + orgfac*chem(i,k,j,p_bsoa1j) + &
6842         orgfac*chem(i,k,j,p_bsoa2j) + orgfac*chem(i,k,j,p_bsoa3j) + &
6843         orgfac*chem(i,k,j,p_bsoa4j) + orgfac*chem(i,k,j,p_orgpaj) + &
6844         anthfac*chem(i,k,j,p_p25j)  + anthfac*chem(i,k,j,p_ecj)
6845
6846 !...c-mode
6847       m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
6848         anthfac*chem(i,k,j,p_antha)
6849
6850 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
6851       chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
6852
6853       chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
6854
6855       chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
6856
6857       enddo
6858       enddo
6859       enddo
6860
6861     return
6862     END SUBROUTINE aerosols_soa_vbs_init
6863
6864 !
6865 SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem,                      &
6866                              ebu,                                                               &
6867                              slai,ust,smois,ivgtyp,isltyp,                                      &
6868                              emis_ant,dust_emiss_active,                                        &
6869                              seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt,          &
6870                              dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod,                   &
6871                              ids,ide, jds,jde, kds,kde,                                         &
6872                              ims,ime, jms,jme, kms,kme,                                         &
6873                              its,ite, jts,jte, kts,kte                                          )
6874 !
6875 ! Routine to apply aerosol emissions for MADE/SOA_VBS...
6876 ! William.Gustafson@pnl.gov; 3-May-2007
6877 ! Modified by
6878 ! steven.peckham@noaa.gov;   8-Jan-2008
6879 !------------------------------------------------------------------------
6880
6881   USE module_state_description, only:  num_chem
6882
6883   INTEGER, INTENT(IN   )   ::    seasalt_emiss_active,kemit,emissopt,   &
6884                                  dust_emiss_active,num_soil_layers,id,  &
6885                                  ktau,dust_opt,biom,                    &
6886                                  ids,ide, jds,jde, kds,kde,             &
6887                                  ims,ime, jms,jme, kms,kme,             &
6888                                  its,ite, jts,jte, kts,kte
6889
6890   REAL, INTENT(IN   ) ::    dtstep
6891
6892 ! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air)
6893   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),               &
6894        INTENT(INOUT ) ::   chem
6895 !
6896 ! aerosol emissions arrays ((ug/m3)*m/s)
6897 !
6898    REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ),         &
6899          INTENT(IN    ) ::    emis_ant
6900
6901 ! biomass burning aerosol emissions arrays ((ug/m3)*m/s)
6902    REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ),              &
6903          INTENT(IN    ) ::    ebu
6904
6905 ! 1/(dry air density) and layer thickness (m)
6906   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ),                      &
6907        INTENT(IN   ) ::                                                 &
6908        alt, dz8w
6909
6910   ! add for gocart dust
6911   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
6912         INTENT(IN    ) :: p8w,u_phy,v_phy,rho_phy
6913   REAL, INTENT(IN    ) :: dx, g
6914   REAL, DIMENSION( ims:ime, jms:jme, 3 ),                              &
6915          INTENT(IN    ) :: erod
6916
6917   REAL,  DIMENSION( ims:ime , jms:jme ),                                &
6918        INTENT(IN   ) ::                                                 &
6919        u10, v10, xland, slai, ust
6920   INTEGER,  DIMENSION( ims:ime , jms:jme ),                             &
6921        INTENT(IN   ) ::   ivgtyp, isltyp
6922   REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ),    &
6923        INTENT(INOUT) ::   smois
6924
6925 ! Local variables...
6926   real, dimension(its:ite,kts:kte,jts:jte) :: factor
6927 !
6928 ! Get the emissions unit conversion factor including the time step.
6929 ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep]
6930 !
6931   factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ &
6932                   dz8w(its:ite,kts:kte,jts:jte)
6933 !
6934 ! Increment the aerosol numbers...
6935 !
6936 ! Increment the aerosol numbers...
6937     if(emissopt  .lt. 5 )then
6938 !
6939 ! Aitken mode first...
6940
6941   chem(its:ite,kts:kemit,jts:jte,p_nu0) =                        &
6942        chem(its:ite,kts:kemit,jts:jte,p_nu0) +                   &
6943        factor(its:ite,kts:kemit,jts:jte)*factnumn*(                                  &
6944        anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) +            &
6945        emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)  +                      &
6946        emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) +                      &
6947        orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) )
6948
6949 ! Accumulation mode next...
6950
6951   chem(its:ite,kts:kemit,jts:jte,p_ac0) =                        &
6952        chem(its:ite,kts:kemit,jts:jte,p_ac0) +                   &
6953        factor(its:ite,kts:kemit,jts:jte)*factnuma*(                                  &
6954        anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) +            &
6955        emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)  +                      &
6956        emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) +                      &
6957        orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) )
6958
6959 ! And now the coarse mode...
6960
6961   chem(its:ite,kts:kemit,jts:jte,p_corn) =                       &
6962        chem(its:ite,kts:kemit,jts:jte,p_corn) +                  &
6963        factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac*                           &
6964        emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)
6965 !
6966 ! Increment the aerosol masses...
6967 !
6968   chem(its:ite,kts:kemit,jts:jte,p_antha) =                      &
6969        chem(its:ite,kts:kemit,jts:jte,p_antha) +                 &
6970        emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte)
6971
6972   chem(its:ite,kts:kemit,jts:jte,p_p25j) =                       &
6973        chem(its:ite,kts:kemit,jts:jte,p_p25j) +                  &
6974        emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte)
6975
6976   chem(its:ite,kts:kemit,jts:jte,p_p25i) =                       &
6977        chem(its:ite,kts:kemit,jts:jte,p_p25i) +                  &
6978        emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte)
6979
6980   chem(its:ite,kts:kemit,jts:jte,p_ecj) =                        &
6981        chem(its:ite,kts:kemit,jts:jte,p_ecj) +                   &
6982        emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte)
6983
6984   chem(its:ite,kts:kemit,jts:jte,p_eci) =                        &
6985        chem(its:ite,kts:kemit,jts:jte,p_eci) +                   &
6986        emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte)
6987   chem(its:ite,kts:kemit,jts:jte,p_naaj) =                        &
6988        chem(its:ite,kts:kemit,jts:jte,p_naaj) +                   &
6989        emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte)
6990   chem(its:ite,kts:kemit,jts:jte,p_naai) =                        &
6991        chem(its:ite,kts:kemit,jts:jte,p_naai) +                   &
6992        emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte)
6993
6994   chem(its:ite,kts:kemit,jts:jte,p_orgpaj) =                     &
6995        chem(its:ite,kts:kemit,jts:jte,p_orgpaj) +                &
6996        emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte)
6997
6998   chem(its:ite,kts:kemit,jts:jte,p_orgpai) =                     &
6999        chem(its:ite,kts:kemit,jts:jte,p_orgpai) +                &
7000        emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte)
7001
7002   chem(its:ite,kts:kemit,jts:jte,p_so4aj) =                      &
7003        chem(its:ite,kts:kemit,jts:jte,p_so4aj) +                 &
7004        emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte)
7005
7006   chem(its:ite,kts:kemit,jts:jte,p_so4ai) =                      &
7007        chem(its:ite,kts:kemit,jts:jte,p_so4ai) +                 &
7008        emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte)
7009
7010   chem(its:ite,kts:kemit,jts:jte,p_no3aj) =                      &
7011        chem(its:ite,kts:kemit,jts:jte,p_no3aj) +                 &
7012        emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte)
7013
7014   chem(its:ite,kts:kemit,jts:jte,p_no3ai) =                      &
7015        chem(its:ite,kts:kemit,jts:jte,p_no3ai) +                 &
7016        emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte)
7017 !liqy
7018   chem(its:ite,kts:kemit,jts:jte,p_claj) =                      &
7019        chem(its:ite,kts:kemit,jts:jte,p_claj) +                 &
7020        emis_ant(its:ite,kts:kemit,jts:jte,p_e_clj)*factor(its:ite,kts:kemit,jts:jte)
7021
7022   chem(its:ite,kts:kemit,jts:jte,p_clai) =                      &
7023        chem(its:ite,kts:kemit,jts:jte,p_clai) +                 &
7024        emis_ant(its:ite,kts:kemit,jts:jte,p_e_cli)*factor(its:ite,kts:kemit,jts:jte)
7025 !liqy-20150625
7026   elseif(emissopt == 5)then
7027 !
7028 ! Aitken mode first...
7029
7030   chem(its:ite,kts:kemit,jts:jte,p_nu0) =                        &
7031        chem(its:ite,kts:kemit,jts:jte,p_nu0) +                   &
7032        factor(its:ite,kts:kemit,jts:jte)*factnumn*(                                  &
7033        anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) +                      &
7034        orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7035
7036 ! Accumulation mode next...
7037
7038   chem(its:ite,kts:kemit,jts:jte,p_ac0) =                        &
7039        chem(its:ite,kts:kemit,jts:jte,p_ac0) +                   &
7040        factor(its:ite,kts:kemit,jts:jte)*factnuma*(                                  &
7041        anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) +                      &
7042        orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7043
7044 !
7045 ! Increment the aerosol masses...
7046 !
7047
7048   chem(its:ite,kts:kemit,jts:jte,p_ecj) =                        &
7049        chem(its:ite,kts:kemit,jts:jte,p_ecj) +                   &
7050        .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7051
7052   chem(its:ite,kts:kemit,jts:jte,p_eci) =                        &
7053        chem(its:ite,kts:kemit,jts:jte,p_eci) +                   &
7054        .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7055
7056   chem(its:ite,kts:kemit,jts:jte,p_orgpaj) =                     &
7057        chem(its:ite,kts:kemit,jts:jte,p_orgpaj) +                &
7058        .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7059
7060   chem(its:ite,kts:kemit,jts:jte,p_orgpai) =                     &
7061        chem(its:ite,kts:kemit,jts:jte,p_orgpai) +                &
7062        .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7063
7064   endif
7065 ! add biomass burning emissions if present
7066 !
7067   if(biom == 1 )then
7068 !
7069 ! Aitken mode first...
7070
7071   chem(its:ite,kts:kte,jts:jte,p_nu0) =                        &
7072        chem(its:ite,kts:kte,jts:jte,p_nu0) +                   &
7073        factor(its:ite,kts:kte,jts:jte)*factnumn*(              &
7074        anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) +       &
7075               .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) +          &
7076        orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7077
7078 ! Accumulation mode next...
7079
7080   chem(its:ite,kts:kte,jts:jte,p_ac0) =                        &
7081        chem(its:ite,kts:kte,jts:jte,p_ac0) +                   &
7082        factor(its:ite,kts:kte,jts:jte)*factnuma*(              &
7083        anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) +        &
7084       .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) +                  &
7085        orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7086 ! coarse
7087   chem(its:ite,kts:kte,jts:jte,p_corn) =                     &
7088        chem(its:ite,kts:kte,jts:jte,p_corn) +                  &
7089        factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac*       &
7090        ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)
7091
7092 !
7093 ! Increment the aerosol masses...
7094 !
7095
7096   chem(its:ite,kts:kte,jts:jte,p_ecj) =                        &
7097        chem(its:ite,kts:kte,jts:jte,p_ecj) +                   &
7098        .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7099
7100   chem(its:ite,kts:kte,jts:jte,p_eci) =                        &
7101        chem(its:ite,kts:kte,jts:jte,p_eci) +                   &
7102        .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7103
7104   chem(its:ite,kts:kte,jts:jte,p_orgpaj) =                     &
7105        chem(its:ite,kts:kte,jts:jte,p_orgpaj) +                &
7106        .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7107
7108   chem(its:ite,kts:kte,jts:jte,p_orgpai) =                     &
7109        chem(its:ite,kts:kte,jts:jte,p_orgpai) +                &
7110        .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7111
7112   chem(its:ite,kts:kte,jts:jte,p_antha) =                      &
7113        chem(its:ite,kts:kte,jts:jte,p_antha) +                 &
7114        ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte)
7115
7116   chem(its:ite,kts:kte,jts:jte,p_p25j) =                       &
7117        chem(its:ite,kts:kte,jts:jte,p_p25j) +                  &
7118        .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7119
7120   chem(its:ite,kts:kte,jts:jte,p_p25i) =                       &
7121        chem(its:ite,kts:kte,jts:jte,p_p25i) +                  &
7122        .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7123
7124    endif !end biomass burning
7125 !
7126 ! Get the sea salt emissions...
7127 !
7128   if( seasalt_emiss_active == 1 ) then
7129      call soa_vbs_seasalt_emiss(                                  &
7130           dtstep, u10, v10, alt, dz8w, xland, chem,              &
7131           ids,ide, jds,jde, kds,kde,                             &
7132           ims,ime, jms,jme, kms,kme,                             &
7133           its,ite, jts,jte, kts,kte                              )
7134   end if
7135  ! if( seasalt_emiss_active == 2 ) then
7136  ! end if
7137   if( dust_opt == 2 ) then
7138     call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13")
7139       call soa_vbs_dust_emiss(                                     &
7140            slai, ust, smois, ivgtyp, isltyp,                      &
7141            id, dtstep, u10, v10, alt, dz8w,                       &
7142            xland, num_soil_layers, chem,                          &
7143            ids,ide, jds,jde, kds,kde,                             &
7144            ims,ime, jms,jme, kms,kme,                             &
7145            its,ite, jts,jte, kts,kte                              )
7146   end if
7147  !     dust_opt changed to 13 since it conflicts with gocart/afwa
7148   if( dust_opt == 13 ) then
7149    !czhao --------------------------
7150       call soa_vbs_dust_gocartemis(                                &
7151            ktau,dtstep,num_soil_layers,alt,u_phy,                 &
7152            v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,        &
7153            ivgtyp,isltyp,xland,dx,g,                              &
7154            ids,ide, jds,jde, kds,kde,                             &
7155            ims,ime, jms,jme, kms,kme,                             &
7156            its,ite, jts,jte, kts,kte                              )
7157   end if
7158
7159 END SUBROUTINE soa_vbs_addemiss
7160
7161 !------------------------------------------------------------------------
7162 SUBROUTINE soa_vbs_seasalt_emiss(                                        &
7163      dtstep, u10, v10, alt, dz8w, xland, chem,                          &
7164      ids,ide, jds,jde, kds,kde,                                         &
7165      ims,ime, jms,jme, kms,kme,                                         &
7166      its,ite, jts,jte, kts,kte                                          )
7167 !
7168 ! Routine to calculate seasalt emissions for SOA_VBS over the time
7169 ! dtstep...
7170 ! William.Gustafson@pnl.gov; 10-May-2007
7171 !------------------------------------------------------------------------
7172
7173    USE module_mosaic_addemiss, only:    seasalt_emitfactors_1bin
7174
7175    IMPLICIT NONE
7176
7177    INTEGER,      INTENT(IN   ) :: ids,ide, jds,jde, kds,kde,            &
7178                                   ims,ime, jms,jme, kms,kme,            &
7179                                   its,ite, jts,jte, kts,kte
7180
7181    REAL, INTENT(IN   ) ::    dtstep
7182
7183 ! 10-m wind speed components (m/s)
7184    REAL,  DIMENSION( ims:ime , jms:jme ),                               &
7185           INTENT(IN   ) ::   u10, v10, xland
7186
7187 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7188    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),              &
7189          INTENT(INOUT ) ::   chem
7190
7191 ! alt  = 1.0/(dry air density) in (m3/kg)
7192 ! dz8w = layer thickness in (m)
7193    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ),                     &
7194          INTENT(IN   ) ::   alt, dz8w
7195
7196 ! local variables
7197    integer :: i, j, k, l, l_na, l_cl, n
7198     integer :: p1st
7199
7200     real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
7201     real :: factaa, factbb, fraccl, fracna
7202 !liqy
7203         real :: fracca, frack,  fracmg, fracso4
7204 !liqy-20140709
7205
7206     real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c
7207     real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c
7208
7209
7210 !   Compute emissions factors for the Aitken mode...
7211 !   Nope, we won't because the parameterization is only valid down to
7212 !   0.1 microns.
7213 !   Setup in units of cm.
7214 !    dumdlo = 0.039e-4
7215 !    dumdhi = 0.078e-4
7216     ssemfact_numb_i = 0.
7217     ssemfact_mass_i = 0.
7218
7219 !   Compute emissions factors for the accumulation mode...
7220 !   Potentially, we could go down to 0.078 microns to match the bin
7221 !   boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end
7222 !   has been chosen to match the MOSAIC bin boundary closest to two
7223 !   standard deviations from the default bin mean diameter for the coarse
7224 !   mode.
7225     dumdlo = 0.1e-4
7226     dumdhi = 1.250e-4
7227     call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi,   &
7228          ssemfact_numb_j, dum, ssemfact_mass_j )
7229
7230 !   Compute emissions factors for the coarse mode...
7231     dumdlo = 1.25e-4
7232     dumdhi = 10.0e-4
7233     call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi,   &
7234          ssemfact_numb_c, dum, ssemfact_mass_c )
7235
7236 !   Convert mass emissions factor from (g/m2/s) to (ug/m2/s)
7237     ssemfact_mass_i = ssemfact_mass_i*1.0e6
7238     ssemfact_mass_j = ssemfact_mass_j*1.0e6
7239     ssemfact_mass_c = ssemfact_mass_c*1.0e6
7240
7241 !   Loop over i,j and apply seasalt emissions
7242     k = kts
7243     do j = jts, jte
7244     do i = its, ite
7245
7246     !Skip this point if over land. xland=1 for land and 2 for water.
7247     !Also, there is no way to differentiate fresh from salt water.
7248     !Currently, this assumes all water is salty.
7249        if( xland(i,j) < 1.5 ) cycle
7250
7251     !wig: As far as I can tell, only real.exe knows the fractional breakdown
7252     !     of land use. So, in wrf.exe, dumoceanfrac will always be 1.
7253        dumoceanfrac = 1. !fraction of grid i,j that is salt water
7254        dumspd10 = dumoceanfrac* &
7255             ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
7256
7257 !   factaa is (s*m2/kg-air)
7258 !   factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air
7259 !   factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) =  #/kg-air
7260        factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7261        factbb = factaa * dumspd10
7262
7263 !liqy
7264 !comment out the old assumption, i.e. "Apportion seasalt mass emissions
7265 !assumming that seasalt is pure NaCl".
7266 !       fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
7267 !       fraccl = 1.0 - fracna
7268                 fracna = 10.7838/35.171
7269                 fraccl = 19.3529/35.171
7270                 fracca =  0.4121/35.171
7271                 frack  =  0.3991/35.171
7272                 fracmg =  1.2837/35.171
7273                 fracso4 =  0.0       !2.7124/35.171
7274
7275 !   Add the emissions into the chem array...
7276        chem(i,k,j,p_naai) = chem(i,k,j,p_naai) +   &
7277                             factbb * ssemfact_mass_i * fracna
7278        chem(i,k,j,p_clai) = chem(i,k,j,p_clai) +   &
7279                             factbb * ssemfact_mass_i * fraccl
7280         chem(i,k,j,p_caai) = chem(i,k,j,p_caai) +  &
7281                         factbb * ssemfact_mass_i * fracca
7282         chem(i,k,j,p_kai) = chem(i,k,j,p_kai) +  &
7283                         factbb * ssemfact_mass_i * frack
7284         chem(i,k,j,p_mgai) = chem(i,k,j,p_mgai) +  &
7285                         factbb * ssemfact_mass_i * fracmg
7286 !       chem(i,k,j,p_so4ai) = chem(i,k,j,p_so4ai) + &
7287 !                       factbb * ssemfact_mass_i * fracso4
7288         chem(i,k,j,p_nu0)  = chem(i,k,j,p_nu0) +   &
7289                             factbb * ssemfact_numb_i
7290
7291 !-------------------------------------------------------------------------
7292
7293 !-------------------------------------------------------------------------
7294        chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) +   &
7295                             factbb * ssemfact_mass_j * fracna
7296        chem(i,k,j,p_claj) = chem(i,k,j,p_claj) +   &
7297                             factbb * ssemfact_mass_j * fraccl
7298         chem(i,k,j,p_caaj) = chem(i,k,j,p_caaj) +  &
7299                                 factbb * ssemfact_mass_j * fracca
7300         chem(i,k,j,p_kaj) = chem(i,k,j,p_kaj) +  &
7301                                 factbb * ssemfact_mass_j * frack
7302         chem(i,k,j,p_mgaj) = chem(i,k,j,p_mgaj) +  &
7303                                 factbb * ssemfact_mass_j * fracmg
7304 !       chem(i,k,j,p_so4aj) = chem(i,k,j,p_so4aj) + &
7305 !                               factbb * ssemfact_mass_j * fracso4
7306        chem(i,k,j,p_ac0)  = chem(i,k,j,p_ac0) +   &
7307                             factbb * ssemfact_numb_j
7308
7309 !-------------------------------------------------------------------------
7310        chem(i,k,j,p_seas) = chem(i,k,j,p_seas) +   &
7311                             factbb * ssemfact_mass_c
7312        chem(i,k,j,p_corn) = chem(i,k,j,p_corn) +   &
7313                             factbb * ssemfact_numb_c
7314 !liqy-20140709
7315
7316     end do !i
7317     end do !j
7318 END SUBROUTINE soa_vbs_seasalt_emiss
7319 !----------------------------------------------------------------------
7320
7321    subroutine soa_vbs_dust_emiss(  slai,ust, smois, ivgtyp, isltyp,         &
7322                id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers,    &
7323                chem,                                                       &
7324                ids,ide, jds,jde, kds,kde,                                  &
7325                ims,ime, jms,jme, kms,kme,                                  &
7326                its,ite, jts,jte, kts,kte                                   )
7327 !
7328 ! adds dust emissions for mosaic aerosol species (i.e. emission tendencies
7329 ! over time dtstep are applied to the aerosol mixing ratios)
7330 !
7331 ! This is a simple dust scheme based on Shaw et al. (2008) to appear in
7332 ! Atmospheric Environment, recoded by Jerome Fast
7333 !
7334 ! NOTE:
7335 ! 1) This version only works with the 8-bin version of MOSAIC.
7336 ! 2) Dust added to MOSAIC's other inorganic specie, OIN.  If Ca and CO3 are
7337 !    activated in the Registry, a small fraction also added to Ca and CO3.
7338 ! 3) The main departure from Shaw et al., is now alphamask is computed since
7339 !    the land-use categories in that paper and in WRF differ.  WRF currently
7340 !    does not have that many land-use categories and adhoc assumptions had to
7341 !    be made. This version was tested for Mexico in the dry season.  The main
7342 !    land-use categories in WRF that are likely dust sources are grass, shrub,
7343 !    and savannna (that WRF has in the desert regions of NW Mexico).  Having
7344 !    dust emitted from these types for other locations and other times of the
7345 !    year is not likely to be valid.
7346 ! 4) An upper bound on ustar was placed because the surface parameterizations
7347 !    in WRF can produce unrealistically high values that lead to very high
7348 !    dust emission rates.
7349 ! 5) Other departures' from Shaw et al. noted below, but are probably not as
7350 !    important as 2) and 3).
7351 !
7352    USE module_configure, only:  grid_config_rec_type
7353    USE module_state_description, only:  num_chem, param_first_scalar
7354    USE module_data_mosaic_asect
7355
7356    IMPLICIT NONE
7357
7358 !  TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
7359
7360    INTEGER,      INTENT(IN   ) :: id,num_soil_layers,                      &
7361                                   ids,ide, jds,jde, kds,kde,               &
7362                                   ims,ime, jms,jme, kms,kme,               &
7363                                   its,ite, jts,jte, kts,kte
7364
7365    REAL, INTENT(IN   ) ::    dtstep
7366
7367 ! 10-m wind speed components (m/s)
7368    REAL,  DIMENSION( ims:ime , jms:jme ),                                  &
7369           INTENT(IN   ) ::   u10, v10, xland, slai, ust
7370    INTEGER,  DIMENSION( ims:ime , jms:jme ),                               &
7371           INTENT(IN   ) ::   ivgtyp, isltyp
7372
7373 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7374    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),                 &
7375          INTENT(INOUT ) ::   chem
7376
7377 ! alt  = 1.0/(dry air density) in (m3/kg)
7378 ! dz8w = layer thickness in (m)
7379    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,               &
7380           INTENT(IN   ) ::   alt, dz8w
7381
7382    REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) ,     &
7383           INTENT(INOUT) ::   smois
7384
7385 ! local variables
7386         integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
7387         integer iphase, itype, izob
7388         integer p1st
7389
7390         real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
7391         real factaa, factbb, fracoin, fracca, fracco3, fractot
7392 !liqy
7393         real dstfracna, dstfraccl, dstfracca, dstfrack, dstfracmg,dstfrac
7394 !liqy-20140709
7395         real ustart, ustar1, ustart0
7396         real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
7397         real smois_grav, wp, pclay
7398         real :: beta(4,7)
7399         real :: gamma(4), delta(4)
7400         real :: sz(8)
7401         real :: dustflux, densdust, mass1part
7402         real :: dp_meanvol_tmp
7403 !
7404 ! from Nickovic et al., JGR, 2001 and Shaw et al. 2007
7405 ! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7)
7406 ! beta (1,*) for 0.5-1 um
7407 ! beta (2,*) for 1-10 um
7408 ! beta (3,*) for 10-25 um
7409 ! beta (4,*) for 25-50 um
7410 !
7411         beta(1,1)=0.12
7412         beta(2,1)=0.04
7413         beta(3,1)=0.04
7414         beta(4,1)=0.80
7415         beta(1,2)=0.34
7416         beta(2,2)=0.28
7417         beta(3,2)=0.28
7418         beta(4,2)=0.10
7419         beta(1,3)=0.45
7420         beta(2,3)=0.15
7421         beta(3,3)=0.15
7422         beta(4,3)=0.25
7423         beta(1,4)=0.12
7424         beta(2,4)=0.09
7425         beta(3,4)=0.09
7426         beta(4,4)=0.70
7427         beta(1,5)=0.40
7428         beta(2,5)=0.05
7429         beta(3,5)=0.05
7430         beta(4,5)=0.50
7431         beta(1,6)=0.34
7432         beta(2,6)=0.18
7433         beta(3,6)=0.18
7434         beta(4,6)=0.30
7435         beta(1,7)=0.22
7436         beta(2,7)=0.09
7437         beta(3,7)=0.09
7438         beta(4,7)=0.60
7439         gamma(1)=0.08
7440         gamma(2)=1.00
7441         gamma(3)=1.00
7442         gamma(4)=0.12
7443 !
7444 ! * Mass fractions for each size bin. These values were recommended by
7445 !   Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM.
7446 ! * Changed slightly since Natelie's estimates do not add up to 1.0
7447 ! * This would need to be made more generic for other bin sizes.
7448 !       sz(1)=0
7449 !       sz(2)=1.78751e-06
7450 !       sz(3)=0.000273786
7451 !       sz(4)=0.00847978
7452 !       sz(5)=0.056055
7453 !       sz(6)=0.0951896
7454 !       sz(7)=0.17
7455 !       sz(8)=0.67
7456         sz(1)=0.0
7457         sz(2)=0.0
7458         sz(3)=0.0005
7459         sz(4)=0.0095
7460         sz(5)=0.03
7461         sz(6)=0.10
7462         sz(7)=0.18
7463         sz(8)=0.68
7464
7465 !   for now just do itype=1
7466         itype = 1
7467         iphase = ai_phase
7468
7469 !   loop over i,j and apply dust emissions
7470         k = kts
7471         do 1830 j = jts, jte
7472         do 1820 i = its, ite
7473
7474     if( xland(i,j) > 1.5 ) cycle
7475
7476 ! compute wind speed anyway, even though ustar is used below
7477
7478         dumlandfrac = 1.
7479         dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
7480         if(dumspd10 >= 5.0) then
7481            dumspd10 = dumlandfrac* &
7482          ( dumspd10*dumspd10*(dumspd10-5.0))
7483          else
7484             dumspd10=0.
7485          endif
7486
7487 ! part1 - compute vegetation mask
7488 !
7489 ! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories
7490 !   for desert, sand desert, grass aemi-desert, and shrub semi-desert
7491 ! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna
7492 !   that are dominate types in Mexico and probably have some erodable surface
7493 !   during the dry season
7494 ! * currently modified these values so that only a small fraction of cell
7495 !   area is erodable
7496 ! * these values are highly tuneable!
7497
7498          alphamask=0.001
7499          if (ivgtyp(i,j) .eq. 7) then
7500            f8=0.005
7501            f50=0.00
7502            f51=0.10
7503            f52=0.00
7504            alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7505          endif
7506          if (ivgtyp(i,j) .eq. 8) then
7507            f8=0.010
7508            f50=0.00
7509            f51=0.00
7510            f52=0.15
7511            alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7512          endif
7513          if (ivgtyp(i,j) .eq. 10) then
7514            f8=0.00
7515            f50=0.00
7516            f51=0.01
7517            f52=0.00
7518            alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7519          endif
7520
7521 ! part2 - zobler
7522 !
7523 ! * in Shaw's paper, dust is computed for 4 size ranges:
7524 !   0.5-1 um
7525 !    1-10 um
7526 !   10-25 um
7527 !   25-50 um
7528 ! * Shaw's paper also accounts for sub-grid variability in soil
7529 !   texture, but here we just assume the same soil texture for each
7530 !   grid cell
7531 ! * since MOSAIC is currently has a maximum size range up to 10 um,
7532 !   neglect upper 2 size ranges and lowest size range (assume small)
7533 ! * map WRF soil classes arbitrarily to Zolber soil textural classes
7534 ! * skip dust computations for WRF soil classes greater than 13, i.e.
7535 !   do not compute dust over water, bedrock, and other surfaces
7536 ! * should be skipping for water surface at this point anyway
7537 !
7538          izob=0
7539          if(isltyp(i,j).eq.1) izob=1
7540          if(isltyp(i,j).eq.2) izob=1
7541          if(isltyp(i,j).eq.3) izob=4
7542          if(isltyp(i,j).eq.4) izob=2
7543          if(isltyp(i,j).eq.5) izob=2
7544          if(isltyp(i,j).eq.6) izob=2
7545          if(isltyp(i,j).eq.7) izob=7
7546          if(isltyp(i,j).eq.8) izob=2
7547          if(isltyp(i,j).eq.9) izob=6
7548          if(isltyp(i,j).eq.10) izob=5
7549          if(isltyp(i,j).eq.11) izob=2
7550          if(isltyp(i,j).eq.12) izob=3
7551          if(isltyp(i,j).ge.13) izob=0
7552          if(izob.eq.0) goto 1840
7553 !
7554 ! part3 - dustprod
7555 !
7556          do ii=1,4
7557            delta(ii)=0.0
7558          enddo
7559          sumdelta=0.0
7560          do ii=1,4
7561            delta(ii)=beta(ii,izob)*gamma(ii)
7562            if(ii.lt.4) then
7563              sumdelta=sumdelta+delta(ii)
7564            endif
7565          enddo
7566          do ii=1,4
7567            delta(ii)=delta(ii)/sumdelta
7568          enddo
7569
7570 ! part4 - wetness
7571 !
7572 ! * assume dry for now, have passed in soil moisture to this routine
7573 !   but needs to be included here
7574 ! * wetfactor less than 1 would reduce dustflux
7575 ! * convert model soil moisture (m3/m3) to gravimetric soil moisture
7576 !   (mass of water / mass of soil in %) assuming a constant density
7577 !   for soil
7578          pclay=beta(1,izob)*100.
7579          wp=0.0014*pclay*pclay+0.17*pclay
7580          smois_grav=(smois(i,1,j)/2.6)*100.
7581          if(smois_grav.gt.wp) then
7582            wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
7583          else
7584            wetfactor=1.0
7585          endif
7586 !        wetfactor=1.0
7587
7588 ! part5 - dustflux
7589 ! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper
7590 ! bound to 100 cm/s
7591
7592          ustar1=ust(i,j)*100.0
7593          if(ustar1.gt.100.0) ustar1=100.0
7594          ustart0=20.0
7595          ustart=ustart0*wetfactor
7596          if(ustar1.le.ustart) then
7597            dustflux=0.0
7598          else
7599            dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1))
7600          endif
7601          dustflux=dustflux*10.0
7602 ! units kg m-2 s-1
7603          ftot=0.0
7604          do ii=1,2
7605            ftot=ftot+dustflux*alphamask*delta(ii)
7606          enddo
7607 ! convert to ug m-2 s-1
7608          ftot=ftot*1.0e+09
7609
7610 !   apportion other inorganics only
7611          factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7612          factbb = factaa * ftot
7613          fracoin = 1.00
7614 !        fracca = 0.03*0.4
7615 !        fracco3 = 0.03*0.6
7616          fracca = 0.0
7617          fracco3 = 0.0
7618          fractot = fracoin + fracca + fracco3
7619
7620 !liqy
7621
7622                 dstfracna = 0.0236
7623                 dstfraccl = 0.0
7624                 dstfracca = 0.0385
7625                 dstfrack  = 0.0214
7626                 dstfracmg = 0.0220
7627                 dstfrac = 1.0-(dstfracna+dstfraccl+dstfracca+dstfrack+dstfracmg)
7628
7629 !   if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot
7630
7631                  chem(i,k,j,p_naaj)=chem(i,k,j,p_naaj) + &
7632                         factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracna
7633 !                chem(i,k,j,p_claj)=chem(i,k,j,p_claj) + &
7634 !                       factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfraccl
7635                  chem(i,k,j,p_caaj)=chem(i,k,j,p_caaj) + &
7636                         factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracca
7637                  chem(i,k,j,p_kaj)=chem(i,k,j,p_kaj) + &
7638                         factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfrack
7639                  chem(i,k,j,p_mgaj)=chem(i,k,j,p_mgaj) + &
7640                         factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracmg
7641
7642                  chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) +   &
7643             factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfrac
7644 !liqy-20140709
7645
7646 !jdf        factbb * (sz(3)+sz(4)+sz(5)) * fractot
7647          chem(i,k,j,p_soila)=chem(i,k,j,p_soila) +   &
7648             factbb * (sz(7)+sz(8)) * fractot
7649 !jdf        factbb * (sz(6)+sz(7)+sz(8)) * fractot
7650 ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3
7651          densdust=2.5
7652          dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
7653          mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7654          chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) +   &
7655             factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part
7656 !jdf        factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part
7657          dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
7658          mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7659          chem(i,k,j,p_corn)=chem(i,k,j,p_corn) +   &
7660             factbb * (sz(7)+sz(8)) * fractot / mass1part
7661 !jdf        factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part
7662
7663 1840    continue
7664
7665 1820    continue
7666 1830    continue
7667
7668         return
7669
7670    END subroutine soa_vbs_dust_emiss
7671
7672 !====================================================================================
7673 !add another dust emission scheme following GOCART mechanism  --czhao  09/17/2009
7674 !====================================================================================
7675   subroutine soa_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy,    &
7676          v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,                   &
7677          ivgtyp,isltyp,xland,dx,g,                                         &
7678          ids,ide, jds,jde, kds,kde,                                        &
7679          ims,ime, jms,jme, kms,kme,                                        &
7680          its,ite, jts,jte, kts,kte                                         )
7681   USE module_data_gocart_dust
7682   USE module_configure
7683   USE module_state_description
7684   USE module_model_constants, ONLY: mwdry
7685   USE module_data_mosaic_asect
7686   IMPLICIT NONE
7687
7688    INTEGER,      INTENT(IN   ) :: ktau, num_soil_layers,           &
7689                                   ids,ide, jds,jde, kds,kde,               &
7690                                   ims,ime, jms,jme, kms,kme,               &
7691                                   its,ite, jts,jte, kts,kte
7692    INTEGER,DIMENSION( ims:ime , jms:jme )                  ,               &
7693           INTENT(IN   ) ::                                                 &
7694                                                      ivgtyp,               &
7695                                                      isltyp
7696    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),                 &
7697          INTENT(INOUT ) ::                                   chem
7698   REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) ,      &
7699       INTENT(INOUT) ::                               smois
7700    REAL,  DIMENSION( ims:ime , jms:jme, 3 )                   ,               &
7701           INTENT(IN   ) ::    erod
7702    REAL,  DIMENSION( ims:ime , jms:jme )                   ,               &
7703           INTENT(IN   ) ::                                                 &
7704                                                      u10,                  &
7705                                                      v10,                  &
7706                                                      xland
7707    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ),                        &
7708           INTENT(IN   ) ::                                                 &
7709                                                         alt,               &
7710                                                      dz8w,p8w,             &
7711                                               u_phy,v_phy,rho_phy
7712
7713   REAL, INTENT(IN   ) :: dt,dx,g
7714 !
7715 ! local variables
7716 !
7717   integer :: nmx,i,j,k,ndt,imx,jmx,lmx
7718   integer ilwi, start_month
7719   real*8, DIMENSION (3) :: erodin
7720   real*8, DIMENSION (5) :: bems
7721   real*8  w10m,gwet,airden,airmas
7722   real*8  cdustemis,jdustemis,cdustcon,jdustcon
7723   real*8  cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
7724   real*8  dxy
7725   real*8  conver,converi
7726   real dttt
7727   real soilfacj,rhosoilj,rhosoilc
7728   real totalemis,accfrac,corfrac,rscale1,rscale2
7729
7730   accfrac=0.07              ! assign 7% to accumulation mode
7731   corfrac=0.93              ! assign 93% to coarse mode
7732   rscale1=1.00  ! to account for the dust larger than 10um in radius
7733   rscale2=1.02  ! to account for the dust larger than 10um in radius
7734   accfrac=accfrac*rscale1
7735   corfrac=corfrac*rscale2
7736
7737   rhosoilj=2.5e3
7738   rhosoilc=2.6e3
7739   soilfacj=soilfac*rhosoilj/rhosoilc
7740
7741   conver=1.e-9
7742   converi=1.e9
7743 !
7744 ! number of dust bins
7745   nmx=5
7746   k=kts
7747   do j=jts,jte
7748   do i=its,ite
7749 !
7750 ! don't do dust over water!!!
7751      if(xland(i,j).lt.1.5)then
7752
7753      ilwi=1
7754      start_month = 3   ! it doesn't matter, ch_dust is not a month dependent now, a constant
7755      w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
7756      airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g   ! kg
7757
7758 ! we don't trust the u10,v10 values, if model layers are very thin near surface
7759      if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j))
7760     !erodin(1)=erod(i,j,1)/dx/dx   ! czhao erod shouldn't be scaled to the area, because it's a fraction
7761     !erodin(2)=erod(i,j,2)/dx/dx
7762     !erodin(3)=erod(i,j,3)/dx/dx
7763      erodin(1)=erod(i,j,1)
7764      erodin(2)=erod(i,j,2)
7765      erodin(3)=erod(i,j,3)
7766 !
7767 !  volumetric soil moisture over porosity
7768      gwet=smois(i,1,j)/porosity(isltyp(i,j))
7769      ndt=ifix(dt)
7770      airden=rho_phy(i,kts,j)
7771      dxy=dx*dx
7772
7773     call soa_vbs_source_du( nmx, dt,i,j, &
7774                             erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
7775                             bems,start_month,g)
7776
7777 !bems: kg/timestep/cell
7778     !sum up the dust emission from 0.1-10 um in radius
7779     ! unit change from kg/timestep/cell to ug/m2/s
7780     totalemis=(sum(bems(1:5))/dt)*converi/dxy
7781      ! to account for the particles larger than 10 um radius
7782      ! based on assumed size distribution
7783     jdustemis = totalemis*accfrac   ! accumulation mode
7784     cdustemis = totalemis*corfrac   ! coarse mode
7785
7786          cdustcon = sum(bems(1:5))*corfrac/airmas  ! kg/kg-dryair
7787          cdustcon = cdustcon * converi   ! ug/kg-dryair
7788          jdustcon = sum(bems(1:5))*accfrac/airmas  ! kg/kg-dryair
7789          jdustcon = jdustcon * converi   ! ug/kg-dryair
7790
7791          chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon
7792          chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon
7793
7794 ! czhao doing dust number emission following pm10
7795 ! use soilfacj for accumulation mode because GOCART assign a less dense dust in
7796 ! accumulation mode
7797        chem(i,k,j,p_ac0) =  chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj
7798        chem(i,k,j,p_corn) =  chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac
7799
7800      endif
7801   enddo
7802   enddo
7803
7804 end subroutine soa_vbs_dust_gocartemis
7805
7806   SUBROUTINE soa_vbs_source_du( nmx, dt1,i,j, &
7807                      erod, ilwi, dxy, w10m, gwet, airden, airmas, &
7808                      bems,month,g0)
7809
7810 ! ****************************************************************************
7811 ! *  Evaluate the source of each dust particles size classes  (kg/m3)
7812 ! *  by soil emission.
7813 ! *  Input:
7814 ! *         EROD      Fraction of erodible grid cell                (-)
7815 ! *                   for 1: Sand, 2: Silt, 3: Clay
7816 ! *         DUSTDEN   Dust density                                  (kg/m3)
7817 ! *         DXY       Surface of each grid cell                     (m2)
7818 ! *         AIRVOL    Volume occupy by each grid boxes              (m3)
7819 ! *         NDT1      Time step                                     (s)
7820 ! *         W10m      Velocity at the anemometer level (10meters)   (m/s)
7821 ! *         u_tresh   Threshold velocity for particule uplifting    (m/s)
7822 ! *         CH_dust   Constant to fudge the total emission of dust  (s2/m2)
7823 ! *
7824 ! *  Output:
7825 ! *         DSRC      Source of each dust type           (kg/timestep/cell)
7826 ! *
7827 ! *  Working:
7828 ! *         SRC       Potential source                   (kg/m/timestep/cell)
7829 ! *
7830 ! ****************************************************************************
7831
7832  USE module_data_gocart_dust
7833
7834   INTEGER, INTENT(IN)    :: nmx
7835   REAL*8,    INTENT(IN)  :: erod(ndcls)
7836   INTEGER, INTENT(IN)    :: ilwi,month
7837
7838   REAL*8,    INTENT(IN)    :: w10m, gwet
7839   REAL*8,    INTENT(IN)    :: dxy
7840   REAL*8,    INTENT(IN)    :: airden, airmas
7841   REAL*8,    INTENT(OUT)   :: bems(nmx)
7842
7843   REAL*8    :: den(nmx), diam(nmx)
7844   REAL*8    :: tsrc, u_ts0, cw, u_ts, dsrc, srce
7845   REAL, intent(in)    :: g0
7846   REAL    :: rhoa, g,dt1
7847   INTEGER :: i, j, n, m, k
7848
7849   ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5
7850   !ch_dust(:,:)=0.8D-9   ! ch_dust is defined here instead of in the chemics_ini.F if with SOA_VBS  -czhao
7851    ch_dust(:,:)=1.0D-9  ! default
7852   !ch_dust(:,:)=0.65D-9   ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara
7853   !ch_dust(:,:)=1.0D-9*0.36  ! ch_dust is scaled to soa_vbs total dust emission
7854
7855   ! executable statemenst
7856   DO n = 1, nmx
7857      ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941)
7858      den(n) = den_dust(n)*1.0D-3
7859      diam(n) = 2.0*reff_dust(n)*1.0D2
7860      g = g0*1.0E2
7861      ! Pointer to the 3 classes considered in the source data files
7862      m = ipoint(n)
7863      tsrc = 0.0
7864               rhoa = airden*1.0D-3
7865               u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
7866                    SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
7867                    SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
7868
7869               ! Case of surface dry enough to erode
7870              IF (gwet < 0.5) THEN  !  Pete's modified value
7871 !              IF (gwet < 0.2) THEN
7872                  u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
7873               ELSE
7874                  ! Case of wet surface, no erosion
7875                  u_ts = 100.0
7876               END IF
7877               srce = frac_s(n)*erod(m)*dxy  ! (m2)
7878               IF (ilwi == 1 ) THEN
7879                  dsrc = ch_dust(n,month)*srce*w10m**2 &
7880                       * (w10m - u_ts)*dt1  ! (kg)
7881               ELSE
7882                  dsrc = 0.0
7883               END IF
7884               IF (dsrc < 0.0) dsrc = 0.0
7885
7886               ! Update dust mixing ratio at first model level.
7887               !tc(n) = tc(n) + dsrc / airmas    !kg/kg-dryair -czhao
7888               bems(n) = dsrc     ! kg/timestep/cell
7889
7890   ENDDO
7891
7892 END SUBROUTINE soa_vbs_source_du
7893
7894 !===========================================================================
7895
7896 !!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F)
7897
7898 !===========================================================================
7899 !   subroutine wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags,      &
7900 !               dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra,        &
7901 !               qlsink,precr,preci,precs,precg,qsrflx,                      &
7902 !               gas_aqfrac, numgas_aqfrac,                                  &
7903 !               ids,ide, jds,jde, kds,kde,                                  &
7904 !               ims,ime, jms,jme, kms,kme,                                  &
7905 !               its,ite, jts,jte, kts,kte                                   )
7906
7907 !  wet removal by grid-resolved precipitation
7908 !  scavenging of cloud-phase aerosols and gases by collection, freezing, ...
7909 !  scavenging of interstitial-phase aerosols by impaction
7910 !  scavenging of gas-phase gases by mass transfer and reaction
7911
7912 !----------------------------------------------------------------------
7913 !   USE module_configure
7914 !   USE module_state_description
7915 !   USE module_data_soa_vbs
7916 !   USE module_mosaic_wetscav,only:  wetscav
7917
7918 !----------------------------------------------------------------------
7919 !   IMPLICIT NONE
7920
7921 !   TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
7922
7923 !   INTEGER,      INTENT(IN   )    ::                                &
7924 !                                      ids,ide, jds,jde, kds,kde,    &
7925 !                                      ims,ime, jms,jme, kms,kme,    &
7926 !                                      its,ite, jts,jte, kts,kte,    &
7927 !                                      id, ktau, ktauc, numgas_aqfrac
7928 !      REAL,      INTENT(IN   ) :: dtstep,dtstepc
7929
7930 ! all advected chemical species
7931 !
7932 !   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),          &
7933 !         INTENT(INOUT ) ::                                chem
7934
7935 ! fraction of gas species in cloud water
7936 !   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ),     &
7937 !         INTENT(IN ) ::                                   gas_aqfrac
7938
7939 !
7940 !
7941 ! input from meteorology
7942 !   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,        &
7943 !         INTENT(IN   ) ::                                          &
7944 !                                                        alt,        &
7945 !                                                      t_phy,        &
7946 !                                                      p_phy,        &
7947 !                                                   t8w,p8w,         &
7948 !                                    qlsink,precr,preci,precs,precg, &
7949 !                                                    rho_phy,cldfra
7950 !   REAL, DIMENSION( ims:ime, jms:jme, num_chem ),          &
7951 !         INTENT(OUT ) ::                                qsrflx ! column change due to scavening
7952
7953 !   call wetscav (id,ktau,dtstep,ktauc,config_flags,                     &
7954 !        dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra,            &
7955 !        qlsink,precr,preci,precs,precg,qsrflx,                          &
7956 !        gas_aqfrac, numgas_aqfrac,                                      &
7957 !        ntype_aer, nsize_aer, ncomp_aer,                                &
7958 !        massptr_aer, dens_aer, numptr_aer,                              &
7959 !        maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, &
7960 !        volumcen_sect, volumlo_sect, volumhi_sect,                      &
7961 !        waterptr_aer, dens_water_aer,                                   &
7962 !        scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, &
7963 !        ids,ide, jds,jde, kds,kde,                                      &
7964 !        ims,ime, jms,jme, kms,kme,                                      &
7965 !       its,ite, jts,jte, kts,kte                                       )
7966
7967 !   end subroutine wetscav_soa_vbs_driver
7968 !===========================================================================
7969
7970 END Module module_aerosols_soa_vbs