chem/module_aerosols_soa_vbs_het.F

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