MODULE module_aerosols_sorgam
!
  USE module_state_description
  USE module_data_radm2
  USE module_data_sorgam
  USE module_radm
!
      IMPLICIT NONE
#define cw_species_are_in_registry

CONTAINS
    SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w,    &
               t8w,alt,p_phy,chem,rho_phy,dz8w,z,z_at_w,                &
               h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
               cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old,    &
               e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10,        &
               e_so4i,e_so4j,e_no3i,e_no3j,                             &
               vdrog3,                                                  &
               kemit,                                                   &
               ids,ide, jds,jde, kds,kde,                               &
               ims,ime, jms,jme, kms,kme,                               &
               its,ite, jts,jte, kts,kte                                )

   INTEGER,      INTENT(IN   )    ::                             &
                                      ids,ide, jds,jde, kds,kde, &
                                      ims,ime, jms,jme, kms,kme, &
                                      its,ite, jts,jte, kts,kte, &
                                      kemit,                     &
                                      id,ktau

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),        &
         INTENT(IN ) ::                                   moist

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),         &
         INTENT(INOUT ) ::                                   chem
!
! following are aerosol arrays that are not advected
!
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
         INTENT(INOUT ) ::                                             &
           h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2,    &
           cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2

!   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
   REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ),                     &
         INTENT(INOUT ) ::                                             &
           e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10,           &
           e_so4i,e_so4j,e_no3i,e_no3j

   REAL,  DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog),                  &
           INTENT(IN   ) ::                                            &
                                                  VDROG3               
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,           &
          INTENT(IN   ) ::                                             &
                                                      t_phy,           &
                                                        alt,           &
                                                      p_phy,           &
                                                      dz8w,            &
                                                      z    ,           &
                                              t8w,p8w,z_at_w ,         &
                                                      aerwrf ,         &
                                                    rho_phy
   REAL,  DIMENSION( ims:ime , kms:kme-0 , jms:jme )         ,         &
          INTENT(IN   ) ::                                             &
             vcsulf_old
      REAL,      INTENT(IN   ) ::                                      &
                             dtstep

      REAL drog_in(ldrog)                                    ! anthropogenic AND
                                                             ! biogenic organic
                                                             ! aerosol precursor [ug m**-3 s**-1]

      REAL condvap_in(lspcv) !bs
                             !rs
                             ! condensable vapors [ug m**-3]
      REAL rgas
      DATA rgas/8.314510/
      REAL convfac,convfac2
!...BLKSIZE set to one in column model ciarev02

      INTEGER blksize
      PARAMETER (blksize=1)

!...number of aerosol species
!  number of species (gas + aerosol)
      INTEGER nspcsda
      PARAMETER (nspcsda=l1ae) !bs
! (internal aerosol dynamics)
!bs # of anth. cond. vapors in SORGAM
      INTEGER nacv
      PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
!bs total # of cond. vapors in SORGAM
      INTEGER ncv
      PARAMETER (ncv=lspcv) !bs
!bs total # of cond. vapors in CTM
      REAL cblk(blksize,nspcsda) ! main array of variables
                                   ! particles [ug/m^3/s]
      REAL soilrat_in
                    ! emission rate of soil derived coars
                    ! input HNO3 to CBLK [ug/m^3]
      REAL nitrate_in
                    ! input NH3 to CBLK  [ug/m^3]
      REAL nh3_in
                    ! input SO4 vapor    [ug/m^3]
      REAL vsulf_in

      REAL so4rat_in
                    ! input SO4 formation[ug/m^3/sec]
      REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
                    ! Emission rate of i-mode EC [ug m**-3 s**-1]
      REAL eeci_in
                    ! Emission rate of j-mode EC [ug m**-3 s**-1]
      REAL eecj_in
                    ! Emission rate of j-mode org. aerosol [ug m**-
      REAL eorgi_in

      REAL eorgj_in
                    ! Emission rate of j-mode org. aerosol [ug m**-
                    ! pressure in cb
      REAL pres
                    ! temperature in K
      REAL temp
                    !bs
      REAL relhum
                    ! rel. humidity (0,1)   
      REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1)

!...molecular weights                   ciarev02

! molecular weight for SO4
      REAL mwso4
      PARAMETER (mwso4=96.0576)

! molecular weight for HNO3
      REAL mwhno3
      PARAMETER (mwhno3=63.01287)

! molecular weight for NH3
      REAL mwnh3
      PARAMETER (mwnh3=17.03061)

!bs molecular weight for Organic Spec
!     REAL mworg
!     PARAMETER (mworg=175.0)

!bs molecular weight for Elemental Ca
      REAL mwec
      PARAMETER (mwec=12.0)

!rs molecular weight
      REAL mwaro1
      PARAMETER (mwaro1=150.0)

!rs molecular weight
      REAL mwaro2
      PARAMETER (mwaro2=150.0)

!rs molecular weight
      REAL mwalk1
      PARAMETER (mwalk1=140.0)

!rs molecular weight
      REAL mwalk2
      PARAMETER (mwalk2=140.0)

!rs molecular weight
!rs molecular weight
      REAL mwole1
      PARAMETER (mwole1=140.0)

!rs molecular weight
      REAL mwapi1
      PARAMETER (mwapi1=200.0)

!rs molecular weight
      REAL mwapi2
      PARAMETER (mwapi2=200.0)

!rs molecular weight
      REAL mwlim1
      PARAMETER (mwlim1=200.0)

!rs molecular weight
      REAL mwlim2
      PARAMETER (mwlim2=200.0)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   INTEGER :: i,j,k,kk,l,debug_level

!
! convert advected aerosol variables to ug/m3 from mixing ratio
! they will be converted back at the end of this driver
!
   do l=p_so4aj,num_chem
      do j=jts,jte
         do k=kts,kte
            kk=min(k,kte-1)
            do i=its,ite
               chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)/alt(i,kk,j))
            enddo
         enddo
      enddo
   enddo
      do 100 j=jts,jte
         do 100 i=its,ite
           debug_level=0
            do k=kts,kte-1
               t(k) = t_phy(i,k,j)
               p(k) = .001*p_phy(i,k,j)
               rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) /        &
                        (3.80*exp(17.27*(t_phy(i,k,j)-273.)/       &
                        (t_phy(i,k,j)-36.))/.01*p_phy(i,k,j))      )
               rh(k)=max(.1,0.01*rh(k))
!               rh(k) = .10
            enddo
            do k=kts,kte-1
!           if(timer.gt.2.)then
!                if((i.eq.12.and.j.eq.17.and.k.eq.1).or.       &
!                   (i.eq.12.and.j.eq.7.and.k.eq.2).or.       &
!                   (i.eq.1.and.j.eq.17.and.k.eq.2))iprt=1
!                if(debug_level.ge.1)print *,ktau,timer,i,j,k,p(k),t(k),dtstep,rgas,vcsulf_old(i,k,j),MWSO4,chem(i,k,j,p_sulf)
!           endif
               cblk=0.
               do l=1,ldrog
                  drog_in(l)=0.
               enddo
               do l=1,lspcv
                  condvap_in(l)=0.
               enddo
               convfac = p(k)/rgas/t(k)*1000.
               so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
               soilrat_in = 0.
               nitrate_in =max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
               nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
               vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
      if(i.eq.23.and.j.eq.37.and.k.eq.22)then
        print *,'vsulfin = ',vsulf_in,chem(i,k,j,p_sulf),convfac,mwso4
      endif
               
!rs
!rs * organic aerosol precursors
!rs * anthropogenic organics DeltaROG
        drog_in(PXYL ) = VDROG3(i,k,j,PXYL )
        drog_in(PTOL ) = VDROG3(i,k,j,PTOL )
        drog_in(PCSL1) = VDROG3(i,k,j,PCSL1)
        drog_in(PCSL2) = VDROG3(i,k,j,PCSL2)
        drog_in(PHC8 ) = VDROG3(i,k,j,PHC8 )
        drog_in(POLI1) = VDROG3(i,k,j,POLI1)
        drog_in(POLI2) = VDROG3(i,k,j,POLI2)
        drog_in(POLI3) = VDROG3(i,k,j,POLI3)
        drog_in(POLT1) = VDROG3(i,k,j,POLT1)
        drog_in(POLT2) = VDROG3(i,k,j,POLT2)
        drog_in(POLT3) = VDROG3(i,k,j,POLT3)
!rs * biogenic organics DeltaROG
        if(p_ete.eq.1)then
            drog_in(PAPI1) = 0.
            drog_in(PAPI2) = 0.
            drog_in(PAPI3) = 0.
            drog_in(PLIM1) = 0.
            drog_in(PLIM2) = 0.
            drog_in(PLIM3) = 0.
            condvap_in(PSOAAPI1) = 0.
            condvap_in(PSOAAPI2) = 0.
            condvap_in(PSOALIM1) = 0.
            condvap_in(PSOALIM2) = 0.
        elseif(p_ete.gt.1)then
            drog_in(PAPI1) = VDROG3(i,k,j,PAPI1)
            drog_in(PAPI2) = VDROG3(i,k,j,PAPI2)
            drog_in(PAPI3) = VDROG3(i,k,j,PAPI3)
            drog_in(PLIM1) = VDROG3(i,k,j,PLIM1)
            drog_in(PLIM2) = VDROG3(i,k,j,PLIM2)
            drog_in(PLIM3) = VDROG3(i,k,j,PLIM3)
            condvap_in(PSOAAPI1) = max(epsilc,cvapi1(i,k,j))
            condvap_in(PSOAAPI2) = max(epsilc,cvapi2(i,k,j))
            condvap_in(PSOALIM1) = max(epsilc,cvlim1(i,k,j))
            condvap_in(PSOALIM2) = max(epsilc,cvlim2(i,k,j))
        endif
        condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
        condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
        condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
        condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
      cblk(1,VORGARO1J) =   chem(i,k,j,p_orgaro1j)
      cblk(1,VORGARO1I) =   chem(i,k,j,p_orgaro1i)
      cblk(1,VORGARO2J) =   chem(i,k,j,p_orgaro2j)
      cblk(1,VORGARO2I) =   chem(i,k,j,p_orgaro2i)
      cblk(1,VORGALK1J) =   chem(i,k,j,p_orgalk1j)
      cblk(1,VORGALK1I) =   chem(i,k,j,p_orgalk1i)
      cblk(1,VORGOLE1J) =   chem(i,k,j,p_orgole1j)
      cblk(1,VORGOLE1I) =   chem(i,k,j,p_orgole1i)
      cblk(1,VORGBA1J ) =   chem(i,k,j,p_orgba1j)
      cblk(1,VORGBA1I ) =   chem(i,k,j,p_orgba1i)
      cblk(1,VORGBA2J ) =   chem(i,k,j,p_orgba2j)
      cblk(1,VORGBA2I ) =   chem(i,k,j,p_orgba2i)
      cblk(1,VORGBA3J ) =   chem(i,k,j,p_orgba3j)
      cblk(1,VORGBA3I ) =   chem(i,k,j,p_orgba3i)
      cblk(1,VORGBA4J ) =   chem(i,k,j,p_orgba4j)
      cblk(1,VORGBA4I ) =   chem(i,k,j,p_orgba4i)
      cblk(1,VORGPAJ  ) =   chem(i,k,j,p_orgpaj)
      cblk(1,VORGPAI  ) =   chem(i,k,j,p_orgpai)
      cblk(1,VECJ     ) =   chem(i,k,j,p_ecj)
      cblk(1,VECI     ) =   chem(i,k,j,p_eci)
      cblk(1,VP25AJ   ) =   chem(i,k,j,p_p25j)
      cblk(1,VP25AI   ) =   chem(i,k,j,p_p25i)
      cblk(1,VANTHA   ) =   chem(i,k,j,p_antha)
      cblk(1,VSEAS    ) =   chem(i,k,j,p_seas)
      cblk(1,VSOILA   ) =   chem(i,k,j,p_soila)
      cblk(1,VH2OAJ   ) =   max(epsilc,h2oaj(i,k,j))
      cblk(1,VH2OAI   ) =   max(epsilc,h2oai(i,k,j))
      cblk(1,VNU3     ) =   max(epsilc,nu3(i,k,j))
      cblk(1,VAC3     ) =   max(epsilc,ac3(i,k,j))
      cblk(1,VCOR3    ) =   max(epsilc,cor3(i,k,j))
      cblk(1,VCVARO1  ) =   max(epsilc,cvaro1(i,k,j))
      cblk(1,VCVARO2  ) =   max(epsilc,cvaro2(i,k,j))
      cblk(1,VCVALK1  ) =   max(epsilc,cvalk1(i,k,j))
      cblk(1,VCVOLE1  ) =   max(epsilc,cvole1(i,k,j))
      cblk(1,VCVAPI1  ) =   0.
      cblk(1,VCVAPI2  ) =   0.
      cblk(1,VCVLIM1  ) =   0.
      cblk(1,VCVLIM2  ) =   0.
!
! Set emissions to zero when above level kemit.
!
      if( k > kemit ) then
         epmcoarse(1) = 0.
         epm25i(1)    = 0.
         epm25j (1)   = 0.
         eeci_in      = 0.
         eecj_in      = 0.
         eorgi_in     = 0.
         eorgj_in     = 0.
         cblk(1,VSO4AJ   ) = chem(i,k,j,p_so4aj)
         cblk(1,VSO4AI   ) = chem(i,k,j,p_so4ai)
         cblk(1,VNO3AJ   ) = chem(i,k,j,p_no3aj)
         cblk(1,VNO3AI   ) = chem(i,k,j,p_no3ai)
      else
         epmcoarse(1) = e_pm10(i,k,j)/dz8w(i,k,j)
         epm25i(1)    = e_pm25i(i,k,j)/dz8w(i,k,j)
         epm25j(1)    = e_pm25j(i,k,j)/dz8w(i,k,j)
         eeci_in      = e_eci(i,k,j)/dz8w(i,k,j)
         eecj_in      = e_ecj(i,k,j)/dz8w(i,k,j)
         eorgi_in     = e_orgi(i,k,j)/dz8w(i,k,j)
         eorgj_in     = e_orgj(i,k,j)/dz8w(i,k,j)
         cblk(1,VSO4AJ   ) = chem(i,k,j,p_so4aj)+e_so4j(i,k,j)/dz8w(i,k,j)*dtstep
         cblk(1,VSO4AI   ) = chem(i,k,j,p_so4ai)+e_so4i(i,k,j)/dz8w(i,k,j)*dtstep
         cblk(1,VNO3AJ   ) = chem(i,k,j,p_no3aj)+e_no3j(i,k,j)/dz8w(i,k,j)*dtstep
         cblk(1,VNO3AI   ) = chem(i,k,j,p_no3ai)+e_no3i(i,k,j)/dz8w(i,k,j)*dtstep
      end if
!rs. nitrate, nh3, sulf
      cblk(1,vsulf) = vsulf_in
      cblk(1,vhno3) = nitrate_in
      cblk(1,vnh3) = nh3_in
      cblk(1,VNH4AJ   ) =   chem(i,k,j,p_nh4aj)
      cblk(1,VNH4AI   ) =   chem(i,k,j,p_nh4ai)
      cblk(1,VNU0     ) =   max(1.e7,chem(i,k,j,p_nu0))
      cblk(1,VAC0     ) =   max(1.e7,chem(i,k,j,p_ac0))
      cblk(1,VCORN    ) =   chem(i,k,j,p_corn)

      if(debug_level.ge.1)then
!     if(i.eq.23.and.j.eq.37.and.k.eq.22)then
        print*,'in a_mechanisms',i,j,k
        print*,'NSPCSDA, BLKSIZE',NSPCSDA, BLKSIZE
        print*,'k,DTA,PRES,TEMP,RELHUM',k,DTstep,10.*P(k),T(k),RH(k)
        print*,'nitrate_in, nh3_in, vsulf_in, so4rat_in', &
                nitrate_in, nh3_in, vsulf_in, so4rat_in
        print*,'drog_in,ldrog',drog_in,ldrog
        print*,'condvap_in,NCV,NACV',condvap_in,NCV,NACV
        print*,'eeci_in, eecj_in, eorgi_in, eorgj_in,convfac' &
            ,eeci_in, eecj_in, eorgi_in, eorgj_in,convfac
        print*,'CBLK',CBLK
       endif
      CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh(k),nitrate_in,nh3_in, &
        vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv,nacv,eeci_in,eecj_in, &
        eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k)
      chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ   )
      chem(i,k,j,p_so4ai) = cblk(1,VSO4AI   )
      chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ   )
      chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI   )
      chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ   )
      chem(i,k,j,p_no3ai) = cblk(1,VNO3AI   )
      chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
      chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
      chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
      chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
      chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
      chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
      chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
      chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
      chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
      chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
      chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
      chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
      chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
      chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
      chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
      chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
      chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ  )
      chem(i,k,j,p_orgpai) = cblk(1,VORGPAI  )
      chem(i,k,j,p_ecj) = cblk(1,VECJ     )
      chem(i,k,j,p_eci) = cblk(1,VECI     )
      chem(i,k,j,p_p25j) = cblk(1,VP25AJ   )
      chem(i,k,j,p_p25i) = cblk(1,VP25AI   )
      chem(i,k,j,p_antha) =cblk(1,VANTHA   )
      chem(i,k,j,p_seas) = cblk(1,VSEAS    )
      chem(i,k,j,p_soila) = cblk(1,VSOILA   )
      chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0     ))
      chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0     ))
!     chem(i,k,j,p_ac0) = cblk(1,VAC0     )
      chem(i,k,j,p_corn) = cblk(1,VCORN    )
      h2oaj(i,k,j) = cblk(1,VH2OAJ   )
      h2oai(i,k,j) = cblk(1,VH2OAI   )
      nu3(i,k,j) = cblk(1,VNU3     )
      ac3(i,k,j) = cblk(1,VAC3     )
      cor3(i,k,j) = cblk(1,VCOR3    )
      cvaro1(i,k,j) = cblk(1,VCVARO1  )
      cvaro2(i,k,j) = cblk(1,VCVARO2  )
      cvalk1(i,k,j) = cblk(1,VCVALK1  )
      cvole1(i,k,j) = cblk(1,VCVOLE1  )
      cvapi1(i,k,j) = 0.
      cvapi2(i,k,j) = 0.
      cvlim1(i,k,j) = 0.
      cvlim2(i,k,j) = 0.
      chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
      chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
      chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
      enddo         ! k-loop
 100  continue      ! i,j-loop

!
! convert aerosol variables back to mixing ratio from ug/m3
!
      do l=p_so4aj,num_chem
         do j=jts,jte
            do k=kts,kte
               kk=min(k,kte-1)
               do i=its,ite
                  chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)*alt(i,kk,j))
               enddo
            enddo
         enddo
      enddo

    END SUBROUTINE sorgam_driver
! ///////////////////////////////////////////////////
    SUBROUTINE sum_pm_sorgam (                                         &
         alt, chem, h2oaj, h2oai,                                      &
         pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10,                   &
         ids,ide, jds,jde, kds,kde,                                    &
         ims,ime, jms,jme, kms,kme,                                    &
         its,ite, jts,jte, kts,kte                                     )

   INTEGER,      INTENT(IN   )    ::                                   &
                                      ids,ide, jds,jde, kds,kde,       &
                                      ims,ime, jms,jme, kms,kme,       &
                                      its,ite, jts,jte, kts,kte

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
         INTENT(IN ) :: chem

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
         INTENT(IN ) :: alt,h2oaj,h2oai

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
         INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10

   INTEGER :: i,ii,j,jj,k,kk,n
!
! sum up pm2_5 and pm10 output
!
      pm2_5_dry(its:ite, kts:kte-1, jts:jte)    = 0.
      pm2_5_water(its:ite, kts:kte-1, jts:jte)  = 0.
      pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
      do j=jts,jte
         jj=min(jde-1,j)
      do k=kts,kte-1
         kk=min(kde-1,k)
      do i=its,ite
         ii=min(ide-1,i)
         do n=p_so4aj,p_p25i
            pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,kk,jj,n)
         enddo
         pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,kk,jj,p_ecj) &
                               + chem(ii,kk,jj,p_eci)
         pm2_5_water(i,k,j) =  pm2_5_water(i,k,j)+h2oaj(i,k,j)       &
                               + h2oai(i,k,j)

         !Convert the units from mixing ratio to concentration (ug m^-3)
         pm2_5_dry(i,k,j)    = pm2_5_dry(i,k,j) / alt(ii,kk,jj)
         pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,kk,jj)
         pm2_5_water(i,k,j)  = pm2_5_water(i,k,j) / alt(ii,kk,jj)
      enddo
      enddo
      enddo
      do j=jts,jte
         jj=min(jde-1,j)
         do k=kts,kte-1
            kk=min(kde-1,k)
            do i=its,ite
               ii=min(ide-1,i)
               pm10(i,k,j) = pm2_5_dry(i,k,j)                       &
                           + ( chem(ii,kk,jj,p_antha)               &
                           + chem(ii,kk,jj,p_soila)                 &
                           + chem(ii,kk,jj,p_seas) ) / alt(ii,kk,jj)
            enddo
         enddo
      enddo
    END SUBROUTINE sum_pm_sorgam
! ///////////////////////////////////////////////////
    SUBROUTINE sorgam_depdriver (id,ktau,dtstep,                        &
               ust,t_phy,moist,p8w,t8w,                                 &
               alt,p_phy,chem,rho_phy,dz8w,z,z_at_w,                    &
               h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
               cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,               &
               aer_res,vgsa,                                            &
               numaer,                                                  &
               ids,ide, jds,jde, kds,kde,                               &
               ims,ime, jms,jme, kms,kme,                               &
               its,ite, jts,jte, kts,kte                                )
   INTEGER,      INTENT(IN   )    ::                             &
                                      numaer,                    &
                                      ids,ide, jds,jde, kds,kde, &
                                      ims,ime, jms,jme, kms,kme, &
                                      its,ite, jts,jte, kts,kte, &
                                      id,ktau

   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),        &
         INTENT(IN ) ::                                   moist
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),         &
         INTENT(INOUT ) ::                                   chem
!
! following are aerosol arrays that are not advected
!
   REAL, DIMENSION( its:ite, jts:jte, numaer ),                       &
         INTENT(INOUT ) ::                                             &
         vgsa
   REAL, DIMENSION( its:ite, jts:jte ),                       &
         INTENT(INOUT ) ::                                             &
         aer_res
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
         INTENT(INOUT ) ::                                             &
           h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2,    &
           cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
          INTENT(IN   ) ::                                      &
                                                      t_phy,    &
                                                      alt,      &
                                                      p_phy,    &
                                                      dz8w,     &
                                                      z    ,    &
                                       t8w,p8w,z_at_w ,  &
                                                    rho_phy
   REAL,  DIMENSION( ims:ime ,  jms:jme )         ,    &
          INTENT(IN   ) ::                                      &
                                                     ust
      REAL,      INTENT(IN   ) ::                               &
                             dtstep
                                                                                               
      REAL rgas
      DATA rgas/8.314510/
      REAL convfac,convfac2
!...BLKSIZE set to one in column model ciarev02

      INTEGER blksize
      PARAMETER (blksize=1)

!...number of aerosol species
!  number of species (gas + aerosol)
      INTEGER nspcsda
      PARAMETER (nspcsda=l1ae) !bs
! (internal aerosol dynamics)
!bs # of anth. cond. vapors in SORGAM
      INTEGER nacv
      PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
!bs total # of cond. vapors in SORGAM
      INTEGER ncv
      PARAMETER (ncv=lspcv) !bs
!bs total # of cond. vapors in CTM
      REAL cblk(blksize,nspcsda) ! main array of variables
                                   ! particles [ug/m^3/s]
      REAL soilrat_in
                    ! emission rate of soil derived coars
                    ! input HNO3 to CBLK [ug/m^3]
      REAL nitrate_in
                    ! input NH3 to CBLK  [ug/m^3]
      REAL nh3_in
                    ! input SO4 vapor    [ug/m^3]
      REAL vsulf_in

      REAL so4rat_in
                    ! input SO4 formation[ug/m^3/sec]
                    ! pressure in cb
      REAL pres
                    ! temperature in K
      REAL temp
                    !bs
      REAL relhum
                    ! rel. humidity (0,1)   
      REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1)

!...molecular weights                   ciarev02

! molecular weight for SO4
      REAL mwso4
      PARAMETER (mwso4=96.0576)

! molecular weight for HNO3
      REAL mwhno3
      PARAMETER (mwhno3=63.01287)

! molecular weight for NH3
      REAL mwnh3
      PARAMETER (mwnh3=17.03061)

!bs molecular weight for Organic Spec
!     REAL mworg
!     PARAMETER (mworg=175.0)

!bs molecular weight for Elemental Ca
      REAL mwec
      PARAMETER (mwec=12.0)

!rs molecular weight
      REAL mwaro1
      PARAMETER (mwaro1=150.0)

!rs molecular weight
      REAL mwaro2
      PARAMETER (mwaro2=150.0)

!rs molecular weight
      REAL mwalk1
      PARAMETER (mwalk1=140.0)

!rs molecular weight
      REAL mwalk2
      PARAMETER (mwalk2=140.0)

!rs molecular weight
!rs molecular weight
      REAL mwole1
      PARAMETER (mwole1=140.0)

!rs molecular weight
      REAL mwapi1
      PARAMETER (mwapi1=200.0)

!rs molecular weight
      REAL mwapi2
      PARAMETER (mwapi2=200.0)

!rs molecular weight
      REAL mwlim1
      PARAMETER (mwlim1=200.0)

!rs molecular weight
      REAL mwlim2
      PARAMETER (mwlim2=200.0)
      INTEGER NUMCELLS  ! actual number of cells in arrays ( default is 1 in box model)
!ia                       kept to 1 in current version of column model

       PARAMETER( NUMCELLS = 1)

      REAL RA(BLKSIZE )             ! aerodynamic resistance [ s m**-1 ]
      REAL USTAR( BLKSIZE )         ! surface friction velocity [ m s**-1 ]
      REAL WSTAR( BLKSIZE )         ! convective velocity scale [ m s**-1 ]

      REAL BLKPRS(BLKSIZE)         ! pressure in cb
      REAL BLKTA(BLKSIZE)          ! temperature in K
      REAL BLKDENS(BLKSIZE)        ! Air density in kg/m3

!
! *** OUTPUT:
!     
! *** atmospheric properties
      
      REAL XLM( BLKSIZE )           ! atmospheric mean free path [ m ]
      REAL AMU( BLKSIZE )           ! atmospheric dynamic viscosity [ kg/m s ]
      
! *** followng is for future version       
      REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
      REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]

! *** modal diameters: [ m ]
      
      REAL DGNUC( BLKSIZE )         ! nuclei mode geometric mean diameter  [ m ]
      REAL DGACC( BLKSIZE )         ! accumulation geometric mean diameter [ m ]
      REAL DGCOR( BLKSIZE )         ! coarse mode geometric mean diameter  [ m ]
      

! *** aerosol properties: 

! *** Modal mass concentrations [ ug m**3 ]
      
      REAL PMASSN( BLKSIZE )        ! mass concentration in Aitken mode
      REAL PMASSA( BLKSIZE )        ! mass concentration in accumulation mode
      REAL PMASSC( BLKSIZE )        ! mass concentration in coarse mode

! *** average modal particle densities  [ kg/m**3 ]

      REAL PDENSN( BLKSIZE )        ! average particle density in nuclei mode
      REAL PDENSA( BLKSIZE )        ! average particle density in accumulation mode
      REAL PDENSC( BLKSIZE )        ! average particle density in coarse mode

! *** average modal Knudsen numbers

      REAL KNNUC ( BLKSIZE )        ! nuclei mode  Knudsen number
      REAL KNACC ( BLKSIZE )        ! accumulation Knudsen number
      REAL KNCOR ( BLKSIZE )        ! coarse mode  Knudsen number

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   INTEGER :: i,j,k,l
!
!     print *,'in sorgdepdriver ',its,ite,jts,jte
      do l=1,numaer
      do i=its,ite
      do j=jts,jte
      vgsa(i,j,l)=0.
      enddo
      enddo
      enddo
      vdep=0.
      do 100 j=jts,jte
         do 100 i=its,ite
            cblk=epsilc
            do k=kts,kte-1
               t(k) = t_phy(i,k,j)
               p(k) = .001*p_phy(i,k,j)
               rh(k) = MIN( 100.,100. * moist(i,k,j,p_qv) / &
               (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
               (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))))
               rh(k)=max(.05,0.01*rh(k))
            enddo
!           do k=kts,kte-1
            k=kts
               convfac = p(k)/rgas/t(k)*1000.
               nitrate_in =chem(i,k,j,p_hno3)*convfac*mwhno3
               nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
               vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4   
               
!rs. nitrate, nh3, sulf
        BLKPRS(BLKSIZE)   = P(K)                ! pressure in hPa
        BLKTA(BLKSIZE)   = T(K)         ! temperature in K
        BLKDENS(BLKSIZE)=BLKPRS(BLKSIZE)/(RDGAS * BLKTA(BLKSIZE))
        USTAR(BLKSIZE) = max(1.e-8,UST(i,j))
        WSTAR(BLKSIZE) = 0.
      convfac2=1./alt(i,k,j)
      cblk(1,vsulf) = max(epsilc,vsulf_in)
      cblk(1,vhno3) = max(epsilc,nitrate_in)
      cblk(1,vnh3) = max(epsilc,nh3_in)
      cblk(1,VSO4AJ   ) =   max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
      cblk(1,VSO4AI   ) =   max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
      cblk(1,VNH4AJ   ) =   max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
      cblk(1,VNH4AI   ) =   max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
      cblk(1,VNO3AJ   ) =   max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
      cblk(1,VNO3AI   ) =   max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
      cblk(1,VORGARO1J) =   max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
      cblk(1,VORGARO1I) =   max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
      cblk(1,VORGARO2J) =   max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
      cblk(1,VORGARO2I) =   max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
      cblk(1,VORGALK1J) =   max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
      cblk(1,VORGALK1I) =   max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
      cblk(1,VORGOLE1J) =   max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
      cblk(1,VORGOLE1I) =   max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
      cblk(1,VORGBA1J ) =   max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
      cblk(1,VORGBA1I ) =   max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
      cblk(1,VORGBA2J ) =   max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
      cblk(1,VORGBA2I ) =   max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
      cblk(1,VORGBA3J ) =   max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
      cblk(1,VORGBA3I ) =   max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
      cblk(1,VORGBA4J ) =   max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
      cblk(1,VORGBA4I ) =   max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
      cblk(1,VORGPAJ  ) =   max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
      cblk(1,VORGPAI  ) =   max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
      cblk(1,VECJ     ) =   max(epsilc,chem(i,k,j,p_ecj)*convfac2)
      cblk(1,VECI     ) =   max(epsilc,chem(i,k,j,p_eci)*convfac2)
      cblk(1,VP25AJ   ) =   max(epsilc,chem(i,k,j,p_p25j)*convfac2)
      cblk(1,VP25AI   ) =   max(epsilc,chem(i,k,j,p_p25i)*convfac2)
      cblk(1,VANTHA   ) =   max(epsilc,chem(i,k,j,p_antha)*convfac2)
      cblk(1,VSEAS    ) =   max(epsilc,chem(i,k,j,p_seas)*convfac2)
      cblk(1,VSOILA   ) =   max(epsilc,chem(i,k,j,p_soila)*convfac2)
      cblk(1,VNU0     ) =   max(epsilc,chem(i,k,j,p_nu0)*convfac2)
      cblk(1,VAC0     ) =   max(epsilc,chem(i,k,j,p_ac0)*convfac2)
      cblk(1,VCORN    ) =   max(epsilc,chem(i,k,j,p_corn)*convfac2)
      cblk(1,VH2OAJ   ) =   h2oaj(i,k,j)
      cblk(1,VH2OAI   ) =   h2oai(i,k,j)
      cblk(1,VNU3     ) =   nu3(i,k,j)
      cblk(1,VAC3     ) =   ac3(i,k,j)
      cblk(1,VCOR3    ) =   cor3(i,k,j)
      cblk(1,VCVARO1  ) =   cvaro1(i,k,j)
      cblk(1,VCVARO2  ) =   cvaro2(i,k,j)
      cblk(1,VCVALK1  ) =   cvalk1(i,k,j)
      cblk(1,VCVOLE1  ) =   cvole1(i,k,j)
      cblk(1,VCVAPI1  ) =   0.
      cblk(1,VCVAPI2  ) =   0.
      cblk(1,VCVLIM1  ) =   0.
      cblk(1,VCVLIM2  ) =   0.
!     cblk(1,VCVAPI1  ) =   cvapi1(i,k,j)
!     cblk(1,VCVAPI2  ) =   cvapi2(i,k,j)
!     cblk(1,VCVLIM1  ) =   cvlim1(i,k,j)
!     cblk(1,VCVLIM2  ) =   cvlim2(i,k,j)
!                                                                     
!rs.   get size distribution information                              
!                                                                     
!       if(i.eq.126.and.j.eq.99)then
!          print *,'in modpar ',i,j
!          print *,cblk,BLKTA,BLKPRS,USTAR
!          print *,'BLKSIZE, NSPCSDA, NUMCELLS'
!          print *,BLKSIZE, NSPCSDA, NUMCELLS
!          print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
!          print *,XLM, AMU,PDENSN, PDENSA, PDENSC
!          print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
!          print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
!       endif

        CALL MODPAR(  BLKSIZE, NSPCSDA, NUMCELLS,             &
             CBLK,                                            &
             BLKTA, BLKPRS,                                   &
             PMASSN, PMASSA, PMASSC,                          &
             PDENSN, PDENSA, PDENSC,                          &
             XLM, AMU,                                        &
             DGNUC, DGACC, DGCOR,                             &
             KNNUC, KNACC,KNCOR    )                                   
!       print *,'out modpar ',i,j
        CALL VDVG(  BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
             BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR,  AMU,   &   
             DGNUC, DGACC, DGCOR,                      &
             KNNUC, KNACC,KNCOR,                       &
             PDENSN, PDENSA, PDENSC,                   &
             VSED, VDEP )                                             
        VGSA(i, j, VSO4AJ   )  =  VDEP(1, VDMACC )
        VGSA(i, j, VSO4AI   )  =  VDEP(1, VDMNUC )
        VGSA(i, j, VNH4AJ   )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VNH4AI   )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VNO3AJ   )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VNO3AI   )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGARO1J)  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGARO1I)  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGARO2J)  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGARO2I)  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGALK1J)  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGALK1I)  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGOLE1J)  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGOLE1I)  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGBA1J )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGBA1I )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGBA2J )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGBA2I )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGBA3J )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGBA3I )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGBA4J )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGBA4I )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VORGPAJ  )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VORGPAI  )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VECJ     )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VECI     )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VP25AJ   )  =  VGSA(i, j, VSO4AJ )
        VGSA(i, j, VP25AI   )  =  VGSA(i, j, VSO4AI )
        VGSA(i, j, VANTHA   )  =  VDEP(1, VDMCOR )
        VGSA(i, j, VSEAS    )  =  VGSA(i, j, VANTHA )
        VGSA(i, j, VSOILA   )  =  VGSA(i, j, VANTHA )
        VGSA(i, j, VNU0     )  =  VDEP(1, VDNNUC )
        VGSA(i, j, VAC0     )  =  VDEP(1, VDNACC )
        VGSA(i, j, VCORN    )  =  VDEP(1, VDNCOR )
!     enddo         ! k-loop
 100  continue      ! i,j-loop
                                                                     
END SUBROUTINE sorgam_depdriver
! ///////////////////////////////////////////////////
    SUBROUTINE actcof(cat,an,gama,molnu,phimult)

!-----------------------------------------------------------------------

! DESCRIPTION:

!  This subroutine computes the activity coefficients of (2NH4+,SO4--),
!  (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
!  multicomponent solution, using Bromley's model and Pitzer's method.

! REFERENCES:

!   Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
!     in aqueous solutions.  AIChE J. 19, 313-320.

!   Chan, C.K. R.C. Flagen, & J.H.  Seinfeld (1992) Water Activities of
!     NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.

!   Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
!     of strong acids over saline solutions - I HNO3,
!     Atmos. Environ. (22): 91-100

!   Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
!     and mean activity and osmotic coefficients of 0-100% nitric acid
!     as a function of temperature,   J. Phys. Chem (94): 5369 - 5380

!   Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
!     general equilibrium model for inorganic multicomponent atmospheric
!     aerosols.  Atmos. Environ. 21(11), 2453-2466.

! ARGUMENT DESCRIPTION:

!     CAT(1) : conc. of H+    (moles/kg)
!     CAT(2) : conc. of NH4+  (moles/kg)
!     AN(1)  : conc. of SO4-- (moles/kg)
!     AN(2)  : conc. of NO3-  (moles/kg)
!     AN(3)  : conc. of HSO4- (moles/kg)
!     GAMA(2,1)    : mean molal ionic activity coeff for (2NH4+,SO4--)
!     GAMA(2,2)    :                                     (NH4+,NO3-)
!     GAMA(2,3)    :                                     (NH4+. HSO4-)
!     GAMA(1,1)    :                                     (2H+,SO4--)
!     GAMA(1,2)    :                                     (H+,NO3-)
!     GAMA(1,3)    :                                     (H+,HSO4-)
!     MOLNU   : the total number of moles of all ions.
!     PHIMULT : the multicomponent paractical osmotic coefficient.

! REVISION HISTORY:
!      Who       When        Detailed description of changes
!   ---------   --------  -------------------------------------------
!   S.Roselle   7/26/89   Copied parts of routine BROMLY, and began this
!                         new routine using a method described by Pilini
!                         and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
!   S.Roselle   7/30/97   Modified for use in Models-3
!   F.Binkowski 8/7/97    Modified coefficients BETA0, BETA1, CGAMA

!-----------------------------------------------------------------------

!     IMPLICIT NONE

!...........INCLUDES and their descriptions

!      INCLUDE SUBST_XSTAT     ! M3EXIT status codes
!....................................................................

! Normal, successful completion           
      INTEGER xstat0
      PARAMETER (xstat0=0)
! File I/O error                          
      INTEGER xstat1
      PARAMETER (xstat1=1)
! Execution error                         
      INTEGER xstat2
      PARAMETER (xstat2=2)
! Special  error                          
      INTEGER xstat3
      PARAMETER (xstat3=3)

      CHARACTER*120 xmsg

!...........PARAMETERS and their descriptions:

! number of cations             
      INTEGER ncat
      PARAMETER (ncat=2)

! number of anions              
      INTEGER nan
      PARAMETER (nan=3)

!...........ARGUMENTS and their descriptions

! tot # moles of all ions       
      REAL molnu
! multicomponent paractical osmo
      REAL phimult
      REAL cat(ncat) ! cation conc in moles/kg (input
      REAL an(nan) ! anion conc in moles/kg (input)
      REAL gama(ncat,nan) 
!...........SCRATCH LOCAL VARIABLES and their descriptions:

! mean molal ionic activity coef
      CHARACTER*16 & ! driver program name               
        pname
      SAVE pname

! anion indX                    
      INTEGER ian

      INTEGER icat
! cation indX                   

      REAL fgama
! ionic strength                
      REAL i

      REAL r

      REAL s

      REAL ta

      REAL tb

      REAL tc

      REAL texpv

      REAL trm
! 2*ionic strength              
      REAL twoi
! 2*sqrt of ionic strength      
      REAL twosri

      REAL zbar

      REAL zbar2

      REAL zot1
! square root of ionic strength 
      REAL sri
      REAL f2(ncat)
      REAL f1(nan)
      REAL zp(ncat) ! absolute value of charges of c
      REAL zm(nan) ! absolute value of charges of a
      REAL bgama(ncat,nan)
      REAL x(ncat,nan)
      REAL m(ncat,nan) ! molality of each electrolyte  
      REAL lgama0(ncat,nan) ! binary activity coefficients  
      REAL y(nan,ncat)
      REAL beta0(ncat,nan) ! binary activity coefficient pa
      REAL beta1(ncat,nan) ! binary activity coefficient pa
      REAL cgama(ncat,nan) ! binary activity coefficient pa
      REAL v1(ncat,nan) ! number of cations in electroly
      REAL v2(ncat,nan) 
! number of anions in electrolyt
      DATA zp/1.0, 1.0/
      DATA zm/2.0, 1.0, 1.0/
      DATA xmsg/' '/
      DATA pname/'ACTCOF'/

! *** Sources for the coefficients BETA0, BETA1, CGAMA:

! *** (1,1);(1,3)  - Clegg & Brimblecombe (1988)
! *** (2,3)        - Pilinis & Seinfeld (1987), cgama different
! *** (1,2)        - Clegg & Brimblecombe (1990)
! *** (2,1);(2,2)  - Chan, Flagen & Seinfeld (1992)

! *** now set the basic constants, BETA0, BETA1, CGAMA

      DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 & 
        /
! 2H+SO4
      DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 & 
        /
! HNO3  
      DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 & 
        /
! H+HSO4
      DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/, &
        cgama(2,1)/ -1.2683E-3 & 
        /
! (NH4)2
      DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/, &
        cgama(2,2)/3.51217E-5 & 
        /
! NH4NO3
      DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 & 
        /
! NH4HSO
      DATA v1(1,1), v2(1,1)/2.0, 1.0 & ! 2H+SO4-                  
        /
      DATA v1(2,1), v2(2,1)/2.0, 1.0 & ! (NH4)2SO4                
        /
      DATA v1(1,2), v2(1,2)/1.0, 1.0 & ! HNO3                     
        /
      DATA v1(2,2), v2(2,2)/1.0, 1.0 & ! NH4NO3                   
        /
      DATA v1(1,3), v2(1,3)/1.0, 1.0 & ! H+HSO4-                  
        /
      DATA v1(2,3), v2(2,3)/1.0, 1.0 & 
        /
!-----------------------------------------------------------------------
!  begin body of subroutine ACTCOF

!...compute ionic strength

! NH4HSO4                  
      i = 0.0

      DO icat = 1, ncat
        i = i + cat(icat)*zp(icat)*zp(icat)
      END DO

      DO ian = 1, nan
        i = i + an(ian)*zm(ian)*zm(ian)
      END DO

      i = 0.5*i

!...check for problems in the ionic strength

      IF (i==0.0) THEN

        DO ian = 1, nan
          DO icat = 1, ncat
            gama(icat,ian) = 0.0
          END DO
        END DO

!       xmsg = 'Ionic strength is zero...returning zero activities'
!       WRITE (6,*) xmsg
        RETURN

      ELSE IF (i<0.0) THEN
!       xmsg = 'Ionic strength below zero...negative concentrations'
        CALL wrf_error_fatal ( xmsg )
      END IF

!...compute some essential expressions

      sri = sqrt(i)
      twosri = 2.0*sri
      twoi = 2.0*i
      texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
      r = 1.0 + 0.75*i
      s = 1.0 + 1.5*i
      zot1 = 0.511*sri/(1.0+sri)

!...Compute binary activity coeffs

      fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))

      DO icat = 1, ncat
        DO ian = 1, nan

          bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
            )*texpv

!...compute the molality of each electrolyte for given ionic strength

          m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
            (1.0/(v1(icat,ian)+v2(icat,ian)))

!...calculate the binary activity coefficients

          lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
            ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
            ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
            v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
            ian)))/2.302585093

        END DO
      END DO

!...prepare variables for computing the multicomponent activity coeffs

      DO ian = 1, nan
        DO icat = 1, ncat
          zbar = (zp(icat)+zm(ian))*0.5
          zbar2 = zbar*zbar
          y(ian,icat) = zbar2*an(ian)/i
          x(icat,ian) = zbar2*cat(icat)/i
        END DO
      END DO

      DO ian = 1, nan
        f1(ian) = 0.0
        DO icat = 1, ncat
          f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
            zot1*zp(icat)*zm(ian)*x(icat,ian)
        END DO
      END DO

      DO icat = 1, ncat
        f2(icat) = 0.0
        DO ian = 1, nan
          f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
            zot1*zp(icat)*zm(ian)*y(ian,icat)
        END DO
      END DO

!...now calculate the multicomponent activity coefficients

      DO ian = 1, nan
        DO icat = 1, ncat

          ta = -zot1*zp(icat)*zm(ian)
          tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
          tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
          trm = ta + tb*tc

          IF (trm>30.0) THEN
            gama(icat,ian) = 1.0E+30
!           xmsg = 'Multicomponent activity coefficient is extremely large'
!           WRITE (6,*) xmsg
          ELSE
            gama(icat,ian) = 10.0**trm
          END IF

        END DO
      END DO

      RETURN
!ia*********************************************************************
    END SUBROUTINE actcof
!ia
!ia     AEROSOL DYNAMICS DRIVER ROUTINE					*
!ia     based on MODELS3 formulation by FZB
!ia     Modified by IA in November 97
!ia
!ia     Revision history
!ia     When    WHO     WHAT
!ia     ----    ----    ----
!ia     ????    FZB     BEGIN
!ia     05/97   IA      Adapted for use in CTM2-S
!ia     11/97   IA      Modified for new model version
!ia                     see comments under iarev02
!ia
!ia     Called BY:      RPMMOD3
!ia
!ia     Calls to:       EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
!ia                     GETVSED
!ia
!ia*********************************************************************
! actcof                                                      
    SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
        blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat, &
        orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,epm25i, &
        epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
        dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
        kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
        ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid)

!     IMPLICIT NONE
! dimension of arrays             
      INTEGER blksize
! number of species in CBLK       
      INTEGER nspcsda
! actual number of cells in arrays
      INTEGER numcells
! number of k-level               
      INTEGER layer
! of organic aerosol precursor  
      INTEGER ldrog
      REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a

      REAL dt
! *** Meteorological information:

! synchronization time  [s]       
      REAL blkta(blksize) ! Air temperature [ K ]                  
      REAL blkprs(blksize) ! Air pressure in [ Pa ]                 
      REAL blkdens(blksize) ! Air density  [ kg/ m**3 ]              
      REAL blkrh(blksize) 
! *** Chemical production rates: [ ug / m**3 s ]

! Fractional relative humidity           
      REAL so4rat(blksize) 
!bs
! sulfate gas-phase production rate     
! total # of cond. vapors & SOA species 
      INTEGER ncv
!bs
      INTEGER nacv
!bs * organic condensable vapor production rate
! # of anthrop. cond. vapors & SOA speci
      REAL drog(blksize,ldrog) !bs
! *** anthropogenic organic aerosol mass production rates from aromatics
! Delta ROG conc. [ppm]              
      REAL orgaro1rat(blksize)

! *** anthropogenic organic aerosol mass production rates from aromatics
      REAL orgaro2rat(blksize)

! *** anthropogenic organic aerosol mass production rates from alkanes &
      REAL orgalk1rat(blksize)

! *** anthropogenic organic aerosol mass production rates from alkenes &
      REAL orgole1rat(blksize)

! *** biogenic organic aerosol production rates
      REAL orgbio1rat(blksize)

! *** biogenic organic aerosol production rates
      REAL orgbio2rat(blksize)

! *** biogenic organic aerosol production rates
      REAL orgbio3rat(blksize)

! *** biogenic organic aerosol production rates
      REAL orgbio4rat(blksize)

! *** Primary emissions rates: [ ug / m**3 s ]

! *** emissions rates for unidentified PM2.5 mass
      REAL epm25i(blksize) ! Aitken mode                         
      REAL epm25j(blksize) 
! *** emissions rates for primary organic aerosol
! Accumululaton mode                  
      REAL eorgi(blksize) ! Aitken mode                          
      REAL eorgj(blksize) 
! *** emissions rates for elemental carbon
! Accumululaton mode                   
      REAL eeci(blksize) ! Aitken mode                           
      REAL eecj(blksize) 
! *** emissions rates for coarse mode particles
! Accumululaton mode                    
      REAL esoil(blksize) ! soil derived coarse aerosols          
      REAL eseas(blksize) ! marine coarse aerosols                
      REAL epmcoarse(blksize) 

! *** OUTPUT:

! *** atmospheric properties

! anthropogenic coarse aerosols         
      REAL xlm(blksize) ! atmospheric mean free path [ m ]  
      REAL amu(blksize) 
! *** modal diameters: [ m ]

! atmospheric dynamic viscosity [ kg
      REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
      REAL dgacc(blksize) ! accumulation geometric mean diamet
      REAL dgcor(blksize) 

! *** aerosol properties:

! *** Modal mass concentrations [ ug m**3 ]

! coarse mode geometric mean diamete
      REAL pmassn(blksize) ! mass concentration in Aitken mode 
      REAL pmassa(blksize) ! mass concentration in accumulation
      REAL pmassc(blksize) 
! *** average modal particle densities  [ kg/m**3 ]

! mass concentration in coarse mode 
      REAL pdensn(blksize) ! average particle density in nuclei
      REAL pdensa(blksize) ! average particle density in accumu
      REAL pdensc(blksize) 
! *** average modal Knudsen numbers

! average particle density in coarse
      REAL knnuc(blksize) ! nuclei mode  Knudsen number       
      REAL knacc(blksize) ! accumulation Knudsen number       
      REAL kncor(blksize) 
! ***  modal condensation factors ( see comments in NUCLCOND )

! coarse mode  Knudsen number       
      REAL fconcn(blksize)
      REAL fconca(blksize)
!bs
      REAL fconcn_org(blksize)
      REAL fconca_org(blksize)
!bs

! *** Rates for secondary particle formation:

! *** production of new mass concentration [ ug/m**3 s ]
      REAL dmdt(blksize) !                                 by particle formation

! *** production of new number concentration [ number/m**3 s ]

! rate of production of new mass concen
      REAL dndt(blksize) !                                 by particle formation

! *** growth rate for third moment by condensation of precursor
!      vapor on existing particles [ 3rd mom/m**3 s ]

! rate of producton of new particle num
      REAL cgrn3(blksize) !  Aitken mode                          
      REAL cgra3(blksize) 
! *** Rates for coaglulation: [ m**3/s ]

! *** Unimodal Rates:

!  Accumulation mode                    
      REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
      REAL ura00(blksize) 

! *** Bimodal Rates:  Aitken mode with accumulation mode ( d( Aitken mod

! accumulation mode 0th moment self-coagulat
      REAL brna01(blksize) 
! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
! rate for 0th moment                     
      REAL c30(blksize)                                                        ! by intermodal c

! *** other processes

! intermodal 3rd moment transfer r
      REAL deltaso4a(blksize) !                                  sulfate aerosol by condensation   [ u

!      INTEGER NN, VV ! loop indICES

! increment of concentration added to   
! ////////////////////// Begin code ///////////////////////////////////

! concentration lower limit  
      CHARACTER*16 pname
      PARAMETER (pname=' AEROPROC       ')

      INTEGER unit
      PARAMETER (unit=20)
      integer igrid,jgrid,kgrid

! *** get water, ammonium  and nitrate content:
!     for now, don't call if temp is below -40C (humidity
!     for this wrf version is already limited to 10 percent)

        if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
           CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
        endif

! *** get size distribution information:

      CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
        pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
        kncor)

! *** Calculate coagulation rates for fine particles:

      CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
        dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)

! *** get condensation and particle formation (nucleation) rates:

      CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
        so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
        orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
        fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)

        if(dndt(1).lt.-10.)print*,'dndt in aeroproc',dndt
        
! *** advance forward in time  DT seconds:
      CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,orgaro1rat, &
        orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat, &
        orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
        dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
        dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)

! *** get new distribution information:

      CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
        pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
        kncor)

      RETURN
    END SUBROUTINE aeroproc
!//////////////////////////////////////////////////////////////////
! *** Time stepping code advances the aerosol moments one timestep;

    SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat         &
       ,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat     &
       ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
       ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn      &
       ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
        igrid,jgrid,kgrid                                                     &
                                                                             )

!***********************************************************************

!      NOTE:

! ***  DESCRIPTION: Integrate the Number and Mass equations
!                   for each mode over the time interval DT.

!      PRECONDITIONS:
!       AEROSTEP() must follow calls to all other dynamics routines.

! ***   Revision history:
!       Adapted 3/95 by UAS and CJC from EAM2's code.
!       Revised 7/29/96 by FSB to use block structure
!       Revised 11/15/96 by FSB dropped flow-through and cast
!                           number solver into Riccati equation form.
!       Revised 8/8/97 by FSB to have mass in Aitken and accumulation mo
!                        each predicted rather than total mass and
!                        Aitken mode mass. Also used a local approximati
!                        the error function. Also added coarse mode.
!       Revised 9/18/97 by FSB to fix mass transfer from Aitken to
!                       accumulation mode by coagulation
!       Revised 10/27/97 by FSB to modify code to use primay emissions
!                        and to correct 3rd moment updates.
!                        Also added coarse mode.
!       Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
!       Revised  11/5/97 by FSB to fix error in MSTRNSFR
!       Revised  11/6/97 FSB to correct the expression for FACTRANS to
!                        remove the 6/pi coefficient. UAS found this.
!       Revised 12/15/97 by FSB to change equations for mass concentrati
!                        to a chemical production form with analytic
!                        solutions for the Aitken mode and to remove
!                        time stepping of the 3rd moments. The mass conc
!                        in the accumulation mode is updated with a forw
!                        Euler step.
!       Revised 1/6/98   by FSB Lowered minimum concentration for
!                        sulfate aerosol to 0.1 [ ng / m**3 ].
!       Revised 1/12/98  C30 replaces BRNA31 as a variable. C30 represen
!                        intermodal transfer rate of 3rd moment in place
!                        of 3rd moment coagulation rate.
!       Revised 5/5/98   added new renaming criterion based on diameters
!       Added   3/23/98  by BS condensational groth factors for organics

!**********************************************************************

!     IMPLICIT NONE

!     Includes:

! *** ARGUMENTS:

! dimension of arrays             
      INTEGER blksize
! actual number of cells in arrays
      INTEGER numcells
! nmber of species in CBLK        
      INTEGER nspcsda
! model layer                     
      INTEGER layer
      REAL cblk(blksize,nspcsda) ! main array of variables          
      INTEGER igrid,jgrid,kgrid
      REAL dt
! *** Chemical production rates: [ ug / m**3 s ]

! time step [sec]                  
      REAL so4rat(blksize) 
! *** anthropogenic organic aerosol mass production rates from aromatics
! sulfate gas-phase production rate     
      REAL orgaro1rat(blksize)
      REAL orgaro2rat(blksize)

! *** anthropogenic organic aerosol mass production rates from alkanes &
      REAL orgalk1rat(blksize)
      REAL orgole1rat(blksize)

! *** biogenic organic aerosol production rates
      REAL orgbio1rat(blksize)
      REAL orgbio2rat(blksize)
      REAL orgbio3rat(blksize)
      REAL orgbio4rat(blksize)

! *** Primary emissions rates: [ ug / m**3 s ]

! *** emissions rates for unidentified PM2.5 mass
      REAL epm25i(blksize) ! Aitken mode                         
      REAL epm25j(blksize) 
! *** emissions rates for primary organic aerosol
! Accumululaton mode                  
      REAL eorgi(blksize) ! Aitken mode                          
      REAL eorgj(blksize) 
! *** emissions rates for elemental carbon
! Accumululaton mode                    
      REAL eeci(blksize) ! Aitken mode                           
      REAL eecj(blksize) 
! *** emissions rates for coarse mode particles
! Accumululaton mode                    
      REAL esoil(blksize) ! soil derived coarse aerosols          
      REAL eseas(blksize) ! marine coarse aerosols                
      REAL epmcoarse(blksize) 
! anthropogenic coarse aerosols         
      REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
      REAL dgacc(blksize) 
! accumulation                          
      REAL fconcn(blksize)                                 ! Aitken mode  [ 1 / s ]
! reciprocal condensation rate          
      REAL fconca(blksize)                                 ! acclumulation mode [ 1 / s ]
! reciprocal condensation rate          
      REAL fconcn_org(blksize)                                 ! Aitken mode  [ 1 / s ]
! reciprocal condensation rate for organ
      REAL fconca_org(blksize)                                 ! acclumulation mode [ 1 / s ]
! reciprocal condensation rate for organ
      REAL dmdt(blksize)                                 ! by particle formation [ ug/m**3 /s ]
! rate of production of new mass concent
      REAL dndt(blksize)                                 ! by particle formation [ number/m**3 /s
! rate of producton of new particle numb
      REAL deltaso4a(blksize)                                 ! sulfate aerosol by condensation [ ug/m
! increment of concentration added to   
      REAL urn00(blksize) ! Aitken intramodal coagulation rate    
      REAL ura00(blksize) ! Accumulation mode intramodal coagulati
      REAL brna01(blksize) ! bimodal coagulation rate for number   
      REAL c30(blksize)       							! by intermodal coagulation
! intermodal 3rd moment transfer rate by
      REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken 
      REAL cgra3(blksize) 
! *** Modal mass concentrations [ ug m**3 ]

! growth rate for 3rd moment for Accumul
      REAL pmassn(blksize) ! mass concentration in Aitken mode 
      REAL pmassa(blksize) ! mass concentration in accumulation
      REAL pmassc(blksize) 

! *** Local Variables

! mass concentration in coarse mode 
      INTEGER l, lcell, & 
        spc
! ** following scratch variables are used for solvers

! *** variables needed for modal dynamics solvers:

! Loop indices                   
      REAL*8 a, b, c
      REAL*8 m1, m2, y0, y
      REAL*8 dhat, p, pexpdt, expdt
      REAL*8 loss, prod, pol, lossinv
! mass intermodal transfer by coagulation           
      REAL mstrnsfr

      REAL factrans

! *** CODE additions for renaming
      REAL getaf2
      REAL aaa, xnum, xm3, fnum, fm3, phnum, & ! Defined below
        phm3
      REAL erf, & ! Error and complementary error function   
        erfc

      REAL xx
! dummy argument for ERF and ERFC          
! a numerical value for a minimum concentration       

! *** This value is smaller than any reported tropospheric concentration

!     :::::::::::::::::::::::::::::::::::::
! *** Statement function given for error function. Source is
!     Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
!      droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
!      20:253-265. They cite Reasearch & Education Asociation (REA), (19
!      Handbook of Mathematical, Scientific, and Engineering Formulas,
!      Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49

      erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
      erfc(xx) = 1.0 - erf(xx)
!     ::::::::::::::::::::::::::::::::::::::::

! ///// begin code

! *** set up time-step integration

      DO l = 1, numcells

! *** code to move number forward by one time step.
! *** solves the Ricatti equation:

!     dY/dt = C - A * Y ** 2 - B * Y

!     Coded 11/21/96 by Dr. Francis S. Binkowski

! *** Aitken mode:

! *** coefficients

        a = urn00(l)
        b = brna01(l)*cblk(l,vac0)
        c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l)) 

! includes primary emissions 
        y0 = cblk(l,vnu0) 
! ***  trap on C = 0

! initial condition                           
        IF (c>0.0D0) THEN

          dhat = sqrt(b*b+4.0D0*a*c)

          m1 = 2.0D0*a*c/(b+dhat)

          m2 = -0.5D0*(b+dhat)

          p = -(m1-a*y0)/(m2-a*y0)

          pexpdt = p*exp(-dhat*dt)

          y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) 
! solution                       
        ELSE

! *** rearrange solution for NUMERICAL stability
!     note If B << A * Y0, the following form, although
!     seemingly awkward gives the correct answer.

          expdt = exp(-b*dt)
          IF (expdt<1.0D0) THEN
            y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
          ELSE
            y = y0
          END IF

        END IF
        if(y.lt.nummin_i)then
          print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
          print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
          print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
        endif

        cblk(l,vnu0) = max(nummin_i,y) 

! *** now do accumulation mode number

! *** coefficients

! update                     
        a = ura00(l)
        b = & ! NOTE B = 0.0                                         
          0.0D0
        c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l)) 
! includes primary emissi
        y0 = cblk(l,vac0) 
! *** this equation requires special handling, because C can be zero.
!     if this happens, the form of the equation is different:

! initial condition                           
!       print *,vac0,y0,c,nummin_j,a
        IF (c>0.0D0) THEN

          dhat = sqrt(4.0D0*a*c)

          m1 = 2.0D0*a*c/dhat

          m2 = -0.5D0*dhat

          p = -(m1-a*y0)/(m2-a*y0)

!       print *,p,-dhat,dt,-dhat*dt
!       print *,exp(-dhat*dt)
          pexpdt = p*exp(-dhat*dt)

          y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) 
! solution                       
        ELSE

          y = y0/(1.0D0+dt*a*y0) 
!       print *,dhat,y0,dt,a
          y = y0/(1.+dt*a*y0) 
!       print *,y
! correct solution to equatio
        END IF

        cblk(l,vac0) = max(nummin_j,y) 
! *** now do coarse mode number neglecting coagulation
! update                     
!       print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
        prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)

!       print *,cblk(l,vcorn),factnumc,prod
        cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt

! *** Prepare to advance modal mass concentration one time step.

! *** Set up production and and intermodal transfer terms terms:
!       print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
        cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l) 

! includes growth from pri
        cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
          orgfac*eorgj(l)                                              ! and transfer of 3rd momen
                                             ! intermodal coagulation

! *** set up transfer coefficients for coagulation between Aitken and ac

! *** set up special factors for mass transfer from the Aitken to accumu
!     intermodal coagulation. The mass transfer rate is proportional to
!     transfer rate, C30. The proportionality factor is p/6 times the th
!     density. The average particle density for a species is the species
!     divided by the particle volume concentration, pi/6 times the 3rd m
!     The p/6 coefficients cancel.

! includes growth from prim
!       print *,'loss',vnu3,c30(l),cblk(l,vnu3)
        loss = c30(l)/cblk(l,vnu3) 

! Normalized coagulation transfer r
        factrans = loss* &                             ! yields an estimate of the amount of mass t
          dt
                            ! the Aitken to the accumulation mode in the

! Multiplying this factor by the species con
!       print *,'factrans = ',factrans,loss
        expdt = exp(-factrans)                               ! decay term is common to all Aitken mode
!       print *,'factrans = ',factrans,loss,expdt
! variable name is re-used here. This expo
        lossinv = 1.0/ & 
          loss
! *** now advance mass concentrations one time step.

! ***  update sulfuric acid vapor concentration by removing mass concent
!      condensed sulfate and newly produced particles.
! *** The method follows Youngblood and Kreidenweis, Further Development
!     of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
!     Atmospheric Science Paper Number 550, April,1994, pp 85-89.
! set up for multiplication rather than divi
        cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))

! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
! *** Solution is:     c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)

! *** sulfate:

        mstrnsfr = cblk(l,vso4ai)*factrans
        prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
        pol = prod*lossinv
!       print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr

        cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt

        cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))

        cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr

! *** anthropogenic secondary organic:
!bs * anthropogenic secondary organics from aromatic precursors

        mstrnsfr = cblk(l,vorgaro1i)*factrans
        prod = orgaro1rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgaro1i) = pol + (cblk(l,vorgaro1i)-pol)*expdt

        cblk(l,vorgaro1i) = max(conmin,cblk(l,vorgaro1i))

        cblk(l,vorgaro1j) = cblk(l,vorgaro1j) + orgaro1rat(l)*fconca_org(l)*dt &
          + mstrnsfr
!bs * second species from aromatics
        mstrnsfr = cblk(l,vorgaro2i)*factrans
        prod = orgaro2rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgaro2i) = pol + (cblk(l,vorgaro2i)-pol)*expdt

        cblk(l,vorgaro2i) = max(conmin,cblk(l,vorgaro2i))

        cblk(l,vorgaro2j) = cblk(l,vorgaro2j) + orgaro2rat(l)*fconca_org(l)*dt &
          + mstrnsfr

!bs * anthropogenic secondary organics from alkanes & other precursors
!bs * higher alkanes
        mstrnsfr = cblk(l,vorgalk1i)*factrans
        prod = orgalk1rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgalk1i) = pol + (cblk(l,vorgalk1i)-pol)*expdt

        cblk(l,vorgalk1i) = max(conmin,cblk(l,vorgalk1i))

        cblk(l,vorgalk1j) = cblk(l,vorgalk1j) + orgalk1rat(l)*fconca_org(l)*dt &
          + mstrnsfr
!bs * higher olefines
        mstrnsfr = cblk(l,vorgole1i)*factrans
        prod = orgole1rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgole1i) = pol + (cblk(l,vorgole1i)-pol)*expdt

        cblk(l,vorgole1i) = max(conmin,cblk(l,vorgole1i))

        cblk(l,vorgole1j) = cblk(l,vorgole1j) + orgole1rat(l)*fconca_org(l)*dt &
          + mstrnsfr

! *** biogenic secondary organic

        mstrnsfr = cblk(l,vorgba1i)*factrans
        prod = orgbio1rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgba1i) = pol + (cblk(l,vorgba1i)-pol)*expdt

        cblk(l,vorgba1i) = max(conmin,cblk(l,vorgba1i))

        cblk(l,vorgba1j) = cblk(l,vorgba1j) + orgbio1rat(l)*fconca_org(l)*dt + &
          mstrnsfr
!bs * second biogenic species
        mstrnsfr = cblk(l,vorgba2i)*factrans
        prod = orgbio2rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgba2i) = pol + (cblk(l,vorgba2i)-pol)*expdt

        cblk(l,vorgba2i) = max(conmin,cblk(l,vorgba2i))

        cblk(l,vorgba2j) = cblk(l,vorgba2j) + orgbio2rat(l)*fconca_org(l)*dt + &
          mstrnsfr

!bs * third biogenic species
        mstrnsfr = cblk(l,vorgba3i)*factrans
        prod = orgbio3rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgba3i) = pol + (cblk(l,vorgba3i)-pol)*expdt

        cblk(l,vorgba3i) = max(conmin,cblk(l,vorgba3i))

        cblk(l,vorgba3j) = cblk(l,vorgba3j) + orgbio3rat(l)*fconca_org(l)*dt + &
          mstrnsfr

!bs * fourth biogenic species
        mstrnsfr = cblk(l,vorgba4i)*factrans
        prod = orgbio4rat(l)*fconcn_org(l)
        pol = prod*lossinv

        cblk(l,vorgba4i) = pol + (cblk(l,vorgba4i)-pol)*expdt

        cblk(l,vorgba4i) = max(conmin,cblk(l,vorgba4i))

        cblk(l,vorgba4j) = cblk(l,vorgba4j) + orgbio4rat(l)*fconca_org(l)*dt + &
          mstrnsfr

! *** primary anthropogenic organic

        mstrnsfr = cblk(l,vorgpai)*factrans
        prod = eorgi(l)
        pol = prod*lossinv

        cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt

        cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))

        cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr

! *** other anthropogenic PM2.5

        mstrnsfr = cblk(l,vp25ai)*factrans
        prod = epm25i(l)
        pol = prod*lossinv

        cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt

        cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))

        cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr

! ***  elemental carbon

        mstrnsfr = cblk(l,veci)*factrans
        prod = eeci(l)
        pol = prod*lossinv

        cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt

        cblk(l,veci) = max(conmin,cblk(l,veci))

        cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr

! ***  coarse mode

! *** soil dust

        cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
        cblk(l,vsoila) = max(conmin,cblk(l,vsoila))

! *** sea salt

        cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
        cblk(l,vseas) = max(conmin,cblk(l,vseas))

! *** anthropogenic PM10 coarse fraction

        cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
        cblk(l,vantha) = max(conmin,cblk(l,vantha))

      END DO

! *** Check for mode merging,if Aitken mode is growing faster than j-mod
!     then merge modes by renaming.

! *** use Binkowski-Kreidenweis paradigm, now including emissions

! end of time-step loop for total mass                 
      DO lcell = 1, numcells

!       IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
!    &      CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
        IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
            lcell,vnu0)>cblk(lcell,vac0)) & 
            THEN

! check if mer
          aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
            dgacc(lcell),xxlsgn,xxlsga,sqrt2)

! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
!        dd is the diameter at which the Aitken-mode and accumulation-mo
!        distributions intersect (overap).

          xnum = max(aaa,xxm3)                                    ! this means that no more than one ha
                                   ! total Aitken mode number may be tra
                                   ! per call.

! do not let XNUM become negative bec
          xm3 = xnum - & 
            xxm3
! set up for 3rd moment and mass tran
          IF (xm3>0.0) & 
              THEN
! do mode merging if  overlap is corr
            phnum = 0.5*(1.0+erf(xnum))
            phm3 = 0.5*(1.0+erf(xm3))
            fnum = 0.5*erfc(xnum)
            fm3 = 0.5*erfc(xm3)

!     In the Aitken mode:

! *** FNUM and FM3 are the fractions of the number and 3rd moment
!     distributions with  diameters greater than dd respectively.

! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
!     distributions with diameters less than dd.

! *** rename the  Aitken mode particle number as accumulation mode
!     particle number

            cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)

! *** adjust the Aitken mode number

            cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)

! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
!     to the accumulation mode is proportional to the amount of 3rd mome
!     transferred, therefore FM3 is used for mass transfer.

            cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3

            cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3

            cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3

            cblk(lcell,vorgaro1j) = cblk(lcell,vorgaro1j) + &
              cblk(lcell,vorgaro1i)*fm3

            cblk(lcell,vorgaro2j) = cblk(lcell,vorgaro2j) + &
              cblk(lcell,vorgaro2i)*fm3

            cblk(lcell,vorgalk1j) = cblk(lcell,vorgalk1j) + &
              cblk(lcell,vorgalk1i)*fm3

            cblk(lcell,vorgole1j) = cblk(lcell,vorgole1j) + &
              cblk(lcell,vorgole1i)*fm3

            cblk(lcell,vorgba1j) = cblk(lcell,vorgba1j) + &
              cblk(lcell,vorgba1i)*fm3

            cblk(lcell,vorgba2j) = cblk(lcell,vorgba2j) + &
              cblk(lcell,vorgba2i)*fm3

            cblk(lcell,vorgba3j) = cblk(lcell,vorgba3j) + &
              cblk(lcell,vorgba3i)*fm3

            cblk(lcell,vorgba4j) = cblk(lcell,vorgba4j) + &
              cblk(lcell,vorgba4i)*fm3

            cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + &
              cblk(lcell,vorgpai)*fm3

            cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3

            cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3

! *** update Aitken mode for mass loss to accumulation mode

            cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3

            cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3

            cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3

            cblk(lcell,vorgaro1i) = cblk(lcell,vorgaro1i)*phm3

            cblk(lcell,vorgaro2i) = cblk(lcell,vorgaro2i)*phm3

            cblk(lcell,vorgalk1i) = cblk(lcell,vorgalk1i)*phm3

            cblk(lcell,vorgole1i) = cblk(lcell,vorgole1i)*phm3

            cblk(lcell,vorgba1i) = cblk(lcell,vorgba1i)*phm3

            cblk(lcell,vorgba2i) = cblk(lcell,vorgba2i)*phm3

            cblk(lcell,vorgba3i) = cblk(lcell,vorgba3i)*phm3

            cblk(lcell,vorgba4i) = cblk(lcell,vorgba4i)*phm3

            cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3

            cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3

            cblk(lcell,veci) = cblk(lcell,veci)*phm3

          END IF
! end check on whether modal overlap is OK             

        END IF
! end check on necessity for merging                   

      END DO
!     set min value for all concentrations

! loop for merging                                       
      DO spc = 1, nspcsda
        DO lcell = 1, numcells
          cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
        END DO
      END DO

      RETURN

!#######################################################################
    END SUBROUTINE aerostep
! aerostep                                                 
    SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
! NOTE!!! wh2o is returned in micrograms / cubic meter
!         mso4,mnh4,mno3 are in microMOLES / cubic meter

!  This  version uses polynomials rather than tables, and uses empirical
! polynomials for the mass fraction of solute (mfs) as a function of wat
!   where:

!            mfs = ms / ( ms + mw)
!             ms is the mass of solute
!             mw is the mass of water.

!  Define y = mw/ ms

!  then  mfs = 1 / (1 + y)

!    y can then be obtained from the values of mfs as

!             y = (1 - mfs) / mfs

!     the aerosol is assumed to be in a metastable state if the rh is
!     is below the rh of deliquescence, but above the rh of crystallizat

!     ZSR interpolation is used for sulfates with x ( the molar ratio of
!     ammonium to sulfate in eh range 0 <= x <= 2, by sections.
!     section 1: 0 <= x < 1
!     section 2: 1 <= x < 1.5
!     section 3: 1.5 <= x < 2.0
!     section 4: 2 <= x
!     In sections 1 through 3, only the sulfates can affect the amount o
!     on the particles.
!     In section 4, we have fully neutralized sulfate, and extra ammoniu
!     allows more nitrate to be present. Thus, the ammount of water is c
!     using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
!     assumed to occur in sections 2,3,and 4. See detailed discussion be

! definitions:
!     mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
!      for sulfate, ammonium, and nitrate respectively
!     irhx is the relative humidity (%)
!     wh2o is the returned water amount in micrograms / cubic meter of a
!     x is the molar ratio of ammonium to sulfate
!     y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
!     for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
!     y3 is the value of the mass ratio of water to solute for
!     a pure ammonium nitrate  solution.

!oded by Dr. Francis S. Binkowski, 4/8/96.

!     IMPLICIT NONE
      INTEGER irhx, irh
      REAL mso4, mnh4, mno3
      REAL tso4, tnh4, tno3, wh2o, x
      REAL aw, awc
!     REAL poly4, poly6
      REAL mfs0, mfs1, mfs15, mfs2
      REAL c0(4), c1(4), c15(4), c2(4)
      REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
      REAL kso4(6), kno3(6), mfsso4, mfsno3

      REAL mwso4, mwnh4, mwno3, mw2, mwano3

! *** molecular weights:
      PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
        mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)

!     The polynomials use data for aw as a function of mfs from Tang and
!     Munkelwitz, JGR 99: 18801-18808, 1994.
!     The polynomials were fit to Tang's values of water activity as a
!     function of mfs.

! *** coefficients of polynomials fit to Tang and Munkelwitz data
!     now give mfs as a function of water activity.

      DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
      DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
      DATA c2/2.085067, -6.024139, 8.967967, -5.002934/

! *** the following coefficients are a fit to the data in Table 1 of
!     Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
!      data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
! *** New data fit to data from
!       Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
!       Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
!       Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
      DATA c0/0.798079, -1.574367, 2.536686, -1.735297/

! *** polynomials for ammonium nitrate and ammonium sulfate are from:
!     Chan et al.1992, Atmospheric Environment (26A): 1661-1673.

      DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
      DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/

! *** check range of per cent relative humidity
      irh = irhx
      irh = max(1,irh)
      irh = min(irh,100)
      aw = float(irh)/ & ! water activity = fractional relative h
        100.0
      tso4 = max(mso4,0.0)
      tnh4 = max(mnh4,0.0)
      tno3 = max(mno3,0.0)
      x = 0.0
! *** if there is non-zero sulfate calculate the molar ratio
      IF (tso4>0.0) THEN
        x = tnh4/tso4
      ELSE
! *** otherwise check for non-zero nitrate and ammonium
        IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
      END IF

! *** begin screen on x for calculating wh2o
      IF (x<1.0) THEN

        mfs0 = poly4(c0,aw)
        mfs1 = poly4(c1,aw)
        y0 = (1.0-mfs0)/mfs0
        y1 = (1.0-mfs1)/mfs1
        y = (1.0-x)*y0 + x*y1

      ELSE IF (x<1.5) THEN

        IF (irh>=40) THEN
          mfs1 = poly4(c1,aw)
          mfs15 = poly4(c15,aw)
          y1 = (1.0-mfs1)/mfs1
          y15 = (1.0-mfs15)/mfs15
          y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
        ELSE
! *** set up for crystalization

! *** Crystallization is done as follows:
!      For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
!      For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
!      and since the code does not allow ar rh < 0.01, crystallization
!      is assumed not to occur in this range.
!      For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
!      from a value of y15 at rh = 0.4 to a value of zero at y1. From
!      point B to point A in the diagram.
!      The algorithm does a double interpolation to calculate the amount
!      water.

!        y1(0.40)               y15(0.40)
!         +                     + Point B

!         +--------------------+
!       x=1                   x=1.5
!      Point A

          awc = 0.80*(x-1.0) ! rh along the crystallization curve.
          y = 0.0
          IF (aw>=awc) & ! interpolate using crystalization 
              THEN
            mfs1 = poly4(c1,0.40)
            mfs15 = poly4(c15,0.40)
            y140 = (1.0-mfs1)/mfs1
            y1540 = (1.0-mfs15)/mfs15
            y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
            yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
            y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
! end of checking for aw                             
          END IF

        END IF
! end of checking on irh                               
      ELSE IF (x<1.9999) THEN

        y = 0.0
        IF (irh>=40) THEN
          mfs15 = poly4(c15,aw)
          mfs2 = poly4(c2,aw)
          y15 = (1.0-mfs15)/mfs15
          y2 = (1.0-mfs2)/mfs2
          y = 2.0*(y15*(2.0-x)+y2*(x-1.5))

        END IF

! end of check for crystallization                    

      ELSE
! regime where ammonium sulfate and ammonium nitrate are in solution.

! *** following cf&s for both ammonium sulfate and ammonium nitrate
! *** check for crystallization here. their data indicate a 40% value
!     is appropriate.
! 1.9999 < x                                                 
        y2 = 0.0
        y3 = 0.0
        IF (irh>=40) THEN
          mfsso4 = poly6(kso4,aw)
          mfsno3 = poly6(kno3,aw)
          y2 = (1.0-mfsso4)/mfsso4
          y3 = (1.0-mfsno3)/mfsno3

        END IF

      END IF
! *** now set up output of wh2o

!      wh2o units are micrograms (liquid water) / cubic meter of air

! end of checking on x                                    
      IF (x<1.9999) THEN

        wh2o = y*(tso4*mwso4+mwnh4*tnh4)

      ELSE

! *** this is the case that all the sulfate is ammonium sulfate
!     and the excess ammonium forms ammonum nitrate

        wh2o = y2*tso4*mw2 + y3*tno3*mwano3

      END IF

      RETURN
    END SUBROUTINE awater
!//////////////////////////////////////////////////////////////////////

    SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
        dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
!***********************************************************************
!**    DESCRIPTION:  calculates aerosol coagulation rates for unimodal
!       and bimodal coagulation using E. Whitby 1990's prescription.

!.......   Rates for coaglulation:
!.......   Unimodal Rates:
!.......   URN00:  nuclei       mode 0th moment self-coagulation rate
!.......   URA00:  accumulation mode 0th moment self-coagulation rate

!.......   Bimodal Rates:  (only 1st order coeffs appear)
!.......   NA-- nuclei  with accumulation coagulation rates,
!.......   AN-- accumulation with nuclei coagulation rates
!.......   BRNA01:  rate for 0th moment ( d(nuclei mode 0) / dt  term)
!.......   BRNA31:           3rd        ( d(nuclei mode 3) / dt  term)
!**
!**
!**    Revision history:
!       prototype 1/95 by Uma and Carlie
!       Revised   8/95 by US for calculation of density from stmt func
!                 and collect met variable stmt funcs in one include fil
!      REVISED 7/25/96 by FSB to use block structure
!      REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
!      REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
!                              changed. All coagulation coefficients
!                              returned with positive signs. Their
!                              linearization is also abandoned.
!                              Fixed values are used for the corrections
!                              to the free-molecular coagulation integra
!                              The code forces the harmonic means to be
!                              evaluated in 64 bit arithmetic on 32 bit
!     REVISED 11/14/96 BY FSB  Internal units are now MKS, moment / unit

!      REVISED 1/12/98 by FSB   C30 replaces BRNA31 as an array. This wa
!                              because BRNA31 can become zero on a works
!                              because of limited precision. With the ch
!                              aerostep to omit update of the 3rd moment
!                              C30 is the only variable now needed.
!                              the logic using ONE88 to force REAL*8 ari
!                              has been removed and all intermediates ar
!                              REAL*8.

!     IMPLICIT NONE

! dimension of arrays             
      INTEGER blksize
! actual number of cells in arrays
      INTEGER numcells

      INTEGER nspcsda

! nmber of species in CBLK        
      REAL cblk(blksize,nspcsda) ! main array of variables         
      REAL blkta(blksize) ! Air temperature [ K ]           
      REAL pdensn(blksize) ! average particel density in Aitk
      REAL pdensa(blksize) ! average particel density in accu
      REAL amu(blksize) ! atmospheric dynamic viscosity [ 
      REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ] 
      REAL dgacc(blksize) ! accumulation mode mean diameter 
      REAL knnuc(blksize) ! Aitken mode Knudsen number      
      REAL knacc(blksize) 
! *** output:

! accumulation mode Knudsen number
      REAL urn00(blksize) ! intramodal coagulation rate (Ait
      REAL ura00(blksize) 
! intramodal coagulation rate (acc
      REAL brna01(blksize) ! intermodal coagulaton rate (numb
      REAL c30(blksize)                                                               ! by inter

! *** Local variables:
! intermodal 3rd moment transfer r
      REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate      
        kncacc
      REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate      
        kfmacc
      REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate   
        kfm
      REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)  
        bencna
      REAL*8 & ! NC 3rd moment coag rate (nuc mode)    
        bencm3n
      REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)  
        befmna
      REAL*8 & ! FM 3rd moment coag rate (nuc mode)    
        befm3n
      REAL*8 betann, & ! composite coag rates, mom 0 (both mode
        betana
      REAL*8 & ! intermodal coagulation rate for 3rd mo
        brna31
      REAL*8 & ! scratch subexpression                 
        s1
      REAL*8 t1, & ! scratch subexpressions                
        t2
      REAL*8 t16, & ! T1**6, T2**6                          
        t26
      REAL*8 rat, & ! ratio of acc to nuc size and its inver
        rin
      REAL*8 rsqt, & ! sqrt( rat ), rsqt**4                  
        rsq4
      REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )       
        rsqi3
      REAL*8 & ! dgnuc**3                              
        dgn3
      REAL*8 & !                                 in 64 bit arithmetic
        dga3

! dgacc**3                              

      INTEGER lcell
! *** Fixed values for correctionss to coagulation
!      integrals for free-molecular case.
! loop counter                                      
      REAL*8 bm0
      PARAMETER (bm0=0.8D0)
      REAL*8 bm0i
      PARAMETER (bm0i=0.9D0)
      REAL*8 bm3i
      PARAMETER (bm3i=0.9D0)
      REAL*8 & ! approx Cunningham corr. factor      
        a
      PARAMETER (a=1.246D0)

!.......................................................................
!   begin body of subroutine  COAGRATE

!...........   Main computational grid-traversal loops
!...........   for computing coagulation rates.

! *** Both modes have fixed std devs.
      DO lcell = 1, & 
          numcells
! *** moment independent factors

!  loop on LCELL               
        s1 = two3*boltz*blkta(lcell)/amu(lcell)

! For unimodal coagualtion:

        kncnuc = s1
        kncacc = s1

        kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
        kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))

! For bimodal coagulation:

        knc = s1
        kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))

!...........   Begin unimodal coagulation rate calculations:

!...........   Near-continuum regime.

        dgn3 = dgnuc(lcell)**3
        dga3 = dgacc(lcell)**3

        t1 = sqrt(dgnuc(lcell))
        t2 = sqrt(dgacc(lcell))
        t16 = & ! = T1**6                               
          dgn3
        t26 = & 
          dga3
!.......   Note rationalization of fractions and subsequent cancellation
!.......   from the formulation in  Whitby et al. (1990)

! = T2**6                               
        bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))

        bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))

!...........   Free molecular regime. Uses fixed value for correction
!               factor BM0

        befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0

        befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0

!...........   Calculate half the harmonic mean between unimodal rates
!...........   free molecular and near-continuum regimes

! FSB       64 bit evaluation

        betann = bencnn*befmnn/(bencnn+befmnn)
        betana = bencna*befmna/(bencna+befmna)

        urn00(lcell) = betann
        ura00(lcell) = betana

! *** End of unimodal coagulation calculations.

!...........   Begin bimodal coagulation rate calculations:

        rat = dgacc(lcell)/dgnuc(lcell)
        rin = 1.0D0/rat
        rsqt = sqrt(rat)
        rsq4 = rat**2

        rsqti = 1.0D0/rsqt
        rsqi3 = rin*rsqti

!...........   Near-continuum coeffs:
!...........   0th moment nuc mode bimodal coag coefficient

        bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
          )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)

!...........   3rd moment nuc mode bimodal coag coefficient

        bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
          *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
          rin*esn64*esa04)

!...........   Free molecular regime coefficients:
!...........   Uses fixed value for correction
!               factor BM0I, BM3I

!...........   0th moment nuc mode coeff

        befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
          rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)

!...........   3rd moment nuc mode coeff

        befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
          rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)

!...........   Calculate half the harmonic mean between bimodal rates
!...........   free molecular and near-continuum regimes

! FSB       Force 64 bit evaluation

        brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)

        brna31 = bencm3n* & ! BRNA31 now is a scala
          befm3n/(bencm3n+befm3n)
        c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
!       print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
                              ! 3d moment transfer by intermodal coagula

!         End bimodal coagulation rate.

      END DO
! end of main lop over cells                            
      RETURN
!------------------------------------------------------------------
    END SUBROUTINE coagrate
! subroutine  to find the roots of a cubic equation / 3rd order polynomi
! formulae can be found in numer. recip.  on page 145
!   kiran  developed  this version on 25/4/1990
!   dr. francis binkowski modified the routine on 6/24/91, 8/7/97
! ***
!234567
! coagrate                                     
    SUBROUTINE cubic(a2,a1,a0,nr,crutes)
!     IMPLICIT NONE
      INTEGER nr
      REAL*8 a2, a1, a0
      REAL crutes(3)
      REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
      REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
      REAL*8 costh, sinth
      DATA sqrt3/1.732050808/, one3rd/0.333333333/
!bs
      REAL*8 onebs
      PARAMETER (onebs=1.0)
!bs
      a2sq = a2*a2
      qq = (a2sq-3.*a1)/9.
      rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
! CASE 1 THREE REAL ROOTS or  CASE 2 ONLY ONE REAL ROOT
      dum1 = qq*qq*qq
      rrsq = rr*rr
      dum2 = dum1 - rrsq
      IF (dum2>=0.) THEN
! NOW WE HAVE THREE REAL ROOTS
        phi = sqrt(dum1)
        IF (abs(phi)<1.E-20) THEN
          print *, ' cubic phi small, phi = ',phi
          crutes(1) = 0.0
          crutes(2) = 0.0
          crutes(3) = 0.0
          nr = 0
          CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
        END IF
        theta = acos(rr/phi)/3.0
        costh = cos(theta)
        sinth = sin(theta)
! *** use trig identities to simplify the expressions
! *** binkowski's modification
        part1 = sqrt(qq)
        yy1 = part1*costh
        yy2 = yy1 - a2/3.0
        yy3 = sqrt3*part1*sinth
        crutes(3) = -2.0*yy1 - a2/3.0
        crutes(2) = yy2 + yy3
        crutes(1) = yy2 - yy3
! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
        IF (crutes(1)<0.0) crutes(1) = 1.0E9
        IF (crutes(2)<0.0) crutes(2) = 1.0E9
        IF (crutes(3)<0.0) crutes(3) = 1.0E9
! *** put smallest positive root in crutes(1)
        crutes(1) = min(crutes(1),crutes(2),crutes(3))
        nr = 3
!     NOW HERE WE HAVE ONLY ONE REAL ROOT
      ELSE
! dum IS NEGATIVE                                           
        part1 = sqrt(rrsq-dum1)
        part2 = abs(rr)
        part3 = (part1+part2)**one3rd
        crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
!bs     &        -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
        crutes(2) = 0.
        crutes(3) = 0.
!IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
!     if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
        nr = 1
      END IF
      RETURN
!///////////////////////////////////////////////////////////////////////
    END SUBROUTINE cubic

!    Calculate the aerosol chemical speciation and water content.

! cubic                                                     
    SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
!***********************************************************************
!**    DESCRIPTION:
!	Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
!	and water between the gas and aerosol phases as the total sulfate,
!	ammonia, and nitrate concentrations, relative humidity and
!	temperature change.  The evolution of the aerosol mass concentration
!	due to the change in aerosol chemical composition is calculated.
!**    REVISION HISTORY:
!       prototype 1/95 by Uma and Carlie
!       Revised   8/95 by US to calculate air density in stmt func
!                 and collect met variable stmt funcs in one include fil
!       Revised 7/26/96 by FSB to use block concept.
!       Revise 12/1896 to do do i-mode calculation.
!**********************************************************************

!     IMPLICIT NONE

! dimension of arrays             
      INTEGER blksize
! actual number of cells in arrays
      INTEGER numcells
! nmber of species in CBLK        
      INTEGER nspcsda
      REAL cblk(blksize,nspcsda) 
! *** Meteorological information in blocked arays:

! main array of variables         
      REAL blkta(blksize) ! Air temperature [ K ]                   
      REAL blkrh(blksize) 

! Fractional relative humidity            

      INTEGER lcell
! loop counter                                   
! air temperature                             
      REAL temp
!iamodels3
      REAL rh
! relative humidity                           
      REAL so4, no3, nh3, nh4, hno3
      REAL aso4, ano3, ah2o, anh4, gnh3, gno3
! Fraction of dry sulfate mass in i-mode         
      REAL fraci
!.......................................................................
      REAL fracj

!      WRITE(20,*) ' IN EQL 3 '

! Fraction of dry sulfate mass in j-mode         
      DO lcell = 1, &
          numcells
! *** Fetch temperature, fractional relative humidity, and
!     air density

!  loop on cells                    
        temp = blkta(lcell)
        rh = blkrh(lcell)

! *** the following is an interim procedure. Assume the i-mode has the
!     same relative mass concentrations as the total mass. Use SO4 as
!     the surrogate. The results of this should be the same as those
!     from the original RPM.

! *** do total aerosol

        so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)

!iamodels3
        no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
!    &                        + CBLK(LCELL, VHNO3)

        hno3 = cblk(lcell,vhno3)

!iamodels3

        nh3 = cblk(lcell,vnh3)

        nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
!    &                        + CBLK(LCELL, VNH3)

!bs           CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
!bs     &             ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
!bs
!bs * call old version of rpmares
!bs
        CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
          gnh3,gno3)
!bs

! *** get modal fraction
        fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
        fracj = 1.0 - fraci

! *** update do i-mode

        cblk(lcell,vh2oai) = fraci*ah2o
        cblk(lcell,vnh4ai) = fraci*anh4
        cblk(lcell,vno3ai) = fraci*ano3

! *** update accumulation mode:

        cblk(lcell,vh2oaj) = fracj*ah2o
        cblk(lcell,vnh4aj) = fracj*anh4
        cblk(lcell,vno3aj) = fracj*ano3

! *** update gas / vapor phase

        cblk(lcell,vnh3) = gnh3
        cblk(lcell,vhno3) = gno3

      END DO
!  end loop on cells                     
      RETURN

!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    END SUBROUTINE eql3
! eql3                                                    
    SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Get the Jacobian of the function                                  !
!bs                                                                    !
!bs         ( a1 * X1^2 + b1 * X1 + c1 )                               !
!bs         ( a2 * X2^2 + b2 * X1 + c2 )                               !
!bs         ( a3 * X3^2 + b3 * X1 + c3 )                               !
!bs  F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0.                          !
!bs         ( a5 * X5^2 + b5 * X1 + c5 )                               !
!bs         ( a6 * X6^2 + b6 * X1 + c6 )                               !
!bs                                                                    !
!bs   a_i = IMW_i                                                      !
!bs   b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i  !
!bs   c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ]                 !
!bs                                                                    !
!bs          delta F_i    ( 2. * a_i * X_i + b_i           if i .EQ. j !
!bs  J_ij = ----------- = (                                            !
!bs          delta X_j    ( X_i * IMW_j - CTOT_i * IMW_j   if i .NE. j !
!bs                                                                    !
!bs                                                                    !
!bs  Called by:       NEWT                                             !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
!bs
!dimension of problem                   
      INTEGER n
      REAL x(n) !bs
!     INTEGER NP                !bs maximum expected value of N
!     PARAMETER (NP = 6)
!bs initial guess of CAER               
      REAL ct(np)
      REAL cs(np)
      REAL imw(np)
!bs
      REAL fjac(n,n)
!bs
      INTEGER i, & !bs loop index                          
        j
      REAL a(np)
      REAL b(np)
      REAL b1(np)
      REAL b2(np)
      REAL sum_jnei
!bs
      DO i = 1, n
        a(i) = imw(i)
        sum_jnei = 0.
        DO j = 1, n
          sum_jnei = sum_jnei + x(j)*imw(j)
        END DO
        b1(i) = sum_jnei - (x(i)*imw(i))
        b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
        b(i) = b1(i) + b2(i)
      END DO
      DO j = 1, n
        DO i = 1, n
          IF (i==j) THEN
            fjac(i,j) = 2.*a(i)*x(i) + b(i)
          ELSE
            fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
          END IF
        END DO
      END DO
!bs
      RETURN
    END SUBROUTINE fdjac
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed.   !
!bs                                                                    !
!bs  Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name,      !
!bs  user-supplied routine that returns the vector of functions at X.  !
!bs  The common block NEWTV communicates the function values back to   !
!bs  NEWT.                                                             !
!bs                                                                    !
!bs  Called by:       NEWT                                             !
!bs                                                                    !
!bs  Calls:           FUNCV                                            !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!

!     IMPLICIT NONE

!bs
!bs
      INTEGER n
!     INTEGER NP
!     PARAMETER (NP = 6)
      REAL ct(np)
      REAL cs(np)
      REAL imw(np)
      REAL m,fmin
      REAL x(*), fvec(np)

      INTEGER i
      REAL sum

      CALL funcv(n,x,fvec,ct,cs,imw,m)
      sum = 0.
      DO i = 1, n
        sum = sum + fvec(i)**2
      END DO
      fmin = 0.5*sum
      RETURN
    END FUNCTION fmin
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Called by:       FMIN                                             !
!bs                                                                    !
!bs  Calls:           None                                             !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
!bs
      INTEGER n
      REAL x(*)
      REAL fvec(n)
!bs
!     INTEGER NP
!     PARAMETER (NP = 6)
      REAL ct(np)
      REAL cs(np)
      REAL imw(np)
      REAL m
!bs
      INTEGER i, j
      REAL sum_jnei
      REAL a(np)
      REAL b(np)
      REAL c(np)
!bs
      DO i = 1, n
        a(i) = imw(i)
        sum_jnei = 0.
        DO j = 1, n
          sum_jnei = sum_jnei + x(j)*imw(j)
        END DO
        sum_jnei = sum_jnei - (x(i)*imw(i))
        b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
        c(i) = -ct(i)*(sum_jnei+m)
        fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
      END DO
!bs
      RETURN
    END SUBROUTINE funcv
    REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
! *** set up new processor for renaming of particles from i to j modes
!     IMPLICIT NONE
      REAL aa, bb, cc, disc, qq, alfa, l, yji
      REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2

      alfa = xlsgi/xlsgj
      yji = log(dgnj/dgni)/(sqrt2*xlsgi)
      aa = 1.0 - alfa*alfa
      l = log(alfa*nj/ni)
      bb = 2.0*yji*alfa*alfa
      cc = l - yji*yji*alfa*alfa
      disc = bb*bb - 4.0*aa*cc
      IF (disc<0.0) THEN
        getaf = - & ! error in intersection                     
          5.0
        RETURN
      END IF
      qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
      getaf = cc/qq
      RETURN
! *** subroutine to implement Kulmala, Laaksonen, Pirjola
    END FUNCTION getaf
!     Parameterization for sulfuric acid/water
!     nucleation rates, J. Geophys. Research (103), pp 8301-8307,
!     April 20, 1998.

!ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
!ia rev02 27.04.99 security check on MDOT > SO4RAT

!ia      subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
! getaf                                                     
    SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
!     IMPLICIT NONE

! *** Input:

! ambient temperature [ K ]                            
      REAL temp
! fractional relative humidity                         
      REAL rh
! sulfuric acid concentration [ ug / m**3 ]            
      REAL h2so4

      REAL so4rat
! *** Output:

!sulfuric acid production rate [ ug / ( m**3 s )]     
! particle number production rate [ # / ( m**3 s )]   
      REAL ndot1
! particle mass production rate [ ug / ( m**3 s )]    
      REAL mdot1
                 ! [ m**2 / ( m**3 s )]
      REAL m2dot

! *** Internal:

! *** NOTE, all units are cgs internally.
! particle second moment production rate               

      REAL ra
! fractional relative acidity                           
! sulfuric acid vaper concentration [ cm ** -3 ]        
      REAL nav
! water vapor concentration   [ cm ** -3 ]              
      REAL nwv
! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]    
      REAL nav0
                ! to produce a nucleation rate of 1 [ cm ** -3  s ** -1
      REAL nac
! critical sulfuric acid vapor concentration [ cm ** -3 
! mole fractio of the critical nucleus                  
      REAL xal
      REAL nsulf, & ! see usage                                    
        delta
      REAL*8 & ! factor to calculate Jnuc                             
        chi
      REAL*8 & 
        jnuc
! nucleation rate [ cm ** -3  s ** -1 ]               
      REAL tt, & ! dummy variables for statement functions              
        rr
      REAL pi
      PARAMETER (pi=3.14159265)

      REAL pid6
      PARAMETER (pid6=pi/6.0)

! avogadro's constant [ 1/mol ]                   
      REAL avo
      PARAMETER (avo=6.0221367E23)

! universal gas constant [ j/mol-k ]         
      REAL rgasuniv
      PARAMETER (rgasuniv=8.314510)

! 1 atmosphere in pascals                               
      REAL atm
      PARAMETER (atm=1013.25E+02)

! formula weight for h2so4 [ g mole **-1 ]          
      REAL mwh2so4
      PARAMETER (mwh2so4=98.07948)

! diameter of a 3.5 nm particle in cm                  
      REAL d35
      PARAMETER (d35=3.5E-07)
      REAL d35sq
      PARAMETER (d35sq=d35*d35)
! volume of a 3.5 nm particle in cm**3                 
      REAL v35
      PARAMETER (v35=pid6*d35*d35sq)
!ia rev01

      REAL mp
! ***  conversion factors:
! mass of sulfate in a 3.5 nm particle               
                     ! number per cubic cm.
      REAL ugm3_ncm3
! micrograms per cubic meter to                    
      PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
!ia rev01
! molecules to micrograms                          
      REAL nc_ug
      PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)

! *** statement functions **************

      REAL pdens, & 
        rho_p
! particle density [ g / cm**3]                 
      REAL ad0, ad1, ad2, & 
        ad3
! coefficients for density expression    
      PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427) 
! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
!     as a function of relative humidity,
!     J. Aerosol Science, 6, pp 265-271, 1975.

!ia rev01

! fit to Nair & Vohra data                  
                ! the mass of sulfate in a 3.5 nm particle
      REAL mp35
! arithmetic statement function to compute              
      REAL a0, a1, a2, & ! coefficients for cubic in mp35                 
        a3
      PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)

      REAL ph2so4, &                         ! for h2so4 and h2o vapor pressures [ Pa ]
        ph2o

! arithmetic statement functions                
      pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))

      ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)

      ph2so4(tt) = exp(27.78492066-10156.0/tt)

! *** both ph2o and ph2so4 are  as in Kulmala et al.  paper

!ia rev01

! *** function for the mass of sulfate in   a 3.5 nm sphere
! *** obtained from a fit to the number of sulfate monomers in
!     a 3.5 nm particle. Uses data from Nair & Vohra
      mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))

! *** begin code:

!     The 1.0e-6 factor in the following converts from MKS to cgs units

! *** get water vapor concentration [ molecles / cm **3 ]

      nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6

! *** calculate the equilibrium h2so4 vapor concentration.

! *** use Kulmala corrections:

! ***

      nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6

! *** convert sulfuric acid vapor concentration from micrograms
!     per cubic meter to molecules per cubic centimeter.

      nav = ugm3_ncm3*h2so4

! *** calculate critical concentration of sulfuric acid vapor

      nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)

! *** calculate relative acidity

      ra = nav/nav0

! *** calculate temperature correction

      delta = 1.0 + (temp-273.15)/273.14

! *** calculate molar fraction

      xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
        0.0016*temp

! *** calculate Nsulf
      nsulf = log(nav/nac)

! *** calculate particle produtcion rate [ # / cm**3 ]

      chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
        2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh

      jnuc = exp(chi) 
! [ # / cm**3 ]                                   
      ndot1 = (1.0E06)*jnuc
!      write(91,*) ' inside klpnuc '
!     write(91,*) ' Jnuc = ', Jnuc
!     write(91,*) ' NDOT = ', NDOT1

! *** calculate particle density

      rho_p = pdens(rh)

!     write(91,*) ' rho_p =', rho_p

! *** get the mass of sulfate in a 3.5 nm particle

      mp = mp35(rh)                      ! in a 3.5 nm particle at ambient RH

! *** calculate mass production rate [ ug / m**3]
!     assume that the particles are 3.5 nm in diameter.

!     MDOT1 =  (1.0E12) * rho_p * v35 * Jnuc

!ia rev01

! number of micrograms of sulfate                  
      mdot1 = mp*ndot1

!ia rev02

      IF (mdot1>so4rat) THEN

        mdot1 = & 
          so4rat
! limit nucleated mass by available ma
        ndot1 = mdot1/ & 
          mp
! adjust DNDT to this                 
      END IF

      IF (mdot1==0.) ndot1 = 0.

! *** calculate M2 production rate [ m**2 / (m**3 s)]

      m2dot = 1.0E-04*d35sq*ndot1

      RETURN

    END SUBROUTINE klpnuc
    SUBROUTINE lnsrch(ctot,n,xold,fold,g,p,x,f,stpmax,check,func, &
     fvec,ct,cs,imw,m)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed.   !
!bs                                                                    !
!bs  Given an n-dimensional point XOLD(1:N), the value of the function !
!bs  and gradient there, FOLD and G(1:N), and a direction P(1:N),      !
!bs  finds a new point X(1:N) along the direction P from XOLD where    !
!bs  the function FUNC has decreased 'sufficiently'. The new function  !
!bs  value is returned in F. STPMAX is an input quantity that limits   !
!bs  the length of the steps so that you do not try to evaluate the    !
!bs  function in regions where it is undefined or subject to overflow. !
!bs  P is usually the Newton direction. The output quantity CHECK is   !
!bs  false on a normal; exit. It is true when X is too close to XOLD.  !
!bs  In a minimization algorithm, this usually signals convergence and !
!bs  can be ignored. However, in a zero-finding algorithm the calling  !
!bs  program should check whether the convergence is spurious.         !
!bs                                                                    !
!bs  Called by:       NEWT                                             !
!bs                                                                    !
!bs  Calls:           FUNC                                             !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!

!     IMPLICIT NONE
!bs
!bs
      INTEGER n
      LOGICAL check
      REAL f, fold, stpmax
      REAL g(n), p(n), x(n), xold(n)
      REAL func
      REAL ctot(n)
      REAL alf
      REAL ct(np)
      REAL cs(np)
      REAL imw(np)
      REAL fvec(n)
      REAL m

      PARAMETER (alf=1.E-04)

      EXTERNAL func

      INTEGER i
      REAL a, alam, alam2, alamin, b, disc
      REAL f2, fold2, rhs1, rhs2, slope
      REAL sum, temp, test, tmplam

      check = .FALSE.
      sum = 0.
      DO i = 1, n
        sum = sum + p(i)*p(i)
      END DO
      sum = sqrt(sum)
      IF (sum>stpmax) THEN
        DO i = 1, n
          p(i) = p(i)*stpmax/sum
        END DO
      END IF
      slope = 0.
      DO i = 1, n
        slope = slope + g(i)*p(i)
      END DO
      test = 0.
      DO i = 1, n
        temp = abs(p(i))/max(abs(xold(i)),1.)
        IF (temp>test) test = temp
      END DO
      alamin = tolx/test
      alam = 1.

10    CONTINUE

!bs
!bs * avoid negative concentrations and set upper limit given by CTOT.
!bs
      DO i = 1, n
        x(i) = xold(i) + alam*p(i)
        IF (x(i)<=0.) x(i) = conmin
        IF (x(i)>ctot(i)) x(i) = ctot(i)
      END DO
      f = func(x,fvec,n,ct,cs,imw,m)
      IF (alam<alamin) THEN
        DO i = 1, n
          x(i) = xold(i)
        END DO
        check = .TRUE.
        RETURN
      ELSE IF (f<=fold+alf*alam*slope) THEN
        RETURN
      ELSE
        IF (alam==1.) THEN
          tmplam = -slope/(2.*(f-fold-slope))
        ELSE
          rhs1 = f - fold - alam*slope
          rhs2 = f2 - fold2 - alam2*slope
          a = (rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
          b = (-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
          IF (a==0.) THEN
            tmplam = -slope/(2.*b)
          ELSE
            disc = b*b - 3.*a*slope
            tmplam = (-b+sqrt(disc))/(3.*a)
          END IF
          IF (tmplam>0.5*alam) tmplam = 0.5*alam
        END IF
      END IF
      alam2 = alam
      f2 = f
      fold2 = fold
      alam = max(tmplam,0.1*alam)
      GO TO 10

    END SUBROUTINE lnsrch
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    SUBROUTINE lubksb(a,n,np,indx,b)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed.   !
!bs                                                                    !
!bs  Solves the set of N linear equations A * X = B. Here A is input,  !
!bs  not as the matrix A but rather as its LU decomposition,           !
!bs  determined by the routine LUDCMP. B(1:N) is input as the right-   !
!bs  hand side vector B, and returns with the solution vector X. A, N, !
!bs  NP, and INDX are not modified by this routine and can be left in  !
!bs  place for successive calls with different right-hand sides B.     !
!bs  This routine takes into account the possibilitythat B will begin  !
!bs  with many zero elements, so it is efficient for use in matrix     !
!bs  inversion.                                                        !
!bs                                                                    !
!bs  Called by:       NEWT                                             !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
      INTEGER n, np, indx(n)
      REAL a(np,np), b(n)

      INTEGER i, ii, j, ll
      REAL sum

      ii = 0
      DO i = 1, n
        ll = indx(i)
        sum = b(ll)
        b(ll) = b(i)
        IF (ii/=0) THEN
          DO j = ii, i - 1
            sum = sum - a(i,j)*b(j)
          END DO
        ELSE IF (sum/=0) THEN
          ii = i
        END IF
        b(i) = sum
      END DO
      DO i = n, 1, -1
        sum = b(i)
        DO j = i + 1, n
          sum = sum - a(i,j)*b(j)
        END DO
        b(i) = sum/a(i,i)
      END DO

      RETURN
    END SUBROUTINE lubksb
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    SUBROUTINE ludcmp(a,n,np,indx,d,klev)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed.   !
!bs                                                                    !
!bs  Equation (2.3.14) Numerical Recipes, p 36:                        !
!bs   | b_11 b_12 b_13 b_14 |                                          !
!bs   | a_21 b_22 b_23 b_24 |                                          !
!bs   | a_31 a_32 b_33 b_34 |                                          !
!bs   | a_41 a_42 a_43 b_44 |                                          !
!bs                                                                    !
!bs  Given a matrix A(1:N,1:N), with physical dimension NP by NP, this !
!bs  routine replaces it by the LU decomposition of a rowwise          !
!bs  permutation of itself. A and N are input. A is output arranged as !
!bs  in equation (2.3.14) above; INDX(1:N) is an output vector that    !
!bs  records vector that records the row permutation effected by the   !
!bs  partial pivoting; D is output as +-1 depending on whether the     !
!bs  number of row interchanges was even or odd, respectively. This    !
!bs  routine is used in combination with SR LUBKSB to solve linear     !
!bs  equations or invert a matrix.                                     !
!bs                                                                    !
!bs  Called by:       NEWT                                             !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
      INTEGER n, np, indx(n)
      INTEGER nmax
      PARAMETER (nmax=10) !largest expected N                    
      REAL d, a(np,np)
      REAL tiny
      PARAMETER (tiny=1.0E-20)

      INTEGER i, imax, j, k
      REAL aamax, dum, sum, vv(nmax)
      integer klev

      d = 1
      DO i = 1, n
        aamax = 0.
        DO j = 1, n
          IF (abs(a(i,j))>aamax) aamax = abs(a(i,j))
        END DO
        IF (aamax==0) THEN
          print *, 'Singular matrix in ludcmp, klev = ',klev
          a(1,1)=epsilc
!         STOP
        END IF
        vv(i) = 1./aamax
      END DO
      DO j = 1, n
        DO i = 1, j - 1
          sum = a(i,j)
          DO k = 1, i - 1
            sum = sum - a(i,k)*a(k,j)
          END DO
          a(i,j) = sum
        END DO
        aamax = 0.
        DO i = j, n
          sum = a(i,j)
          DO k = 1, j - 1
            sum = sum - a(i,k)*a(k,j)
          END DO
          a(i,j) = sum
          dum = vv(i)*abs(sum)
          IF (dum>=aamax) THEN
            imax = i
            aamax = dum
          END IF
        END DO
        IF (j/=imax) THEN
          DO k = 1, n
            dum = a(imax,k)
            a(imax,k) = a(j,k)
            a(j,k) = dum
          END DO
          d = -d
          vv(imax) = vv(j)
        END IF
        indx(j) = imax
        IF (a(j,j)==0.) a(j,j) = tiny
        IF (j/=n) THEN
          dum = 1./a(j,j)
          DO i = j + 1, n
            a(i,j) = a(i,j)*dum
          END DO
        END IF
      END DO

      RETURN
    END SUBROUTINE ludcmp

! //////////////////////////////////////////////////////////////////

    SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
        pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
        knacc,kncor)
!***********************************************************************

!**    DESCRIPTION:
!       Calculates modal parameters and derived variables,
!       log-squared of std deviation, mode mean size, Knudsen number)
!       based on current values of moments for the modes.
! FSB   Now calculates the 3rd moment, mass, and density in all 3 modes.
!**
!**    Revision history:
!       Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
!       Revised  7/23/96 by FSB to use COMMON blocks and small blocks
!        instead of large 3-d arrays, and to assume a fixed std.
!       Revised 12/06/96 by FSB to include coarse mode
!       Revised 1/10/97 by FSB to have arrays passed in call vector
!**********************************************************************

!     IMPLICIT NONE

!     Includes:

! *** input:

! dimension of arrays             
      INTEGER blksize
! actual number of cells in arrays
      INTEGER numcells

      INTEGER nspcsda

! nmber of species in CBLK        
      REAL cblk(blksize,nspcsda) ! main array of variables          
      REAL blkta(blksize) ! Air temperature [ K ]            
      REAL blkprs(blksize) 
! *** output:

! Air pressure in [ Pa ]           
! concentration lower limit [ ug/m*
! lowest particle diameter ( m )   
      REAL dgmin
      PARAMETER (dgmin=1.0E-09)

! lowest particle density ( Kg/m**3
      REAL densmin
      PARAMETER (densmin=1.0E03)

      REAL pmassn(blksize) ! mass concentration in nuclei mode 
      REAL pmassa(blksize) ! mass concentration in accumulation
      REAL pmassc(blksize) ! mass concentration in coarse mode 
      REAL pdensn(blksize) ! average particel density in Aitken
      REAL pdensa(blksize) ! average particel density in accumu
      REAL pdensc(blksize) ! average particel density in coarse
      REAL xlm(blksize) ! atmospheric mean free path [ m]   
      REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
      REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]   
      REAL dgacc(blksize) ! accumulation                      
      REAL dgcor(blksize) ! coarse mode                       
      REAL knnuc(blksize) ! Aitken mode Knudsen number        
      REAL knacc(blksize) ! accumulation                      
      REAL kncor(blksize) 

! coarse mode                       

      INTEGER lcell
!      WRITE(20,*) ' IN MODPAR '

! *** set up  aerosol  3rd moment, mass, density

! loop counter                            
      DO lcell = 1, numcells

! *** Aitken-mode
!        cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
        cblk(lcell,vnu3) = so4fac*cblk(lcell, &
          vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
          vh2oai)+no3fac*cblk(lcell,vno3ai)+orgfac*cblk(lcell, &
          vorgaro1i)+orgfac*cblk(lcell,vorgaro2i)+orgfac*cblk(lcell, &
          vorgalk1i)+orgfac*cblk(lcell,vorgole1i)+orgfac*cblk(lcell, &
          vorgba1i)+orgfac*cblk(lcell,vorgba2i)+orgfac*cblk(lcell, &
          vorgba3i)+orgfac*cblk(lcell,vorgba4i)+orgfac*cblk(lcell, &
          vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
!          vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan

! *** Accumulation-mode

!        cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
        cblk(lcell,vac3) = so4fac*cblk(lcell, &
          vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
          vh2oaj)+no3fac*cblk(lcell,vno3aj)+orgfac*cblk(lcell, &
          vorgaro1j)+orgfac*cblk(lcell,vorgaro2j)+orgfac*cblk(lcell, &
          vorgalk1j)+orgfac*cblk(lcell,vorgole1j)+orgfac*cblk(lcell, &
          vorgba1j)+orgfac*cblk(lcell,vorgba2j)+orgfac*cblk(lcell, &
          vorgba3j)+orgfac*cblk(lcell,vorgba4j)+orgfac*cblk(lcell, &
          vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
!          vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan

! *** coarse mode

!        cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
!          vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
        cblk(lcell,vcor3) = soilfac*cblk(lcell, &
          vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)

! *** now get particle mass and density

! *** Aitken-mode:

        pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
          vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
          vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, &
          vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, &
          vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, &
          vp25ai)+cblk(lcell,veci)))

! *** Accumulation-mode:

        pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
          vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
          vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, &
          vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, &
          vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
          vp25aj)+cblk(lcell,vecj)))

! *** coarse mode:

        pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
          lcell,vantha))

      END DO
! *** now get particle density, mean free path, and dynamic viscosity

! aerosol  3rd moment and  mass                       
      DO lcell = 1, & 
          numcells
! *** density in [ kg m**-3 ]

! Density and mean free path              
        pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
        pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
        pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))

! *** Calculate mean free path [ m ]:

        xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))

! *** 6.6328E-8 is the sea level values given in Table I.2.8
! *** on page 10 of U.S. Standard Atmosphere 1962

! *** 	Calculate dynamic viscosity [ kg m**-1 s**-1 ]:

! *** U.S. Standard Atmosphere 1962 page 14 expression
!     for dynamic viscosity is:
!     dynamic viscosity =  beta * T * sqrt(T) / ( T + S)
!     where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].

        amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
          (blkta(lcell)+110.4)

      END DO

!...............   Standard deviation fixed in both modes, so
!...............   diagnose diameter from 3rd moment and number concentr

!  density and mean free path 
      DO lcell = 1, & 
          numcells

! calculate diameters             
        dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
          one3)

        dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
          one3)

        dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
          **one3)

      END DO
! end loop on diameters                              
      DO lcell = 1, & 
          numcells
! Calculate Knudsen numbers           
        knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)

        knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)

        kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)

      END DO

! end loop for  Knudsen numbers                       
      RETURN

!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    END SUBROUTINE modpar
! modpar                                                  
    SUBROUTINE newt(layer,x,n,check,ctot,csat,imwcv,minitw,its)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed.   !
!bs                                                                    !
!bs  Given an initial guess X(1:N) for a root in N dimensions, find    !
!bs  the root by globally convergent Newton's method. The vector of    !
!bs  functions to be zeroed, called FVEC(1:N) in the routine below. is !
!bs  retuned by a user-supplied function that must be called FUNCV and !
!bs  have the declaration SUBROUTINE FUNCV(NX,FVEC). The output        !
!bs  quantity CHECK is false on a normal return and true if the        !
!bs  routine has converged to a local minimum of the function FMIN     !
!bs  defined below. In this case try restarting from a different       !
!bs  initial guess.                                                    !
!bs                                                                    !
!bs  PARAMETERS                                                        !
!bs  NP     : maximum expected value of N                              !
!bs  MAXITS : maximum number of iterations                             !
!bs  TOLF   : convergence criterion on function values                 !
!bs  TOLMIN : criterion for decidingwhether spurios convergence to a   !
!bs           minimum of FMIN has ocurred                              !
!bs  TOLX   : convergence criterion on delta_X                         !
!bs  STPMX  : scaled maximum step length allowed in line searches      !
!bs                                                                    !
!bs  Called by:       SOA_PART                                         !
!bs                                                                    !
!bs  Calls:           FDJAC                                            !
!bs                   FMIN                                             !
!bs                   LNSRCH                                           !
!bs                   LUBKSB                                           !
!bs                   LUDCMP                                           !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
!bs * includes
!bs
!bs
!bs * input variables
!bs
!bs model layer                           
      INTEGER layer
!bs dimension of problem                  
      INTEGER n
      REAL x(n) !bs initial guess of CAER                 
      LOGICAL check
      REAL ctot(n) !bs total concentration GAS + AER + PROD  
      REAL csat(n) !bs saturation conc. of cond. vapor [ug/m^
      REAL imwcv(n) !bs inverse molecular weights             
!bs
      REAL minitw
!bs * following Numerical recipes
!bs
!bs weighted initial mass                 
      INTEGER nn
!     INTEGER NP
!     PARAMETER (NP = 6)
      REAL fvec(np) !bs
!bs
!bs vector of functions to be zeroed
      REAL ct(np)
      REAL cs(np)
      REAL imw(np)
      REAL m
!bs
      INTEGER i, its, j, indx(np)
      REAL d, den, f, fold, stpmax, sum, temp, test
      REAL fjac(np,np)
      REAL g(np), p(np), xold(np)
!bs
!     EXTERNAL fmin
!bs
!bs * begin code
!bs
      m = minitw
      DO i = 1, n
        ct(i) = ctot(i)
        cs(i) = csat(i)
        imw(i) = imwcv(i)
      END DO
!bs
      nn = n
      f = fmin(x,fvec,nn,ct,cs,imw,m) !The vector FVEC is 
      test = & !Test for initial guess being a root. Us
        0.
      DO i = 1, & !stringent test than simply TOLF.       
          n
        IF (abs(fvec(i))>test) test = abs(fvec(i))
      END DO
      IF (test<0.01*tolf) RETURN
      sum = & !Calculate STPMAX for line searches     
        0.
      DO i = 1, n
        sum = sum + x(i)**2
      END DO
      stpmax = stpmx*max(sqrt(sum),float(n))
      DO its = 1, & !start of iteration loop                
          maxits
        CALL fdjac(n,x,fjac,ct,cs,imw) !get Jacobian              
        DO i = 1, & !compute Delta f for line search        
            n
          sum = 0.
          DO j = 1, n
            sum = sum + fjac(j,i)*fvec(j)
          END DO
          g(i) = sum
        END DO
        DO i = 1, & !store X                                
            n
          xold(i) = x(i)
        END DO
        fold = & !store F                                
          f
        DO i = 1, & !right-hand side for linear equations   
            n
          p(i) = -fvec(i)
        END DO
        CALL ludcmp(fjac,n,np,indx,d,layer) !solve linear equations by LU dec
        CALL lubksb(fjac,n,np,indx,p)
        CALL lnsrch(ctot,n,xold,fold,g, & !LNSRCH returns new X and F. It a
          p,x,f,stpmax, & !calculates FVEC at the new X whe
          check,fmin,fvec,ct,cs,imw,m) !calls FMIN                      
        test = 0.
        DO i = 1, n
          IF (abs(fvec(i))>test) test = abs(fvec(i))
        END DO
        IF (test<tolf) THEN
          check = .FALSE.
          RETURN
        END IF
        IF (check) & !Check for gradient of F zero,          
            THEN
          test = & !i.e., superious convergence.           
            0.
          den = max(f,0.5*n)
          DO i = 1, n
            temp = abs(g(i))*max(abs(x(i)),1.)/den
            IF (temp>test) test = temp
          END DO
          IF (test<tolmin) THEN
            check = .TRUE.
          ELSE
            check = .FALSE.
          END IF
          RETURN
        END IF
        test = & !Test for convergence on delta_x        
          0.
        DO i = 1, n
          temp = (abs(x(i)-xold(i)))/max(abs(x(i)),1.)
          IF (temp>test) test = temp
        END DO
        IF (test<tolx) RETURN
      END DO
!     WRITE (6,'(a,i2)') 'MAXITS exceeded in newt.F ! Layer: ', layer
!bs
    END SUBROUTINE newt
! //////////////////////////////////////////////////////////////////

    SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
        blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
        orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
        fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)
!***********************************************************************
!**    DESCRIPTION:  calculates aerosol nucleation and condensational
!**    growth rates using Binkowski and Shankar (1995) method.

! *** In this version, the method od RPM is followed where
!     the diffusivity, the average molecular ve3locity, and
!     the accomodation coefficient for sulfuric acid are used for
!     the organics. This is for consistency.
!       Future versions will use the correct values.  FSB 12/12/96

!**
!**    Revision history:
!       prototype 1/95 by Uma and Carlie
!       Corrected 7/95 by Uma for condensation of mass not nucleated
!       and mass conservation check
!       Revised   8/95 by US to calculate air density in stmt function
!                 and collect met variable stmt funcs in one include fil
!       Revised 7/25/96 by FSB to use block structure.
!       Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
!       Revised 11/15/96 by FSB to use MKS,  and mom m^-3 units.
!       Revised 1/13/97 by FSB to pass arrays and simplify code.
!       Added   23/03/99 by BS growth factors for organics
!**********************************************************************

!     IMPLICIT NONE

!     Includes:

! *** arguments

! *** input;

! dimension of arrays             
      INTEGER blksize
      INTEGER layer
! number of species in CBLK       
      INTEGER nspcsda
! actual number of cells in arrays
      INTEGER numcells

      INTEGER ldrog
! # of organic aerosol precursor  
      REAL cblk(blksize,nspcsda) ! main array of variables         
! model time step in  SECONDS     
      REAL dt
      REAL blkta(blksize) ! Air temperature [ K ]           
      REAL blkprs(blksize) ! Air pressure in [ Pa ]          
      REAL blkrh(blksize) ! Fractional relative humidity    
      REAL so4rat(blksize)                                       ! rate [  ug/m**3 /s ]
!bs
! sulfate gas-phase production    
! total # of cond. vapors & SOA spe
      INTEGER ncv
!bs
      INTEGER nacv
!bs * anthropogenic organic condensable vapor production rate
! # of anthrop. cond. vapors & SOA 
      REAL drog(blksize,ldrog) !bs
! Delta ROG conc. [ppm]             
      REAL orgaro1rat(blksize)                                 ! production rate from aromatics [ug/m**
! anthropogenic organic aerosol mass    
      REAL orgaro2rat(blksize)                                 ! production rate from aromatics [ug/m**
! anthropogenic organic aerosol mass    
      REAL orgalk1rat(blksize)                                 ! production rate from alkanes & others
! anthropogenic organic aerosol mass    
      REAL orgole1rat(blksize)                                 ! production rate from alkenes & others
!bs * biogenic organic condensable vapor production rate
! anthropogenic organic aerosol mass    
      REAL orgbio1rat(blksize)                                 ! rate [  ug/m**3 /s ]
! biogenic organic aerosol production   
      REAL orgbio2rat(blksize)                                 ! rate [  ug/m**3 /s ]
! biogenic organic aerosol production   
      REAL orgbio3rat(blksize)                                 ! rate [  ug/m**3 /s ]
! biogenic organic aerosol production   
      REAL orgbio4rat(blksize)                                 ! rate [  ug/m**3 /s ]
!bs
! biogenic organic aerosol production   
      REAL dgnuc(blksize) ! accumulation                          
      REAL dgacc(blksize) 
! *** output:

! coarse mode                           
      REAL fconcn(blksize)                                 ! Aitken mode  [ 1 / s ]
! reciprocal condensation rate          
      REAL fconca(blksize)                                 ! acclumulation mode [ 1 / s ]
! reciprocal condensation rate          
      REAL fconcn_org(blksize)                                 ! Aitken mode  [ 1 / s ]
! reciprocal condensation rate          
      REAL fconca_org(blksize)                                 ! acclumulation mode [ 1 / s ]
! reciprocal condensation rate          
      REAL dmdt(blksize)                                 ! by particle formation [ ug/m**3 /s ]
! rate of production of new mass concent
      REAL dndt(blksize)                                 ! concentration by particle formation [#
! rate of producton of new particle numb
      REAL deltaso4a(blksize)                                 ! sulfate aerosol by condensation [ ug/m
! increment of concentration added to   
      REAL cgrn3(blksize)                                 ! Aitken mode [ 3rd mom/m **3 s ]
! growth rate for 3rd moment for        
      REAL cgra3(blksize)                                 ! Accumulation mode   

!...........    SCRATCH local variables and their descriptions:

! growth rate for 3rd moment for        

      INTEGER lcell

! LOOP INDEX                                     
! conv rate so2 --> so4 [mom-3/g/s]     
      REAL chemrat
! conv rate for organics [mom-3/g/s]    
      REAL chemrat_org
      REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
        am1a
      REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
        am2a
      REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
        gnc3a
      REAL gfm3n, & ! free-mol  fns (nuc, acc) for mom-3 den
        gfm3a
! total reciprocal condensation rate    
      REAL fconc

      REAL td
! d * tinf (cgs)                        
      REAL*8 & ! Cnstant to force 64 bit evaluation of 
        one88
      PARAMETER (one88=1.0D0)
!  *** variables to set up sulfate and organic condensation rates

! sulfuric acid vapor at current time step            
      REAL vapor1
!                                    chemistry and emissions
      REAL vapor2
! Sulfuric acid vapor prior to addition from          
!bs
      REAL deltavap
!bs * start update
!bs
! change to vapor at previous time step 
      REAL diffcorr

!bs *
      REAL csqt_org
!bs * end update
!bs

      REAL csqt
!.......................................................................
!   begin body of subroutine  NUCLCOND

!...........   Main computational grid-traversal loop nest
!...........   for computing condensation and nucleation:

      DO lcell = 1, & 
          numcells
! *** First moment:

!  1st loop over NUMCELLS                  
        am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
        am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04

!..............   near-continuum factors [ 1 / sec ]
!bs
!bs * adopted from code of FSB
!bs * correction to DIFFSULF and DIFFORG for temperature and pressure
!bs
        diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
!bs
        gnc3n = cconc*am1n*diffcorr
        gnc3a = cconc*am1a*diffcorr

! *** Second moment:

        am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
        am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16

        csqt = ccofm*sqrt(blkta(lcell)) 
!...............   free molecular factors [ 1 / sec ]

! put in temperature fac
        gfm3n = csqt*am2n
        gfm3a = csqt*am2a

! *** Condensation factors in [ s**-1] for h2so4
! *** In the future, separate factors for condensing organics will
!      be included. In this version, the h2so4 values are used.

!...............   Twice the harmonic mean of fm, nc functions:

! *** Force 64 bit evaluation:

        fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
        fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
        fconc = fconcn(lcell) + fconca(lcell)

! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
!bs
!bs * start modifications for organcis
!bs
        gnc3n = cconc_org*am1n*diffcorr
        gnc3a = cconc_org*am1a*diffcorr
!bs
        csqt_org = ccofm_org*sqrt(blkta(lcell))
        gfm3n = csqt_org*am2n
        gfm3a = csqt_org*am2a
!bs
        fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
        fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
!bs
!bs * end modifications for organics
!bs
! *** calculate the total change to sulfuric acid vapor from production
!                      and condensation

        vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor        
        vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* & 
          dt
! vapor at prev
        vapor2 = max(0.0,vapor2)

        deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))

! *** Calculate increment in total sufate aerosol mass concentration

! *** This follows the method of Youngblood & Kreidenweis.

!bs
!bs        DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
!bs
!bs * allow DELTASO4A to be negative, but the change must not be larger
!bs * than the amount of vapor available.
!bs
        deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
          so4rat(lcell)*dt-deltavap)
!bs

! *** zero out growth coefficients

        cgrn3(lcell) = 0.0
        cgra3(lcell) = 0.0

      END DO

! *** Select method of nucleation

! End 1st loop over NUMCELLS            
      IF (inucl==1) THEN

! *** Do Youngblood & Kreidenweis  Nucleation

!         CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
!     &        DNDT,DMDT,NUMCELLS,BLKSIZE,
!     &        VAPOR1)
!       IF (firstime) THEN
!         WRITE (6,*)
!         WRITE (6,'(a,i2)') 'INUCL =', inucl
!         WRITE (90,'(a,i2)') 'INUCL =', inucl
!         firstime = .FALSE.
!       END IF

      ELSE IF (inucl==0) THEN

! *** Do Kerminen & Wexler Nucleation

!         CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
!     &        DNDT,DMDT,NUMCELLS,BLKSIZE)
!       IF (firstime) THEN
!         WRITE (6,*)
!         WRITE (6,'(a,i2)') 'INUCL =', inucl
!         WRITE (90,'(a,i2)') 'INUCL =', inucl
!         firstime = .FALSE.
!       END IF

      ELSE IF (inucl==2) THEN

!bs ** Do Kulmala et al. Nucleation
!       if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)

        if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
           CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
        else
           dndt(1)=0.
           dmdt(1)=0.
        endif

!       CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
        if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
        IF (dndt(1)==0.) dmdt(1) = 0.
        IF (dmdt(1)==0.) dndt(1) = 0.
!       IF (firstime) THEN
!         WRITE (6,*)
!         WRITE (6,'(a,i2)') 'INUCL =', inucl
!         WRITE (90,'(a,i2)') 'INUCL =', inucl
!         firstime = .FALSE.
!       END IF
!     ELSE
!       WRITE (6,'(a)') '*************************************'
!       WRITE (6,'(a,i2,a)') '  INUCL =', inucl, ',  PLEASE CHECK !!'
!       WRITE (6,'(a)') '        PROGRAM TERMINATED !!'
!       WRITE (6,'(a)') '*************************************'
!       STOP

      END IF
!bs
!bs * Secondary organic aerosol module (SORGAM)
!bs
! end of selection of nucleation method 
      CALL sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
        orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
        nacv,cblk,blksize,nspcsda,numcells,dt)
!bs
!bs *  Secondary organic aerosol module (SORGAM)
!bs

      DO lcell = 1, numcells

! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
!     condensation factors

        td = 1.0/(fconcn(lcell)+fconca(lcell))
        fconcn(lcell) = td*fconcn(lcell)
        fconca(lcell) = td*fconca(lcell)
!bs
        td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
        fconcn_org(lcell) = td*fconcn_org(lcell)
        fconca_org(lcell) = td*fconca_org(lcell)
!bs
      END DO

! ***  Begin second loop over cells

      DO lcell = 1, & 
          numcells
! *** note CHEMRAT includes  species other than sulfate.

! 3rd loop on NUMCELLS                     
        chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
        chemrat_org = orgfac*(orgaro1rat(lcell)+orgaro2rat(lcell)+orgalk1rat( &
          lcell)+orgole1rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
          orgbio3rat(lcell)+orgbio4rat(lcell)) 
! *** Calculate the production rates for new particle

! [mom3 m**-3 s-
        cgrn3(lcell) = so4fac*dmdt(lcell) 
! Rate of increase of 3rd
        chemrat = chemrat - cgrn3(lcell)                                            !bs 3rd moment production fro

!bs Remove the rate of new pa
        chemrat = max(chemrat,0.0) 
! *** Now calculate the rate of condensation on existing particles.

! Prevent CHEMRAT from being negativ
        cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
          chemrat_org*fconcn_org(lcell)

        cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)

! ***

      END DO
!  end 2nd loop over NUMCELLS           
      RETURN

    END SUBROUTINE nuclcond
!23456789012345678901234567890123456789012345678901234567890123456789012

! nuclcond                              
    REAL FUNCTION poly4(a,x)
      REAL a(4), x

      poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
      RETURN
    END FUNCTION poly4
    REAL FUNCTION poly6(a,x)
      REAL a(6), x

      poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
      RETURN
    END FUNCTION poly6

!-----------------------------------------------------------------------

    SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
        gnh3,gno3)

!-----------------------------------------------------------------------

! Description:

!   ARES calculates the chemical composition of a sulfate/nitrate/
!   ammonium/water aerosol based on equilibrium thermodynamics.

!   This code considers two regimes depending upon the molar ratio
!   of ammonium to sulfate.

!   For values of this ratio less than 2,the code solves a cubic for
!   hydrogen ion molality, HPLUS,  and if enough ammonium and liquid
!   water are present calculates the dissolved nitric acid. For molal
!   ionic strengths greater than 50, nitrate is assumed not to be presen

!   For values of the molar ratio of 2 or greater, all sulfate is assume
!   to be ammonium sulfate and a calculation is made for the presence of
!   ammonium nitrate.

!   The Pitzer multicomponent approach is used in subroutine ACTCOF to
!   obtain the activity coefficients. Abandoned -7/30/97 FSB

!   The Bromley method of calculating the activity coefficients is s use
!    in this version

!   The calculation of liquid water
!   is done in subroutine water. Details for both calculations are given
!   in the respective subroutines.

!   Based upon MARS due to
!   P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
!   Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.

!   and SCAPE due to
!   Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
!   Vol 19, number 2, pages 157-181 and pages 182-198, 1993.

! NOTE: All concentrations supplied to this subroutine are TOTAL
!       over gas and aerosol phases

! Parameters:

!  SO4   : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
!  HNO3  : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
!  NO3   : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
!  NH3   : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
!  NH4   : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
!  RH    : Fractional relative humidity (IN)
!  TEMP  : Temperature in Kelvin (IN)
!  GNO3  : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
!  GNH3  : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
!  ASO4  : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
!  ANO3  : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
!  ANH4  : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
!  AH2O  : Aerosol phase water in MICROGRAMS/M**3 (OUT)
!  NITR  : Number of iterations for obtaining activity coefficients  (OU
!  NR    : Number of real roots to the cubic in the low ammonia case (OU

! Revision History:
!      Who       When        Detailed description of changes
!   ---------   --------  -------------------------------------------
!   S.Roselle   11/10/87  Received the first version of the MARS code
!   S.Roselle   12/30/87  Restructured code
!   S.Roselle   2/12/88   Made correction to compute liquid-phase
!                         concentration of H2O2.
!   S.Roselle   5/26/88   Made correction as advised by SAI, for
!                         computing H+ concentration.
!   S.Roselle   3/1/89    Modified to operate with EM2
!   S.Roselle   5/19/89   Changed the maximum ionic strength from
!                         100 to 20, for numerical stability.
!   F.Binkowski 3/3/91    Incorporate new method for ammonia rich case
!                         using equations for nitrate budget.
!   F.Binkowski 6/18/91   New ammonia poor case which
!                         omits letovicite.
!   F.Binkowski 7/25/91   Rearranged entire code, restructured
!                         ammonia poor case.
!   F.Binkowski 9/9/91    Reconciled all cases of ASO4 to be output
!                         as SO4--
!   F.Binkowski 12/6/91   Changed the ammonia defficient case so that
!                         there is only neutralized sulfate (ammonium
!                         sulfate) and sulfuric acid.
!   F.Binkowski 3/5/92    Set RH bound on AWAS to 37 % to be in agreemen
!                          with the Cohen et al. (1987)  maximum molalit
!                          of 36.2 in Table III.( J. Phys Chem (91) page
!                          4569, and Table IV p 4587.)
!   F.Binkowski 3/9/92    Redid logic for ammonia defficient case to rem
!                         possibility for denomenator becoming zero;
!                         this involved solving for HPLUS first.
!                         Note that for a relative humidity
!                          less than 50%, the model assumes that there i
!                          aerosol nitrate.
!   F.Binkowski 4/17/95   Code renamed  ARES (AeRosol Equilibrium System
!                          Redid logic as follows
!                         1. Water algorithm now follows Spann & Richard
!                         2. Pitzer Multicomponent method used
!                         3. Multicomponent practical osmotic coefficien
!                            use to close iterations.
!                         4. The model now assumes that for a water
!                            mass fraction WFRAC less than 50% there is
!                            no aerosol nitrate.
!   F.Binkowski 7/20/95   Changed how nitrate is calculated in ammonia p
!                         case, and changed the WFRAC criterion to 40%.
!                         For ammonium to sulfate ratio less than 1.0
!                         all ammonium is aerosol and no nitrate aerosol
!                         exists.
!   F.Binkowski 7/21/95   Changed ammonia-ammonium in ammonia poor case
!                         allow gas-phase ammonia to exist.
!   F.Binkowski 7/26/95   Changed equilibrium constants to values from
!                         Kim et al. (1993)
!   F.Binkowski 6/27/96   Changed to new water format
!   F.Binkowski 7/30/97   Changed to Bromley method for multicomponent
!                         activity coefficients. The binary activity coe
!                         are the same as the previous version
!   F.Binkowski 8/1/97    Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
!                         1 picogram per cubic meter

!-----------------------------------------------------------------------

!     IMPLICIT NONE

!...........INCLUDES and their descriptions

!cc      INCLUDE SUBST_CONST          ! constants

!...........PARAMETERS and their descriptions:

! molecular weight for NaCl          
      REAL mwnacl
      PARAMETER (mwnacl=58.44277)

! molecular weight for NO3           
      REAL mwno3
      PARAMETER (mwno3=62.0049)

! molecular weight for HNO3          
      REAL mwhno3
      PARAMETER (mwhno3=63.01287)

! molecular weight for SO4           
      REAL mwso4
      PARAMETER (mwso4=96.0576)

! molecular weight for HSO4          
      REAL mwhso4
      PARAMETER (mwhso4=mwso4+1.0080)

! molecular weight for H2SO4         
      REAL mh2so4
      PARAMETER (mh2so4=98.07354)

! molecular weight for NH3           
      REAL mwnh3
      PARAMETER (mwnh3=17.03061)

! molecular weight for NH4           
      REAL mwnh4
      PARAMETER (mwnh4=18.03858)

! molecular weight for Organic Specie
      REAL mworg
      PARAMETER (mworg=16.0)

! molecular weight for Chloride      
      REAL mwcl
      PARAMETER (mwcl=35.453)

! molecular weight for AIR           
      REAL mwair
      PARAMETER (mwair=28.964)

! molecular weight for Letovicite    
      REAL mwlct
      PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)

! molecular weight for Ammonium Sulfa
      REAL mwas
      PARAMETER (mwas=2.0*mwnh4+mwso4)

! molecular weight for Ammonium Bisul
      REAL mwabs
      PARAMETER (mwabs=mwnh4+mwso4+1.0080)

!...........ARGUMENTS and their descriptions

!iamodels3
      REAL so4
! Total sulfate in micrograms / m**3 
! Total nitric acid in micrograms / m
      REAL hno3
! Total nitrate in micrograms / m**3 
      REAL no3
! Total ammonia in micrograms / m**3 
      REAL nh3
! Total ammonium in micrograms / m**3
      REAL nh4
! Fractional relative humidity       
      REAL rh
! Temperature in Kelvin              
      REAL temp
! Aerosol sulfate in micrograms / m**
      REAL aso4
! Aerosol nitrate in micrograms / m**
      REAL ano3
! Aerosol liquid water content water 
      REAL ah2o
! Aerosol ammonium in micrograms / m*
      REAL anh4
! Gas-phase nitric acid in micrograms
      REAL gno3

      REAL gnh3
!...........SCRATCH LOCAL VARIABLES and their descriptions:

! Gas-phase ammonia in micrograms / m
! Index set to percent relative humid
      INTEGER irh
! Number of iterations for activity c
      INTEGER nitr
! Loop index for iterations          
      INTEGER nnn

      INTEGER nr
! Number of roots to cubic equation f
      REAL*8 & ! Coefficients and roots of        
        a0
      REAL*8 & ! Coefficients and roots of        
        a1
      REAL*8 & ! Coefficients and roots of        
        a2
! Coefficients and discriminant for q
      REAL aa
! internal variables ( high ammonia c
      REAL bal
! Coefficients and discriminant for q
      REAL bb
! Variables used for ammonia solubili
      REAL bhat
! Coefficients and discriminant for q
      REAL cc
! Factor for conversion of units     
      REAL convt
! Coefficients and discriminant for q
      REAL dd
! Coefficients and discriminant for q
      REAL disc
! Relative error used for convergence
      REAL eror
!  Free ammonia concentration , that 
      REAL fnh3
! Activity Coefficient for (NH4+, HSO
      REAL gamaab
! Activity coefficient for (NH4+, NO3
      REAL gamaan
! Variables used for ammonia solubili
      REAL gamahat
! Activity coefficient for (H+ ,NO3-)
      REAL gamana
! Activity coefficient for (2H+, SO4-
      REAL gamas1
! Activity coefficient for (H+, HSO4-
      REAL gamas2
! used for convergence of iteration  
      REAL gamold
! internal variables ( high ammonia c
      REAL gasqd
! Hydrogen ion (low ammonia case) (mo
      REAL hplus
! Equilibrium constant for ammoniua t
      REAL k1a
! Equilibrium constant for sulfate-bi
      REAL k2sa
! Dissociation constant for ammonium 
      REAL k3
! Equilibrium constant for ammonium n
      REAL kan
! Variables used for ammonia solubili
      REAL khat
! Equilibrium constant for nitric aci
      REAL kna
! Henry's Law Constant for ammonia   
      REAL kph
! Equilibrium constant for water diss
      REAL kw
! Internal variable using KAN        
      REAL kw2
! Nitrate (high ammonia case) (moles 
      REAL man
! Sulfate (high ammonia case) (moles 
      REAL mas
! Bisulfate (low ammonia case) (moles
      REAL mhso4
! Nitrate (low ammonia case) (moles /
      REAL mna
! Ammonium (moles / kg water)        
      REAL mnh4
! Total number of moles of all ions  
      REAL molnu
! Sulfate (low ammonia case) (moles /
      REAL mso4
! Practical osmotic coefficient      
      REAL phibar
! Previous value of practical osmotic
      REAL phiold
! Molar ratio of ammonium to sulfate 
      REAL ratio
! Internal variable using K2SA       
      REAL rk2sa
! Internal variables using KNA       
      REAL rkna
! Internal variables using KNA       
      REAL rknwet
      REAL rr1
      REAL rr2
! Ionic strength                     
      REAL stion
! Internal variables for temperature 
      REAL t1
! Internal variables for temperature 
      REAL t2
! Internal variables of convenience (
      REAL t21
! Internal variables of convenience (
      REAL t221
! Internal variables for temperature 
      REAL t3
! Internal variables for temperature 
      REAL t4
! Internal variables for temperature 
      REAL t6
! Total ammonia and ammonium in micro
      REAL tnh4
! Total nitrate in micromoles / meter
      REAL tno3
! Tolerances for convergence test    
      REAL toler1
! Tolerances for convergence test    
      REAL toler2
! Total sulfate in micromoles / meter
      REAL tso4
! 2.0 * TSO4  (high ammonia case) (mo
      REAL twoso4
! Water mass fraction                
      REAL wfrac
                                   ! micrograms / meter **3 on output
      REAL wh2o
                                   ! internally it is 10 ** (-6) kg (wat
                                   ! the conversion factor (1000 g = 1 k
                                   ! for AH2O output
! Aerosol liquid water content (inter
! internal variables ( high ammonia c
      REAL wsqd
! Nitrate aerosol concentration in mi
      REAL xno3
! Variable used in quadratic solution
      REAL xxq
! Ammonium aerosol concentration in m
      REAL ynh4
! Water variable saved in case ionic 
      REAL zh2o

      REAL zso4
! Total sulfate molality - mso4 + mhs
      REAL cat(2) ! Array for cations (1, H+); (2, NH4+
      REAL an(3) ! Array for anions (1, SO4--); (2, NO
      REAL crutes(3) ! Coefficients and roots of          
      REAL gams(2,3) ! Array of activity coefficients     
! Minimum value of sulfate laerosol c
      REAL minso4
      PARAMETER (minso4=1.0E-6/mwso4)
      REAL floor
      PARAMETER (floor=1.0E-30) 
!-----------------------------------------------------------------------
!  begin body of subroutine RPMARES

!...convert into micromoles/m**3
!cc      WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
!iamodels3 merge NH3/NH4 , HNO3,NO3 here
! minimum concentration              
      tso4 = max(0.0,so4/mwso4)
      tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
      tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
!cc      WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH

!...now set humidity index IRH as a percent

      irh = nint(100.0*rh)

!...Check for valid IRH

      irh = max(1,irh)
      irh = min(99,irh)
!cc      WRITE(10,*)'RH,IRH ',RH,IRH

!...Specify the equilibrium constants at  correct
!...  temperature.  Also change units from ATM to MICROMOLE/M**3 (for KA
!...  KPH, and K3 )
!...  Values from Kim et al. (1993) except as noted.

      convt = 1.0/(0.082*temp)
      t6 = 0.082E-9*temp
      t1 = 298.0/temp
      t2 = alog(t1)
      t3 = t1 - 1.0
      t4 = 1.0 + t2 - t1
      kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
      k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
      k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
      kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
      kph = 57.639*exp(13.79*t3-5.39*t4)*t6
!cc      K3   =  5.746E-17 * EXP( -74.38 * T3 + 6.12  * T4 ) * T6 * T6
      khat = kph*k1a/kw
      kan = kna*khat

!...Compute temperature dependent equilibrium constant for NH4NO3
!...  ( from Mozurkewich, 1993)

      k3 = exp(118.87-24084.0/temp-6.025*alog(temp))

!...Convert to (micromoles/m**3) **2

      k3 = k3*convt*convt

      wh2o = 0.0
      stion = 0.0
      ah2o = 0.0
      mas = 0.0
      man = 0.0
      hplus = 0.0
      toler1 = 0.00001
      toler2 = 0.001
      nitr = 0
      nr = 0
      ratio = 0.0
      gamaan = 1.0
      gamold = 1.0

!...set the ratio according to the amount of sulfate and nitrate
      IF (tso4>minso4) THEN
        ratio = tnh4/tso4

!...If there is no sulfate and no nitrate, there can be no ammonium
!...  under the current paradigm. Organics are ignored in this version.

      ELSE

        IF (tno3==0.0) THEN

! *** If there is very little sulfate and no nitrate set concentrations
!      to a very small value and return.
          aso4 = max(floor,aso4)
          ano3 = max(floor,ano3)
          wh2o = 0.0
          ah2o = 0.0
          gnh3 = max(floor,gnh3)
          gno3 = max(floor,gno3)
          RETURN
        END IF

!...For the case of no sulfate and nonzero nitrate, set ratio to 5
!...  to send the code to the high ammonia case

        ratio = 5.0
      END IF

!....................................
!......... High Ammonia Case ........
!....................................

      IF (ratio>2.0) THEN

        gamaan = 0.1

!...Set up twice the sulfate for future use.

        twoso4 = 2.0*tso4
        xno3 = 0.0
        ynh4 = twoso4

!...Treat different regimes of relative humidity

!...ZSR relationship is used to set water levels. Units are
!...  10**(-6) kg water/ (cubic meter of air)
!...  start with ammomium sulfate solution without nitrate

        CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3              
        wh2o = 1.0E-3*ah2o
        aso4 = tso4*mwso4
        ano3 = 0.0
        anh4 = ynh4*mwnh4
        wfrac = ah2o/(aso4+anh4+ah2o)
!cc        IF ( WFRAC .EQ. 0.0 )  RETURN   ! No water
        IF (wfrac<0.2) THEN

!... dry  ammonium sulfate and ammonium nitrate
!...  compute free ammonia

          fnh3 = tnh4 - twoso4
          cc = tno3*fnh3 - k3

!...check for not enough to support aerosol

          IF (cc<=0.0) THEN
            xno3 = 0.0
          ELSE
            aa = 1.0
            bb = -(tno3+fnh3)
            disc = bb*bb - 4.0*cc

!...Check for complex roots of the quadratic
!...  set nitrate to zero and RETURN if complex roots are found

            IF (disc<0.0) THEN
              xno3 = 0.0
              ah2o = 1000.0*wh2o
              ynh4 = twoso4
              gno3 = tno3*mwhno3
              gnh3 = (tnh4-ynh4)*mwnh3
              aso4 = tso4*mwso4
              ano3 = 0.0
              anh4 = ynh4*mwnh4
              RETURN
            END IF

!...to get here, BB .lt. 0.0, CC .gt. 0.0 always

            dd = sqrt(disc)
            xxq = -0.5*(bb+sign(1.0,bb)*dd)

!...Since both roots are positive, select smaller root.

            xno3 = min(xxq/aa,cc/xxq)

          END IF
          ah2o = 1000.0*wh2o
          ynh4 = 2.0*tso4 + xno3
          gno3 = (tno3-xno3)*mwhno3
          gnh3 = (tnh4-ynh4)*mwnh3
          aso4 = tso4*mwso4
          ano3 = xno3*mwno3
          anh4 = ynh4*mwnh4
          RETURN

        END IF

!...liquid phase containing completely neutralized sulfate and
!...  some nitrate.  Solve for composition and quantity.

        mas = tso4/wh2o
        man = 0.0
        xno3 = 0.0
        ynh4 = twoso4
        phiold = 1.0

!...Start loop for iteration

!...The assumption here is that all sulfate is ammonium sulfate,
!...  and is supersaturated at lower relative humidities.

        DO nnn = 1, 150
          nitr = nnn
          gasqd = gamaan*gamaan
          wsqd = wh2o*wh2o
          kw2 = kan*wsqd/gasqd
          aa = 1.0 - kw2
          bb = twoso4 + kw2*(tno3+tnh4-twoso4)
          cc = -kw2*tno3*(tnh4-twoso4)

!...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut

          disc = bb*bb - 4.0*aa*cc

!...Check for complex roots, if so set nitrate to zero and RETURN

          IF (disc<0.0) THEN
            xno3 = 0.0
            ah2o = 1000.0*wh2o
            ynh4 = twoso4
            gno3 = tno3*mwhno3
            gnh3 = (tnh4-ynh4)*mwnh3
            aso4 = tso4*mwso4
            ano3 = 0.0
            anh4 = ynh4*mwnh4
!cc            WRITE( 10, * ) ' COMPLEX ROOTS '
            RETURN
          END IF

          dd = sqrt(disc)
          xxq = -0.5*(bb+sign(1.0,bb)*dd)
          rr1 = xxq/aa
          rr2 = cc/xxq

!...choose minimum positve root

          IF ((rr1*rr2)<0.0) THEN
            xno3 = max(rr1,rr2)
          ELSE
            xno3 = min(rr1,rr2)
          END IF

          xno3 = min(xno3,tno3)

!...This version assumes no solid sulfate forms (supersaturated )
!...  Now update water

          CALL awater(irh,tso4,ynh4,xno3,ah2o)

!...ZSR relationship is used to set water levels. Units are
!...  10**(-6) kg water/ (cubic meter of air)
!...  The conversion from micromoles to moles is done by the units of WH

          wh2o = 1.0E-3*ah2o

!...Ionic balance determines the ammonium in solution.

          man = xno3/wh2o
          mas = tso4/wh2o
          mnh4 = 2.0*mas + man
          ynh4 = mnh4*wh2o

!...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
!...  and ammonium in molal units (moles/(kg water) ).

          stion = 3.0*mas + man
          cat(1) = 0.0
          cat(2) = mnh4
          an(1) = mas
          an(2) = man
          an(3) = 0.0
          CALL actcof(cat,an,gams,molnu,phibar)
          gamaan = gams(2,2)

!...Use GAMAAN for convergence control

          eror = abs(gamold-gamaan)/gamold
          gamold = gamaan

!...Check to see if we have a solution

          IF (eror<=toler1) THEN
!cc            WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
!cc     &      GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR

            aso4 = tso4*mwso4
            ano3 = xno3*mwno3
            anh4 = ynh4*mwnh4
            gno3 = (tno3-xno3)*mwhno3
            gnh3 = (tnh4-ynh4)*mwnh3
            ah2o = 1000.0*wh2o
            RETURN
          END IF

        END DO

!...If after NITR iterations no solution is found, then:

        aso4 = tso4*mwso4
        ano3 = 0.0
        ynh4 = twoso4
        anh4 = ynh4*mwnh4
        CALL awater(irh,tso4,ynh4,xno3,ah2o)
        gno3 = tno3*mwhno3
        gnh3 = (tnh4-ynh4)*mwnh3
        RETURN

      ELSE

!......................................
!......... Low Ammonia Case ...........
!......................................

!...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)

!...All cases covered by this logic
        wh2o = 0.0
        CALL awater(irh,tso4,tnh4,tno3,ah2o)
        wh2o = 1.0E-3*ah2o
        zh2o = ah2o
!...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
!...  per cubic meter of air (1000 g = 1 kg)

        aso4 = tso4*mwso4
        anh4 = tnh4*mwnh4
        ano3 = 0.0
        gno3 = tno3*mwhno3
        gnh3 = 0.0

!...Check for zero water.

        IF (wh2o==0.0) RETURN
        zso4 = tso4/wh2o

!...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4

!cc         IF ( ZSO4 .GT. 11.0 ) THEN

!...do not solve for aerosol nitrate for total sulfate molality
!...  greater than 11.0 because the model parameters break down
!...  greater than  9.0 because the model parameters break down

        IF (zso4>9.0) & ! 18 June 97                        
            THEN
          RETURN
        END IF

!...First solve with activity coeffs of 1.0, then iterate.

        phiold = 1.0
        gamana = 1.0
        gamas1 = 1.0
        gamas2 = 1.0
        gamaab = 1.0
        gamold = 1.0

!...All ammonia is considered to be aerosol ammonium.

        mnh4 = tnh4/wh2o

!...MNH4 is the molality of ammonium ion.

        ynh4 = tnh4
!...loop for iteration

        DO nnn = 1, 150
          nitr = nnn

!...set up equilibrium constants including activities
!...  solve the system for hplus first then sulfate & nitrate
!          print*,'gamas,gamana',gamas1,gamas2,gamana
          rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
          rkna = kna/(gamana*gamana)
          rknwet = rkna*wh2o
          t21 = zso4 - mnh4
          t221 = zso4 + t21

!...set up coefficients for cubic

          a2 = rk2sa + rknwet - t21
          a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
          a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)

          CALL cubic(a2,a1,a0,nr,crutes)

!...Code assumes the smallest positive root is in CRUTES(1)

          hplus = crutes(1)
          bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
          mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
          mhso4 = zso4 - & ! molality of bisulf
            mso4
          mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
          mna = max(0.0,mna)
          mna = min(mna,tno3/wh2o)
          xno3 = mna*wh2o
          ano3 = mna*wh2o*mwno3
          gno3 = (tno3-xno3)*mwhno3
!...Calculate ionic strength

          stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)

!...Update water

          CALL awater(irh,tso4,ynh4,xno3,ah2o)

!...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
!...  per cubic meter of air (1000 g = 1 kg)

          wh2o = 1.0E-3*ah2o
          cat(1) = hplus
          cat(2) = mnh4
          an(1) = mso4
          an(2) = mna
          an(3) = mhso4
!          print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
          CALL actcof(cat,an,gams,molnu,phibar)

          gamana = gams(1,2)
          gamas1 = gams(1,1)
          gamas2 = gams(1,3)
          gamaan = gams(2,2)

          gamahat = (gamas2*gamas2/(gamaab*gamaab))
          bhat = khat*gamahat
!cc          EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
!cc          PHIOLD = PHIBAR
          eror = abs(gamold-gamahat)/gamold
          gamold = gamahat

!...write out molalities and activity coefficient
!...  and return with good solution

          IF (eror<=toler2) THEN
!cc            WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
!cc            WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
!cc     &                  GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
            RETURN
          END IF

        END DO

!...after NITR iterations, failure to solve the system, no ANO3

        gno3 = tno3*mwhno3
        ano3 = 0.0
        CALL awater(irh,tso4,tnh4,tno3,ah2o)
        RETURN

      END IF
! ratio .gt. 2.0                                         
! ///////////////////////////////////////////////////
    END SUBROUTINE rpmares_old
!ia*********************************************************
!ia                                                        *
!ia BEGIN OF AEROSOL ROUTINE				   *
!ia							   *
!ia*********************************************************

!***********************************************************************

!   	BEGIN OF AEROSOL CALCULATIONS

!***********************************************************************

!ia*********************************************************************
!ia  									*
!ia	MAIN AEROSOL DYNAMICS ROUTINE					*
!ia	based on MODELS3 formulation by FZB				*
!ia	Modified by IA in May 97					*
!ia     THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
!ia     CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
!ia     VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
!ia     CALCULATIONS.
!ia     INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
!ia     ONE GRID CELL!!!!
!ia     and passed to dynamics calcs. subroutines.
!ia									*
!ia	Revision history						*
!ia	When	WHO	WHAT						*
!ia	----	----	----						*
!ia	????	FZB	BEGIN						*
!ia	05/97	IA	Adapted for use in CTM2-S			*
!ia			Modified renaming/bug fixing			*
!ia     11/97   IA      Modified for new model version
!ia                     see comments under iarev02
!ia     03/98   IA      corrected error on pressure units
!ia									*
!ia	Called BY:	CHEM						*
!ia									*
!ia	Calls to:	OUTPUT1,AEROPRC					*
!ia									*
!ia*********************************************************************

! end RPMares                                                 
    SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
        nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv, &
        nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,    &
        soilrat_in,cblk,igrid,jgrid,kgrid)

!     IMPLICIT NONE

!     Includes:

!iarev02       INCLUDE  AEROINCL.EXT 
! block size, set to 1 in column model  ciarev0
      INTEGER blksize
!ia   			  kept to 1 in current version of column model
      INTEGER numcells

! actual number of cells in arrays ( default is 
      PARAMETER (numcells=1)

      INTEGER layer
! number of layer (default is 1 in

      INTEGER ncell
! index for cell in blocked array (default is 1 in
      PARAMETER (ncell=1)
! *** inputs
! Input temperature [ K ]                      
      REAL temp
! Input relative humidity  [ fraction ]        
      REAL relhum
! Input pressure [ hPa ]                       
      REAL pres
! Input number for Aitken mode [ m**-3 ]       
      REAL numnuc_in
! Input number for accumulation mode [ m**-3 ] 
      REAL numacc_in
! Input number for coarse mode  [ m**-3 ]      
      REAL numcor_in
                         ! sulfuric acid [ ug m**-3 ]
      REAL vsulf_in
! total sulfate vapor as sulfuric acid as      
                         ! sulfuric acid [ ug m**-3 ]
      REAL asulf_in
! total sulfate aerosol as sulfuric acid as    
! i-mode sulfate input as sulfuric acid [ ug m*
      REAL asulfi_in
! ammonia gas [  ug m**-3 ]                    
      REAL nh3_in
! input value of nitric acid vapor [ ug m**-3 ]
      REAL nitrate_in
! Production rate of sulfuric acid   [ ug m**-3
      REAL so4rat_in
                         ! aerosol [ ug m**-3 s**-1 ]
      REAL soilrat_in
! Production rate of soil derived coarse       
! Emission rate of i-mode EC [ug m**-3 s**-1]  
      REAL eeci_in
! Emission rate of j-mode EC [ug m**-3 s**-1]  
      REAL eecj_in
! Emission rate of j-mode org. aerosol [ug m**-
      REAL eorgi_in

      REAL eorgj_in
!bs
! Emission rate of j-mode org. aerosol [ug m**-
! total # of cond. vapors & SOA species 
      INTEGER ncv
! # of anthrop. cond. vapors & SOA speci
      INTEGER nacv
! # of organic aerosol precursor        
      INTEGER ldrog
      REAL drog_in(ldrog)                                 ! organic aerosol precursor [ppm]
! Input delta ROG concentration of      
      REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]           
      REAL drog(blksize,ldrog)                                 ! organic aerosol precursor [ppm]
!bs
! *** Primary emissions rates: [ ug / m**3 s ]

! *** emissions rates for unidentified PM2.5 mass
! Delta ROG concentration of            
      REAL epm25i(blksize) ! Aitken mode                         
      REAL epm25j(blksize) 
! *** emissions rates for primary organic aerosol
! Accumululaton mode                  
      REAL eorgi(blksize) ! Aitken mode                          
      REAL eorgj(blksize) 
! *** emissions rates for elemental carbon
! Accumululaton mode                   
      REAL eeci(blksize) ! Aitken mode                           
      REAL eecj(blksize) 
! *** Primary emissions rates [ ug m**-3 s -1 ] :

! Accumululaton mode                    
      REAL epm25(blksize) ! emissions rate for PM2.5 mass           
      REAL esoil(blksize) ! emissions rate for soil derived coarse a
      REAL eseas(blksize) ! emissions rate for marine coarse aerosol
      REAL epmcoarse(blksize) 
! emissions rate for anthropogenic coarse 

      REAL dtsec

! time step [ s ], PASSED FROM MAIN COLUMN MODE

      REAL newm3

      REAL totaersulf
! total aerosol sulfate                   
! loop index for time steps                     
      INTEGER numsteps

      REAL step

! *** arrays for aerosol model codes:

! synchronization time  [s]                     

      INTEGER nspcsda

! number of species in CBLK ciarev02           
      REAL cblk(blksize,nspcsda) 

! *** Meteorological information in blocked arays:

! *** Thermodynamic variables:

! main array of variables            
      REAL blkta(blksize) ! Air temperature [ K ]                     
      REAL blkprs(blksize) ! Air pressure in [ Pa ]                    
      REAL blkdens(blksize) ! Air density  [ kg m^-3 ]                  
      REAL blkrh(blksize) 

! *** Chemical production rates [ ug m**-3 s -1 ] :

! Fractional relative humidity              
      REAL so4rat(blksize)                                 ! rate [ug/m^3/s]
! sulfuric acid vapor-phase production  
      REAL orgaro1rat(blksize)                                 ! production rate from aromatics [ ug /
! anthropogenic organic aerosol mass    
      REAL orgaro2rat(blksize)                                 ! production rate from aromatics [ ug /
! anthropogenic organic aerosol mass    
      REAL orgalk1rat(blksize)                                 ! rate from alkanes & others [ ug / m^3
! anthropogenic organic aerosol mass pro
      REAL orgole1rat(blksize)                                 ! rate from alkanes & others [ ug / m^3
! anthropogenic organic aerosol mass pro
      REAL orgbio1rat(blksize)                                 ! rate [ ug / m^3 s ]
! biogenic organic aerosol production   
      REAL orgbio2rat(blksize)                                 ! rate [ ug / m^3 s ]
! biogenic organic aerosol production   
      REAL orgbio3rat(blksize)                                 ! rate [ ug / m^3 s ]
! biogenic organic aerosol production   
      REAL orgbio4rat(blksize)                                 ! rate [ ug / m^3 s ]
!bs
! *** atmospheric properties

! biogenic organic aerosol production   
      REAL xlm(blksize) ! atmospheric mean free path [ m ]  
      REAL amu(blksize) 
! *** aerosol properties:

! *** modal diameters:

! atmospheric dynamic viscosity [ kg
      REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
      REAL dgacc(blksize) ! accumulation geometric mean diamet
      REAL dgcor(blksize) 

! *** Modal mass concentrations [ ug m**3 ]

! coarse mode geometric mean diamete
      REAL pmassn(blksize) ! mass concentration in Aitken mode 
      REAL pmassa(blksize) ! mass concentration in accumulation
      REAL pmassc(blksize) 
! *** average modal particle densities  [ kg/m**3 ]

! mass concentration in coarse mode 
      REAL pdensn(blksize) ! average particle density in nuclei
      REAL pdensa(blksize) ! average particle density in accumu
      REAL pdensc(blksize) 
! *** average modal Knudsen numbers

! average particle density in coarse
      REAL knnuc(blksize) ! nuclei mode  Knudsen number       
      REAL knacc(blksize) ! accumulation Knudsen number       
      REAL kncor(blksize) 
! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]

! coarse mode  Knudsen number       
      REAL fconcn(blksize) 
! reciprocal condensation rate Aitke
      REAL fconca(blksize) !bs
! reciprocal condensation rate acclu
      REAL fconcn_org(blksize)
      REAL fconca_org(blksize)
!bs

! *** Rates for secondary particle formation:

! *** production of new mass concentration [ ug/m**3 s ]
      REAL dmdt(blksize) !                                 by particle formation

! *** production of new number concentration [ number/m**3 s ]

! rate of production of new mass concen
      REAL dndt(blksize) !                                 by particle formation
! *** growth rate for third moment by condensation of precursor
!      vapor on existing particles [ 3rd mom/m**3 s ]

! rate of producton of new particle num
      REAL cgrn3(blksize) !  Aitken mode                          
      REAL cgra3(blksize) 
! *** Rates for coaglulation: [ m**3/s ]

! *** Unimodal Rates:

!  Accumulation mode                    
      REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
      REAL ura00(blksize) 

! *** Bimodal Rates:  Aitken mode with accumulation mode ( d( Aitken mod

! accumulation mode 0th moment self-coagulat
      REAL brna01(blksize) ! rate for 0th moment                     
      REAL brna31(blksize) 
! *** other processes

! rate for 3rd moment                     
      REAL deltaso4a(blksize) !                                  sulfate aerosol by condensation   [ u

! *** housekeeping variables:

! increment of concentration added to   
      INTEGER unit
      PARAMETER (unit=30)

      CHARACTER*16 pname
      PARAMETER (pname=' BOX            ')

      INTEGER isp,igrid,jgrid,kgrid

! loop index for species.                             
      INTEGER ii, iimap(8)
      DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/

!   begin body  of program box

! *** Set up files and other info

! *** set up experimental conditions

! *** initialize model variables

!ia *** not required any more

!ia       DO ISP = 1, NSPCSDA
!ia       CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
!ia       END DO

      step = & ! set time step                                   
        dtsec
      blkta(blksize) = & ! T in Kelvin             
        temp
      blkprs(blksize) = pres* & ! P in  Pa (pres is given in 
        100.
      blkrh(blksize) = & ! fractional RH            
        relhum
      blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs      CBLK(BLKSIZE,VSULF) = vsulf_in
!rs      CBLK(BLKSIZE,VHNO3) = nitrate_in
!rs      CBLK(BLKSIZE,VNH3) =  nh3_in
!bs
!rs      CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
!rs      CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
!rs      CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
!rs      CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
!rs      CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
!rs      CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
!rs      CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
!rs      CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
! dr
      DO isp = 1, ldrog
        drog(blksize,isp) = drog_in(isp)
      END DO
!      print*,'drog in rpm',drog
!bs
!ia *** 27/05/97 the following variables are transported quantities
!ia *** of the column-model now and thuse do not need this init.
!ia *** step.

!     CBLK(BLKSIZE,VNU0) = numnuc_in
!     CBLK(BLKSIZE,VAC0) = numacc_in
!     CBLK(BLKSIZE,VSO4A) =  asulf_in
!     CBLK(BLKSIZE,VSO4AI) = asulfi_in
!     CBLK(BLKSIZE, VCORN) = numcor_in

      so4rat(blksize) = so4rat_in

!...INITIALISE EMISSION RATES

!     epm25i(blksize) = & ! unidentified PM2.5 mass                  
!       0.0
!     epm25j(blksize) = & 
!       0.0
! unidentified PM2.5 m
      eorgi(blksize) = & ! primary organic     
        eorgi_in
      eorgj(blksize) = & 
        eorgj_in
! primary organic     
      eeci(blksize) = & ! elemental carbon    
        eeci_in
      eecj(blksize) = & 
        eecj_in
! elemental carbon    
      epm25(blksize) = & !currently from input file ACTIONIA        
        0.0
      esoil(blksize) = & ! ACTIONIA                          
        soilrat_in
      eseas(blksize) = & !currently from input file ACTIONIA        
        0.0
!     epmcoarse(blksize) = & !currently from input file ACTIONIA    
!       0.0
      dgnuc(blksize) = dginin
      dgacc(blksize) = dginia
      dgcor(blksize) = dginic
      newm3 = 0.0

! *** Set up initial total 3rd moment factors

      totaersulf = 0.0
      newm3 = 0.0
! ***  time loop

!       write(50,*) ' numsteps dgnuc dgacc ',
!    &      ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'

! *** Call aerosol routines

      CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
        blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat, &
        orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
        nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
        amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
        knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
        urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid)

! *** write output

!      WRITE(UNIT,*) ' AFTER AEROPROC '
!      WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS

! *** Write out file for graphing.

!     write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)

! *** update sulfuric acid vapor
!ia 21.04.98 this update is not required here
!ia artefact from box model
!       CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
!    &            SO4RAT(BLKSIZE) * STEP

      RETURN

!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
    END SUBROUTINE rpmmod3
! main box model                                            
    SUBROUTINE soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
        orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
        nacv,cblk,blksize,nspcsda,numcells,dt)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:                                                      !
!bs                                                                    !
!bs  SOA_PART calculates the formation and partitioning of secondary   !
!bs  organic aerosol based on (pseudo-)ideal solution thermodynamics.  !
!bs                                                                    !
!bs  This code considers two cases:                                    !
!bs   i) initil absorbing mass is existend in the aerosol phase        !
!bs  ii) a threshold has to be exeeded before partitioning (even below !
!bs      saturation) will take place.                                  !
!bs                                                                    !
!bs  The temperature dependence of the saturation concentrations are   !
!bs  calculated using the Clausius-Clapeyron equation.                 !
!bs                                                                    !
!bs  It is assumed that the condensable vapors also evaporate if the   !
!bs  saturation concentraion lowers e.g. due to temperature effects.   !
!bs  Therefor negative production rates (= evaporation rates) are      !
!bs  possible.                                                         !
!bs                                                                    !
!bs  If there is no absorbing mass at all the Pandis method is applied !
!bs  for the first steps.                                              !
!bs                                                                    !
!bs  References:                                                       !
!bs    Pankow (1994):                                                  !
!bs     An absorption model of the gas/aerosol                         !
!bs     partitioning involved in the formation of                      !
!bs     secondary organic aerosol, Atmos. Environ. 28(2),              !
!bs     189-193.                                                       !
!bs    Odum et al. (1996):                                             !
!bs     Gas/particle partitioning and secondary organic                !
!bs     aerosol yields,  Environ. Sci. Technol. 30,                    !
!bs     2580-2585.                                                     !
!bs    see also                                                        !
!bs    Bowman et al. (1997):                                           !
!bs     Mathematical model for gas-particle partitioning               !
!bs     of secondary organic aerosols, Atmos. Environ.                 !
!bs     31(23), 3921-3931.                                             !
!bs    Seinfeld and Pandis (1998):                                     !
!bs     Atmospheric Chemistry and Physics (0-471-17816-0)              !
!bs     chapter 13.5.2 Formation of binary ideal solution              !
!bs     with -- preexisting aerosol                                    !
!bs          -- other organic vapor                                    !
!bs                                                                    !
!bs  Called by:     SORGAM                                             !
!bs                                                                    !
!bs  Calls:         None                                               !
!bs                                                                    !
!bs  Arguments:     LAYER,                                             !
!bs                 BLKTA, BLKPRS,                                     !
!bs                 ORGARO1RAT, ORGARO2RAT,                            !
!bs                 ORGALK1RAT, ORGOLE1RAT,                            !
!bs                 ORGBIO1RAT, ORGBIO2RAT,                            !
!bs                 ORGBIO3RAT, ORGBIO4RAT,                            !
!bs                 DROG, LDROG, NCV, NACV,                            !
!bs                 CBLK, BLKSIZE, NSPCSDA, NUMCELLS,                  !
!bs                 DT                                                 !
!bs                                                                    !
!bs  Include files: AEROSTUFF.EXT                                      !
!bs                 AERO_internal.EXT                                  !
!bs                                                                    !
!bs  Data:          None                                               !
!bs                                                                    !
!bs  Input files:   None                                               !
!bs                                                                    !
!bs  Output files:  None                                               !
!bs                                                                    !
!bs--------------------------------------------------------------------!
!bs                                                                    !
!bs  History:                                                          !
!bs   No    Date    Author           Change                            !
!bs  ____  ______  ________________  _________________________________ !
!bs   01   170399   B.Schell         Set up                            !
!bs   02   050499   B.Schell         introduced SR NEWT                !
!bs   03   040599   B.Schell         include-file sorgam.inc           !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!     IMPLICIT NONE
!bs
!bs * includes
!bs
!bs
!bs * input variables
!bs
! model layer                     
      INTEGER layer
! dimension of arrays             
      INTEGER blksize
! number of species in CBLK       
      INTEGER nspcsda
! actual number of cells in arrays
      INTEGER numcells
! # of organic aerosol precursor  
      INTEGER ldrog
! total # of cond. vapors & SOA sp
      INTEGER ncv
! # of anthrop. cond. vapors & SOA
      INTEGER nacv
      REAL cblk(blksize,nspcsda) ! main array of variables         
! model time step in  SECONDS     
      REAL dt
      REAL blkta(blksize) ! Air temperature [ K ]           
      REAL blkprs(blksize) ! Air pressure in [ Pa ]          
      REAL orgaro1rat(blksize)                                       ! rates from aromatics
! anth. organic vapor production  
      REAL orgaro2rat(blksize)                                       ! rates from aromatics
! anth. organic vapor production  
      REAL orgalk1rat(blksize)                                       ! rates from alkenes and others
! anth. organic vapor production  
      REAL orgole1rat(blksize)                                       ! rates from alkanes and others
! anth. organic vapor production  
      REAL orgbio1rat(blksize) ! bio. organic vapor production ra
      REAL orgbio2rat(blksize) ! bio. organic vapor production ra
      REAL orgbio3rat(blksize) ! bio. organic vapor production ra
      REAL orgbio4rat(blksize) ! bio. organic vapor production ra
      REAL drog(blksize,ldrog) !bs
!bs * local variable declaration
!bs
! Delta ROG conc. [ppm]           
!bs numerical value for a minimum thresh
      REAL thrsmin
      PARAMETER (thrsmin=1.E-19)
!bs numerical value for a minimum thresh
!bs
!bs universal gas constant [J/mol-K]    
      REAL rgas
      PARAMETER (rgas=8.314510)
!bs reference temperature T0 = 298 K    
      REAL tnull
      PARAMETER (tnull=298.)
!bs molecular weight for C              
      REAL mwc
      PARAMETER (mwc=12.0)
!bs molecular weight for organic species
      REAL mworg
      PARAMETER (mworg=175.0)
!bs molecular weight for SO4            
      REAL mwso4
      PARAMETER (mwso4=96.0576)
!bs molecular weight for NH4            
      REAL mwnh4
      PARAMETER (mwnh4=18.03858)
!bs molecular weight for NO3            
      REAL mwno3
      PARAMETER (mwno3=62.01287)
!bs relative tolerance for mass check   
      REAL rtol
      PARAMETER (rtol=1.E-04)
!bs      REAL DTMIN                !bs minimum time step in seconds
!bs      PARAMETER (DTMIN = 0.1)
!bs
!bs loop index                          
      INTEGER lcell
      INTEGER l, & !bs loop index                          
        n
!bs conversion factor ppm --> ug/m^3    
      REAL convfac
!bs difference of inverse temperatures  
      REAL ttinv
!bs weighted initial organic mass [10^-6
      REAL minitw
!bs weighted total organic mass [10^-6 m
      REAL mtotw
!bs weighted inorganic mass [10^-6 mol/m
      REAL mnonow
!bs 1. / MTOTW                          
      REAL imtotw
!bs initial organic mass [ug/m^3]       
      REAL minit
!bs inorganic mass [ug/m^3]             
      REAL mnono
!bs total organic mass [ug/m^3]         
      REAL mtot
!bs threshold for SOA formatio for low M
      REAL thres
!bs mass check ratio of input/output mas
      REAL mcheck
      REAL msum(ncv) !bs input total mass [ug/m^3]           
      REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
      REAL imwcv(ncv) !bs 1. / MWCV(NCV)                      
      REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
      REAL dhvap(ncv) !bs heat of vaporisation of compound i [
      REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]     
      REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
      REAL cgas(ncv) !bs gasphase concentration of cond. vapo
      REAL caer(ncv) !bs aerosolphase concentration of cond. 
      REAL asav(ncv) !bs saved CAER for iteration            
      REAL aold(ncv) !bs saved CAER for rate determination   
      REAL csat(ncv) !bs saturation conc. of cond. vapor [ug/
      REAL alpha(ncv) !bs molar yield for condensable vapors  
      REAL prod(ncv) !bs production of condensable vapor [ug/
      REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]          
      REAL f(ldrog) !bs scaling factor for ind. oxidant     
!bs check convergence of SR NEWT        
      LOGICAL check
!bs
      INTEGER its
!bs * initialisation
!bs
!bs * DVAP data: average value calculated from C14-C18 monocarboxylic
!bs *      acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
!bs *      Eniron. Sci. Technol. 1989, 23, 1519-1523.
!bs *      average value is 156 kJ/mol
!bs
!bs number of iterations in NEWT        
      dhvap(psoaaro1) = 156.0E03
      dhvap(psoaaro2) = 156.0E03
      dhvap(psoaalk1) = 156.0E03
      dhvap(psoaole1) = 156.0E03
      dhvap(psoaapi1) = 156.0E03
      dhvap(psoaapi2) = 156.0E03
      dhvap(psoalim1) = 156.0E03
      dhvap(psoalim2) = 156.0E03
!bs
!bs * MWCV data: average value calculated from C14-C18 monocarboxylic
!bs *      acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
!bs *      Eniron. Sci. Technol. 1989, 23, 1519-1523.
!bs *      average value is 222.5 g/mol
!bs *
!bs * molecular weights used are estimates taking the origin (reactants)
!bs *      into account. This should be updated if more information abou
!bs *      the products is available.
!bs *      First hints are taken from Forstner et al. (1997), Environ. S
!bs *        Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmo
!bs *        Environ. 31(13), 1953-1964.
!bs *
!bs * !! these molecular weights should be identical with WTM in CTM !!
!bs
      mwcv(psoaaro1) = 150.
      mwcv(psoaaro2) = 150.
      mwcv(psoaalk1) = 140.
      mwcv(psoaole1) = 140.
      mwcv(psoaapi1) = 184.
      mwcv(psoaapi2) = 184.
      mwcv(psoalim1) = 200.
      mwcv(psoalim2) = 200.
!bs
!bs * aromatic yields from:
!bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, R.C. Flagan, and
!bs *   J.H. Seinfeld: The atmospheric aerosol-forming potential of whol
!bs *   gasoline vapor, Science 276, 96-99, 1997.
!bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, H.J.L. Forstner, R.C. Fl
!bs *   and J.H. Seinfeld: Aromatics, reformulated gasoline, and atmosph
!bs *   organic aerosol formation, Environ. Sci. Technol. 31, 1890-1897,
!bs *
!bs * !! yields provided by Odum are mass-based stoichiometric coefficen
!bs *    average for high and low yield aromatics
!bs *    alpha1 = 0.0545  K1 = 0.0475 m^3/ug
!bs *    alpha2 = 0.1525  K2 = 0.00165 m^3/ug
!bs *    change to molar yields using the model MW
!bs *    alpha1 * MW(XYL) / MW(PSOAARO1) = alpha1 * 106 / 150 = 0.0385
!bs *    alpha2 * MW(XYL) / MW(PSOAARO2) = alpha2 * 106 / 150 = 0.1077
!bs *   ALPHA(PSOAARO1) = 0.0385; ALPHA(PSOAARO2) = 0.1077
!bs *
!bs
!bs * alkane and alkene yields from:
!bs * Moucheron M.C. and J. Milford: Development and testing of a proces
!bs *    model for secondary organic aerosols. Air & Waste Manag. Assoc.
!bs *    for presentation at the 89th Annual Meeting & Exhibition, Nashv
!bs *    Tennessee, June 23-28, 96-FA130B.03, 1996.
!bs *  molar yields used instead of [ ug m^-3 / ppm ], calculation
!bs *    at T=298K, P=1.0133*10^5 Pa
!bs *    ALPHA(PSOAALK1) = 0.048; ALPHA(PSOAOLE1) = 0.008
!bs
!bs * biogenic yields from:
!bs * Griffin R.J., D.R. Cocker III, R.C. Flagan, and J.H. Seinfeld:
!bs *   Organic aerosol formation from the oxidation of biogenic hydro-
!bs *   carbons, JGR, 1999 in press.
!bs *   the yields given in Table 3 are mass yields [ ug m^-3 / ug m^-3
!bs *   change to molar yields via:
!bs *   molar yield = mass yield * ((R*T/M_soa*p) / (R*T/M_terp*p))
!bs *               = mass yield * (M_terp / M_soa)
!bs *               = mass yield * ( M(Terpenes) / M(pinonic acid) )
!bs *               = mass yield * 136 / 184
!bs * average for a-Pinene and Limonene, maybe splitted in future versio
!bs *    0.138 * 0.739 = 0.102; 0.345 * 0.739 = 0.254
!bs * values for a-Pinene (molar yield) alpha1 = 0.028, alpha2 = 0.241
!bs * values for limonene (molar yield) alpha1 = 0.163, alpha2 = 0.247
!bs
      alpha(psoaaro1) = 0.039
      alpha(psoaaro2) = 0.108
      alpha(psoaalk1) = 0.048
      alpha(psoaole1) = 0.008
!bs      ALPHA(PSOAAPI1) = 0.028
!bs      ALPHA(PSOAAPI2) = 0.241
      alpha(psoaapi1) = & !bs API + O3 only Griffin '99           
        0.092
      alpha(psoaapi2) = & !bs API + O3 only Griffin '99           
        0.075
      alpha(psoalim1) = 0.163
      alpha(psoalim2) = 0.247
!bs
!bs * P0 data in Pa for T = 298K:
!bs *    aromatics: Odum et al. (1997) using R = 8.314 J/(mol*K),
!bs *         DHvap = 156 kJ/mol, T = 313K, MW = 150 g/mol and averaged
!bs *         Ki's of high and low aromatics.
!bs *         T = 313   => PNULL(ARO1) = 1.7E-05, PNULL(ARO2) = 5.1E-04
!bs *         T = 307.4 => PNULL(ARO1) = 5.7E-05, PNULL(ARO2) = 1.6E-03
!bs *    biogenics: Hoffmann et al. (1997); Griffin et al. (1999);
!bs *         using R = 8.314 J/(mol*K),
!bs *         DHvap = 156 kJ/mol, T = 313, MW = 184 g/mol, and
!bs *         averaged Ki's of a-pinene and limonene
!bs *         p1(298K) = 6.1E-06; p2(298K) = 1.5E-04
!bs *         Ki's for a-pinene p1(298K) = 4.0E-06; p2(298K) = 1.7E-04
!bs *         Ki's for limonene p1(298K) = 2.5E-05; p2(298K) = 1.2E-04
!bs *    alkanes and alkenes: no data available, use low value to get cl
!bs *         to the Pandis yields, 1 ppt = 1*10^-7 Pa.
!bs
      pnull(psoaaro1) = 5.7E-05
      pnull(psoaaro2) = 1.6E-03
      pnull(psoaalk1) = 5.0E-06
      pnull(psoaole1) = 5.0E-06
!bs      PNULL(PSOAAPI1) = 4.0E-06
!bs      PNULL(PSOAAPI2) = 1.7E-04
      pnull(psoaapi1) = & !bs API + O3 only Griffin '99         
        2.488E-05
      pnull(psoaapi2) = & !bs API + O3 only Griffin '99         
        2.778E-05
      pnull(psoalim1) = 2.5E-05
      pnull(psoalim2) = 1.2E-04
!bs
!bs * scaling of contribution of individual oxidants to aerosol formatio
!bs
      f(pxyl) = & !bs * XYL + OH                          
        1.
      f(ptol) = & !bs * TOL + OH                          
        1.
      f(pcsl1) = & !bs * CSL + OH                          
        1.
      f(pcsl2) = & !bs * CSL + NO                          
        1.
      f(phc8) = & !bs * HC  + OH                          
        1.
      f(poli1) = & !bs * OLI + OH                          
        1.
      f(poli2) = & !bs * OLI + NO                          
        1.
      f(poli3) = & !bs * OLI + O3                          
        1.
      f(polt1) = & !bs * OLT + OH                          
        1.
      f(polt2) = & !bs * OLT + NO                          
        1.
      f(polt3) = & !bs      F(PAPI1) = 0.228          !bs * API + OH
        1.
!bs      F(PAPI2) = 0.             !bs * API + NO
!bs      F(PAPI3) = 0.771          !bs * API + O3
!bs * OLT + O3                          
      f(papi1) = & !bs * API + OH                          
        0.
      f(papi2) = & !bs * API + NO                          
        0.
      f(papi3) = & !bs * API + O3                          
        1.
      f(plim1) = & !bs * LIM + OH                          
        0.228
      f(plim2) = & !bs * LIM + NO                          
        0.
      f(plim3) = & !bs
        0.771
!bs * begin code -------------------------------------------------------
!bs
!bs * LIM + O3                          
      DO lcell = 1, numcells
        DO l = 1, ldrog
          drog(lcell,l) = f(l)*drog(lcell,l)
        END DO
        ttinv = 1./tnull - 1./blkta(lcell)
        convfac = blkprs(lcell)/(rgas*blkta(lcell))
        cgas(psoaaro1) = cblk(lcell,vcvaro1)
        cgas(psoaaro2) = cblk(lcell,vcvaro2)
        cgas(psoaalk1) = cblk(lcell,vcvalk1)
        cgas(psoaole1) = cblk(lcell,vcvole1)
        cgas(psoaapi1) = cblk(lcell,vcvapi1)
        cgas(psoaapi2) = cblk(lcell,vcvapi2)
        cgas(psoalim1) = cblk(lcell,vcvlim1)
        cgas(psoalim2) = cblk(lcell,vcvlim2)
        caer(psoaaro1) = cblk(lcell,vorgaro1j) + cblk(lcell,vorgaro1i)
        caer(psoaaro2) = cblk(lcell,vorgaro2j) + cblk(lcell,vorgaro2i)
        caer(psoaalk1) = cblk(lcell,vorgalk1j) + cblk(lcell,vorgalk1i)
        caer(psoaole1) = cblk(lcell,vorgole1j) + cblk(lcell,vorgole1i)
        caer(psoaapi1) = cblk(lcell,vorgba1j) + cblk(lcell,vorgba1i)
        caer(psoaapi2) = cblk(lcell,vorgba2j) + cblk(lcell,vorgba2i)
        caer(psoalim1) = cblk(lcell,vorgba3j) + cblk(lcell,vorgba3i)
        caer(psoalim2) = cblk(lcell,vorgba4j) + cblk(lcell,vorgba4i)
!bs
        prod(psoaaro1) = drog(lcell,pxyl) + drog(lcell,ptol) + &
          drog(lcell,pcsl1) + drog(lcell,pcsl2)
        prod(psoaaro2) = drog(lcell,pxyl) + drog(lcell,ptol) + &
          drog(lcell,pcsl1) + drog(lcell,pcsl2)
        prod(psoaalk1) = drog(lcell,phc8)
        prod(psoaole1) = drog(lcell,poli1) + drog(lcell,poli2) + &
          drog(lcell,poli3) + drog(lcell,polt1) + drog(lcell,poli2) + &
          drog(lcell,polt3)
        prod(psoaapi1) = drog(lcell,papi1) + drog(lcell,papi2) + &
          drog(lcell,papi3)
        prod(psoaapi2) = drog(lcell,papi1) + drog(lcell,papi2) + &
          drog(lcell,papi3)
        prod(psoalim1) = drog(lcell,plim1) + drog(lcell,plim2) + &
          drog(lcell,plim3)
        prod(psoalim2) = drog(lcell,plim1) + drog(lcell,plim2) + &
          drog(lcell,plim3)
!bs
!bs * calculate actual production from gasphase reactions [ug/m^3]
!bs * calculate vapor pressure of pure compound as a liquid
!bs *   using the Clausius-Clapeyromn equation and the actual
!bs *   saturation concentration.
!bs * calculate the threshold for partitioning if no initial mass
!bs *   is present to partition into.
!bs
        thres = 0.
        mtot = 0.
        mtotw = 0.
        DO l = 1, ncv
          prod(l) = convfac*mwcv(l)*alpha(l)*prod(l)
          ctot(l) = prod(l) + cgas(l) + caer(l) !bs redefined below   
          p(l) = prod(l)
          msum(l) = cgas(l) + caer(l) + prod(l)
          aold(l) = caer(l)
          imwcv(l) = 1./mwcv(l)
          pvap(l) = pnull(l)*exp(dhvap(l)/rgas*ttinv)
          csat(l) = pvap(l)*mwcv(l)*1.0E06/(rgas*blkta(lcell))
          thres = thres + ((cgas(l)+prod(l))/csat(l))
          mtot = mtot + caer(l)
          mtotw = mtotw + caer(l)*imwcv(l)
        END DO
!bs
!bs * small amount of non-volatile absorbing mass is assumed to be
!bs * present (following Bowman et al. (1997) 0.01% of the inorganic
!bs * mass in each size section, here mode)
!bs
        mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+cblk(lcell, &
          vno3aj))
        mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+cblk( &
          lcell,vno3ai))
        mnonow = 0.0001*(cblk(lcell,vso4aj)/mwso4+cblk(lcell,vnh4aj)/mwnh4+ &
          cblk(lcell,vno3aj)/mwno3)
        mnonow = mnonow + 0.0001*(cblk(lcell,vso4ai)/mwso4+cblk(lcell,vnh4ai)/ &
          mwnh4+cblk(lcell,vno3ai)/mwno3)
        mnono = max(mnono,conmin)
        mnonow = max(mnonow,conmin)
!bs
!bs         MNONOW = 0.
!bs         MNONO  = 0.
!bs
        minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + &
          cblk(lcell,vorgpai) + mnono
        minitw = (cblk(lcell,vecj)+cblk(lcell,veci))/mwc + &
          (cblk(lcell,vorgpaj)+cblk(lcell,vorgpai))/mworg + mnonow
!bs
!bs * If MINIT is set to zero partitioning will occur if the pure
!bs * saturation concentation is exceeded (Pandis et al. 1992).
!bs * If some amount of absorbing organic mass is formed gas/particle
!bs * partitioning will follow the ideal solution approach.
!bs
        minit = 0.
        minitw = 0.
!bs
        mtot = mtot + minit
        mtotw = mtotw + minitw
        imtotw = 1./mtotw
!bs
!bs * do the gas/particle partitioning
!bs
        IF ((thres>1 .AND. minitw<thrsmin) .OR. (minitw>thrsmin) .OR. &
            (mtot>thrsmin)) THEN
!bs
          DO l = 1, ncv
            ctot(l) = p(l) + cgas(l) + caer(l)
            caer(l) = ctot(l) !bs 'initial' guess      
          END DO
!bs
!bs * globally convergent method for nonlinear system of equations
!bs * adopted from Numerical Recipes 2nd Edition
!bs
          CALL newt(layer,caer,ncv,check,ctot,csat,imwcv,minitw,its)
!bs
          IF (check) THEN
!           WRITE (6,'(a,i2)') '!! Problems in SR NEWT !! K: ', layer
          END IF
!bs
!bs       IF (layer==1) WRITE (76,'(i3)') its
!bs
          DO l = 1, ncv
            IF (caer(l)<=tolmin) THEN
!             IF (abs(caer(l))>tolmin) WRITE (6,90000) l, caer(l)
              caer(l) = conmin
            END IF
            IF (caer(l)>ctot(l)) THEN
              IF (caer(l)-ctot(l)>tolmin) THEN
!                WRITE (6,90010)
              END IF
              caer(l) = ctot(l)
            END IF
            cgas(l) = ctot(l) - caer(l)
          END DO
!bs
!90000     FORMAT ('!! PROBLEMS WITH CAER, CAER < 0. !!',1X,I1,1PE14.6)
!90010     FORMAT ('!! PROBLEMS WITH CAER, CAER > CTOT !!')
!bs
!bs * assign values to CBLK array
!bs
          cblk(lcell,vcvaro1) = max(cgas(psoaaro1),conmin)
          cblk(lcell,vcvaro2) = max(cgas(psoaaro2),conmin)
          cblk(lcell,vcvalk1) = max(cgas(psoaalk1),conmin)
          cblk(lcell,vcvole1) = max(cgas(psoaole1),conmin)
          cblk(lcell,vcvapi1) = max(cgas(psoaapi1),conmin)
          cblk(lcell,vcvapi2) = max(cgas(psoaapi2),conmin)
          cblk(lcell,vcvlim1) = max(cgas(psoalim1),conmin)
          cblk(lcell,vcvlim2) = max(cgas(psoalim2),conmin)
          orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
          orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
          orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
          orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
          orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
          orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
          orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
          orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
!bs
!bs
        ELSE
!bs            WRITE(6,'(a)') 'Pandis method in SR SOA_PART.F used!'
!bs            WRITE(6,1010) THRES, MINITW
!bs 1010       FORMAT('THRES =',1pe14.6,1X,'MINITW =',1pe14.6)
!bs
!bs do Pandis method                    
          DO l = 1, ncv
            caer(l) = ctot(l) - csat(l)
            caer(l) = max(caer(l),0.)
            cgas(l) = ctot(l) - caer(l)
          END DO
!bs
          cblk(lcell,vcvaro1) = cgas(psoaaro1)
          cblk(lcell,vcvaro2) = cgas(psoaaro2)
          cblk(lcell,vcvalk1) = cgas(psoaalk1)
          cblk(lcell,vcvole1) = cgas(psoaole1)
          cblk(lcell,vcvapi1) = cgas(psoaapi1)
          cblk(lcell,vcvapi2) = cgas(psoaapi2)
          cblk(lcell,vcvlim1) = cgas(psoalim1)
          cblk(lcell,vcvlim2) = cgas(psoalim2)
          orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
          orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
          orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
          orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
          orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
          orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
          orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
          orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
!bs
        END IF
!bs
!bs * check mass conservation
!bs
        DO l = 1, ncv
!rs check is component exits
          IF (cgas(l)==0. .AND. caer(l)==0. .AND. msum(l)==0) THEN
            mcheck = 1.
          ELSE
            mcheck = (cgas(l)+caer(l))/msum(l)
          END IF
          IF ((mcheck<1.-rtol) .OR. (mcheck>1.+rtol)) THEN
!           WRITE (6,'(/,a)') 'Problems with mass conservation!'
!           WRITE (6,90020) layer, l, mcheck, cgas(l) + caer(l)
!           WRITE (6,'(a)') '!! CHECK RESULTS !!'
90020       FORMAT ('LAYER = ',I2,', L = ',I2,', MCHECK = ',E12.6,', MASS = ', &
              E12.6)
          END IF
        END DO
!bs
!bs
      END DO
!bs * end of SR SOA_PART
!bs
!bs loop over NUMCELLS                  
      RETURN
    END SUBROUTINE soa_part
    SUBROUTINE sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
        orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
        nacv,cblk,blksize,nspcsda,numcells,dt)
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs                                                                    !
!bs  Description:   Secondary organic aerosol module                   !
!bs                 This module calculates the gas/particle parti-     !
!bs                 tioning of semi-volatile organic vapors            !
!bs                                                                    !
!bs  Called by:     RPMMOD3                                            !
!bs                                                                    !
!bs  Calls:         SOA_PANDIS                                         !
!bs                 SOA_PART                                           !
!bs                                                                    !
!bs  Arguments:     LAYER, BLKTA,                                      !
!bs                 ORGARO1RAT, ORGARO2RAT,                            !
!bs                 ORGALK1RAT, ORGOLE1RAT,                            !
!bs                 ORGBIO1RAT, ORGBIO2RAT,                            !
!bs                 DROG, LDROG,                                       !
!bs                 CBLK, BLKSIZE, NSPCSDA, NUMCELLS,                  !
!bs                 DT                                                 !
!bs                                                                    !
!bs  Include files: AEROSTUFF.EXT                                      !
!bs                 AERO_internal.EXT                                  !
!bs                                                                    !
!bs  Data:                                                             !
!bs                                                                    !
!bs  Input files:   None                                               !
!bs                                                                    !
!bs  Output files:  UNIT 90: control output                            !
!bs                                                                    !
!bs--------------------------------------------------------------------!
!bs                                                                    !
!bs  History:                                                          !
!bs   No    Date    Author           Change                            !
!bs  ____  ______  ________________  _________________________________ !
!bs   01   040299   B.Schell         Set up                            !
!bs                                                                    !
!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
!bs
!bs * Literature:
!bs * Pandis et al. (1992): Secondary organic aerosol formation and
!bs *     transport. Atmos Environ. 26A, 2453-2466.
!bs * Seinfeld and Pandis (1998): Atmospheric Chemistry and Physics
!bs *     chapter 13.5.2 Noninteracting SOA compounds. (0-471-17816-0)
!bs * STI Report (Sonoma Technology, Inc.) (1998):
!bs *     Development of gas-phase chemistry, secondary organic aerosol,
!bs *     and aqueous-phase chemistry modules for PM modeling.
!bs *     By: R. Strader, C. Gurciullo, S. Pandis, N. Kumar, F. Lurmann
!bs *     Prepared for: Coordinating Research Council, Atlanta, Aug 24 1
!bs * Tao and McMurray (1989): Vapor pressures and surface free energies
!bs *     C14-C18 monocarboxylic acids and C5 and C6 dicarboxylic acids.
!bs *     Eniron. Sci. Technol. 23, 1519-1523.
!bs * Pankow (1994): An absorption model of gas/particle partitioning of
!bs *     organic compounds in the atmosphere. Atmos. Environ. 28, 185-1
!bs * Pankow (1994): An absorption model of gas/aerosol partitioning inv
!bs *     in the formation of secondary organic aerosol.
!bs *     Atmos. Environ. 28, 189-193.
!bs * Odum et al. (1996): Gas/particle partitioning and secondary organi
!bs *     aerosol yields. Environ. Sci. Technol. 30(8), 2580-2585.
!bs
!     IMPLICIT NONE
!bs
!bs
!bs * variable declaration
!bs
!bs
!bs * inputs
!bs
! dimension of arrays             
      INTEGER blksize
! number of species in CBLK       
      INTEGER nspcsda
! actual number of cells in arrays
      INTEGER numcells
! model layer                     
      INTEGER layer
! # of organic aerosol precursor  
      INTEGER ldrog
! total # of cond. vapors & SOA sp
      INTEGER ncv
! # of anthrop. cond. vapors & SOA
      INTEGER nacv
! model time step in  SECONDS     
      REAL dt
      REAL cblk(blksize,nspcsda) ! main array of variables         
      REAL blkta(blksize) ! Air temperature [ K ]           
      REAL blkprs(blksize) ! Air pressure in [ Pa ]          
      REAL orgaro1rat(blksize)                                       ! rates from aromatics
! anth. organic vapor production  
      REAL orgaro2rat(blksize)                                       ! rates from aromatics
! anth. organic vapor production  
      REAL orgalk1rat(blksize)                                       ! rates from alkanes and others
! anth. organic vapor production  
      REAL orgole1rat(blksize)                                       ! rates from alkenes and others
! anth. organic vapor production  
      REAL orgbio1rat(blksize) ! bio. organic vapor production ra
      REAL orgbio2rat(blksize) ! bio. organic vapor production ra
      REAL orgbio3rat(blksize) ! bio. organic vapor production ra
      REAL orgbio4rat(blksize) ! bio. organic vapor production ra
      REAL drog(blksize,ldrog) !bs
!bs * get some infos
!bs
!bs      INTEGER LL
!bs      IF (LAYER .EQ. 1) THEN
!bs         WRITE(75,4711) (CBLK(1,LL), LL = VORGARO1J, VORGOLE1I)
!bs         WRITE(75,4711) (CBLK(1,LL), LL = VORGBA1J , VORGBA4I )
!bs         WRITE(75,4712) (CBLK(1,LL), LL = VCVARO1, VCVLIM2)
!bs         WRITE(75,4712) (DROG(1,LL), LL =  1,    8)
!bs         WRITE(75,4712) (DROG(1,LL), LL =  9,   16)
!bs         WRITE(75,4714) (DROG(1,LL), LL = 17,LDROG)
!bs      ENDIF
!bs 4711 FORMAT(8(e12.6,1X))
!bs 4712 FORMAT(8(e12.6,1X))
!bs 4713 FORMAT(17(e12.6,1X))
!bs 4714 FORMAT(e12.6,/)
!bs
!bs * begin code
!bs
! ROG production rate [ug m^-3 s^-
      IF (orgaer==1) THEN
!       IF (firstime) THEN
!         WRITE (6,'(a)')
!         WRITE (6,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
!         WRITE (6,'(a)')
!         WRITE (90,'(a)')
!         WRITE (90,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
!         firstime = .FALSE.
!       END IF
!         CALL SOA_PANDIS(
!     &                   LAYER,
!     &                   BLKTA, BLKPRS,
!     &                   ORGARO1RAT, ORGARO2RAT,
!     &                   ORGALK1RAT, ORGOLE1RAT,
!     &                   ORGBIO1RAT, ORGBIO2RAT,
!     &                   ORGBIO3RAT, ORGBIO4RAT,
!     &                   DROG, LDROG, NCV, NACV,
!     &                   CBLK, BLKSIZE, NSPCSDA, NUMCELLS,
!     &                   DT
!     &                  )
      ELSE IF (orgaer==2) THEN
!       IF (firstime) THEN
!         WRITE (6,'(a)')
!         WRITE (6,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
!         WRITE (6,'(a)')
!         WRITE (90,'(a)')
!         WRITE (90,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
!         firstime = .FALSE.
!       END IF
        CALL soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
          orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog, &
          ncv,nacv,cblk,blksize,nspcsda,numcells,dt)
      ELSE
!       WRITE (6,'(a)')
!       WRITE (6,'(a)') 'WRONG PARAMETER ORGAER !!'
!       WRITE (6,90000) orgaer
!       WRITE (6,'(a)') 'PROGRAM TERMINATED !!'
!       WRITE (6,'(a)')
!       STOP
      END IF
!bs
!bs      ORGARO1RAT(1) = 0.
!bs      ORGARO2RAT(1) = 0.
!bs      ORGALK1RAT(1) = 0.
!bs      ORGOLE1RAT(1) = 0.
!bs      ORGBIO1RAT(1) = 0.
!bs      ORGBIO2RAT(1) = 0.
!bs      ORGBIO3RAT(1) = 0.
!bs      ORGBIO4RAT(1) = 0.
!bs      WRITE(6,'(a)') '!!! ORGRATs SET TO 0. !!!'
!bs
!bs * formats
!bs
90000 FORMAT ('ORGAER = ',I2)
!bs
!bs * end of SR SORGAM
!bs
      RETURN
    END SUBROUTINE sorgam
!****************************************************************
!
!
!
!
! ///////////////////////////////
! *** this routine calculates the dry deposition and sedimentation 
!     velocities for the three modes. 
!     coded 1/23/97 by Dr. Francis S. Binkowski. Follows 
!     FSB's original method, i.e. uses Jon Pleim's expression for deposition
!     velocity but includes Marv Wesely's wstar contribution. 
!ia eliminated Stokes term for coarse mode deposition calcs.,
!ia see comments below
 
       SUBROUTINE VDVG(  BLKSIZE, NSPCSDA, NUMCELLS,           &
                     LAYER,                                    &
                     CBLK,                                     &  
                     BLKTA, BLKDENS, RA, USTAR, WSTAR,  AMU,   &
                     DGNUC, DGACC, DGCOR,                      &
                     KNNUC, KNACC,KNCOR,                       &    
                     PDENSN, PDENSA, PDENSC,                   &                 
                     VSED, VDEP )

! *** calculate size-averaged particle dry deposition and 
!     size-averaged sedimentation velocities.

!     IMPLICIT NONE

      INTEGER BLKSIZE                  ! dimension of arrays
      INTEGER NSPCSDA                  ! number of species in CBLK
      INTEGER NUMCELLS                ! actual number of cells in arrays 
      INTEGER LAYER                   ! number of layer

      REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables      
      REAL BLKTA( BLKSIZE )         ! Air temperature [ K ]
      REAL BLKDENS(BLKSIZE) ! Air density  [ kg m^-3 ]      
      REAL RA(BLKSIZE )             ! aerodynamic resistance [ s m**-1 ]
      REAL USTAR( BLKSIZE )         ! surface friction velocity [ m s**-1 ]
      REAL WSTAR( BLKSIZE )         ! convective velocity scale [ m s**-1 ]
      REAL AMU( BLKSIZE )           ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
      REAL DGNUC( BLKSIZE )         ! nuclei mode mean diameter [ m ]
      REAL DGACC( BLKSIZE )         ! accumulation  
      REAL DGCOR( BLKSIZE )         ! coarse mode
      REAL KNNUC( BLKSIZE )         ! nuclei mode Knudsen number 
      REAL KNACC( BLKSIZE )         ! accumulation  
      REAL KNCOR( BLKSIZE )         ! coarse mode
      REAL PDENSN( BLKSIZE )        ! average particel density in nuclei mode [ kg / m**3 ]
      REAL PDENSA( BLKSIZE )        ! average particel density in accumulation mode [ kg / m**3 ]
      REAL PDENSC( BLKSIZE )        ! average particel density in coarse mode [ kg / m**3 ]
       

! *** modal particle diffusivities for number and 3rd moment, or mass:

      REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
      REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)

! *** modal sedimentation velocities for number and 3rd moment, or mass:
      
      REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
      REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)

! *** deposition and sedimentation velocities

      REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
      REAL VSED( BLKSIZE, NASPCSSED)  ! deposition  velocity [ m s**-1 ]
      
      
      INTEGER LCELL
      REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
      REAL DCONST2, DCONST3N, DCONST3A,DCONST3C 
      REAL SC0N, SC0A, SC0C ! Schmidt numbers for number 
      REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
      REAL ST0N, ST0A, ST0C ! Stokes numbers for number 
      REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
      REAL RD0N, RD0A, RD0C    ! canopy resistance for number
      REAL RD3N, RD3A, RD3C    ! canopy resisteance for 3rd moment 
      REAL UTSCALE   ! scratch function of USTAR and WSTAR.
      REAL NU        !kinematic viscosity [ m**2 s**-1 ]     
      REAL USTFAC      ! scratch function of USTAR, NU, and GRAV
      REAL BHAT
      PARAMETER( BHAT =  1.246 ) ! Constant from Cunningham slip correction.

! *** check layer value. 

         IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and 
!                                    sedimentation velocities         
	        
         DO LCELL = 1, NUMCELLS
         
            DCONST1 = BOLTZ * BLKTA(LCELL) /                                         &
                    ( THREEPI * AMU(LCELL) )
            DCONST1N = DCONST1 / DGNUC( LCELL ) 
            DCONST1A = DCONST1 / DGACC( LCELL )
            DCONST1C = DCONST1 / DGCOR( LCELL )   
            DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
            DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
            DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
            DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2

! *** i-mode 
 
            DCHAT0N(LCELL) =  DCONST1N                             &
               * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
                
            DCHAT3N(LCELL) =  DCONST1N                             &
               * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
            
            VGHAT0N(LCELL) = DCONST3N                             &
               * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
                
            VGHAT3N(LCELL) = DCONST3N                             &
               * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )

! *** j-mode

            DCHAT0A(LCELL) =  DCONST1A                             &
              * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
                
            DCHAT3A(LCELL) =  DCONST1A                             &
               * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )           
            
            VGHAT0A(LCELL) = DCONST3A                             &
              * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
                
            VGHAT3A(LCELL) = DCONST3A                             &
              * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )

! *** coarse mode

            DCHAT0C(LCELL)=  DCONST1C                             &
              * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
                
            DCHAT3C(LCELL) = DCONST1C                             &
              * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
            
            VGHAT0C(LCELL) = DCONST3C                             &
              * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
                
            VGHAT3C(LCELL) = DCONST3C                             &
              * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
        
        END DO
 
! *** now calculate the deposition and sedmentation velocities

!ia  07.05.98 
! *** NOTE In the deposition velocity for coarse mode,
!     the impaction term  10.0 ** (-3.0 / st) is eliminated because
!     coarse particles are likely to bounce on impact and the current
!     formulation does not account for this.

        DO LCELL = 1, NUMCELLS
        
         NU = AMU(LCELL) / BLKDENS(LCELL) 
         USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
         UTSCALE = USTAR(LCELL) +                             &
                 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)

! *** first do number   
           
! *** nuclei or Aitken mode  ( no sedimentation velocity )      

        SC0N = NU / DCHAT0N(LCELL)      
        ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
        RD0N = 1.0 / ( UTSCALE *                             &
                  ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) ) 
      
        VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) +                             &
               1.0 / (                             &
           RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )

        VSED( LCELL, VSNNUC) = VGHAT0N(LCELL) 
     
! *** accumulation mode

        SC0A = NU / DCHAT0A(LCELL)      
        ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
        RD0A = 1.0 / ( UTSCALE *                             &
                  ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) ) 
      
        VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) +                             &
               1.0 / (                             &
           RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) ) 

        VSED( LCELL, VSNACC) = VGHAT0A(LCELL) 

! *** coarse mode 

        SC0C = NU / DCHAT0C(LCELL)      
!ia        ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
!ia        RD0C = 1.0 / ( UTSCALE * 
!ia     &            ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) ) 
 
         RD0C = 1.0 / ( UTSCALE *                            &
                      ( SC0C ** ( -TWO3 )  ) ) ! eliminate impaction term
      
        VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) +                             &
               1.0 / (                             &
           RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) ) 

        VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) 

! *** now do m3 for the deposition of mass 

! *** nuclei or Aitken mode  

        SC3N = NU / DCHAT3N(LCELL)      
        ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01) 
        RD3N = 1.0 / ( UTSCALE *                             &
                  ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) ) 
      
        VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) +                             &
               1.0 / (                             &
           RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) ) 

        VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
     
! *** accumulation mode

        SC3A = NU / DCHAT3A(LCELL)      
        ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
        RD3A = 1.0 / ( UTSCALE *                             &
                  ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) ) 

       VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) +                            &
               1.0 / (                            &
               RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
                
     
! *** fine mass deposition velocity: combine Aitken and accumulation 
!     mode deposition velocities. Assume density is the same
!     for both modes.

!       VDEP(LCELL,VDMFINE) = ( 
!    &    CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) + 
!    &    CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) / 
!    &    ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) ) 
     
 
! *** fine mass sedimentation velocity

!       VSED( LCELL, VSMFINE) = (
!    &    CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + 
!    &     CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
!    &    ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3)  )     

        VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)

! *** coarse mode 

        SC3C = NU / DCHAT3C(LCELL)
!ia        ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
!ia        RD3C = 1.0 / ( UTSCALE * 
!ia     &            ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) ) 
   
        RD3C = 1.0 / ( UTSCALE *                            &
                     ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term   
        VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) +                             &
               1.0 / (                             &
           RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL)) 

! *** coarse mode sedmentation velocity

        VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) 

                                 
        END DO  
             
        ELSE   ! LAYER greater than 1
        
! *** for layer greater than 1 calculate  sedimentation velocities only 

         DO LCELL = 1, NUMCELLS
         
            DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
            
            DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
            DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
            DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2

            VGHAT0N(LCELL) = DCONST3N                             &
               * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
               
! *** nucleation mode number sedimentation velocity

            VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
 
            VGHAT3N(LCELL) = DCONST3N                             &
               * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )

! *** nucleation mode volume sedimentation velocity

	    VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)

            VGHAT0A(LCELL) = DCONST3A                             &
              * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )

! *** accumulation mode number sedimentation velocity
     
            VSED( LCELL, VSNACC) = VGHAT0A(LCELL)      
                
            VGHAT3A(LCELL) = DCONST3A                            & 
              * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
     
! *** fine mass sedimentation velocity

!           VSED( LCELL, VSMFINE) = (
!    &       CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + 
!    &        CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
!    &       ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3)  )     

            VSED( LCELL, VSMACC) = VGHAT3A(LCELL)     
         
            VGHAT0C(LCELL) = DCONST3C                            & 
              * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )

! *** coarse mode sedimentation velocity
     
            VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) 
       
                
            VGHAT3C(LCELL) = DCONST3C                             &
              * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )

! *** coarse mode mass sedimentation velocity

            VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) 
        
         END DO 
         
         END IF ! check on layer 
         
END SUBROUTINE vdvg
!
!
    SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w,             &
         pm2_5_dry,pm2_5_water,pm2_5_dry_ec,                         &
         chem_in_opt,aer_ic_opt, is_aerosol,                         &
         ids,ide, jds,jde, kds,kde,                                  &
         ims,ime, jms,jme, kms,kme,                                  &
         its,ite, jts,jte, kts,kte                                   )
   implicit none
   INTEGER,      INTENT(IN   ) :: chem_in_opt,aer_ic_opt
   INTEGER,      INTENT(IN   ) ::                               &
                                  ids,ide, jds,jde, kds,kde,    &
                                  ims,ime, jms,jme, kms,kme,    &
                                  its,ite, jts,jte, kts,kte
   LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) ,     &
          INTENT(INOUT   ) ::                                      &
                              chem
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
          INTENT(INOUT      ) ::                                   &
                     pm2_5_dry,pm2_5_water,pm2_5_dry_ec
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
          INTENT(IN      ) ::                                      &
                   convfac
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ) ,               &
          INTENT(IN         ) ::                                   &
                     z_at_w
     integer i,j,k,l,ii,jj,kk     
     real tempfac,mwso4,zz
!    real,dimension(its:ite,kts:kte,jts:jte) :: convfac
      REAL splitfac
                        !between gas and aerosol phase
      REAL so4vaptoaer
!factor for splitting initial conc. of SO4
!3rd moment i-mode [3rd moment/m^3]
      REAL m3nuc
!3rd MOMENT j-mode [3rd moment/m^3]
      REAL m3acc
!       REAL ESN36
      REAL m3cor
      DATA splitfac/.98/
      DATA so4vaptoaer/.999/
      integer iphase,itype
      integer ll, n, p1st

        nphase_aer = 1
	if(p_so4cwj.ge. param_first_scalar) then
           nphase_aer = 2
	endif
        ntype_aer = 3
	nsize_aer(:)=1
	ai_phase=-999888777
	cw_phase=-999888777
	ci_phase=-999888777
	cr_phase=-999888777
	cs_phase=-999888777
	cg_phase=-999888777
	if(nphase_aer>=1)ai_phase=1
	if(nphase_aer>=2)cw_phase=2
	if(nphase_aer>=3)cr_phase=3
	if(nphase_aer>=4)ci_phase=4
	if(nphase_aer>=5)cw_phase=5
	if(nphase_aer>=6)cg_phase=6
	msectional = 0
	maerosolincw = 0
#if defined ( cw_species_are_in_registry )
	maerosolincw = 1
#endif
	name_mastercomp_aer( 1) = 'sulfate'
	dens_mastercomp_aer( 1) = dens_so4_aer
	mw_mastercomp_aer(   1) =   mw_so4_aer
	hygro_mastercomp_aer(1) = hygro_so4_aer

	name_mastercomp_aer( 2) = 'nitrate'
	dens_mastercomp_aer( 2) = dens_no3_aer
	mw_mastercomp_aer(   2) =   mw_no3_aer
	hygro_mastercomp_aer(2) = hygro_no3_aer

	name_mastercomp_aer( 3) = 'ammonium'
	dens_mastercomp_aer( 3) = dens_nh4_aer
	mw_mastercomp_aer(   3) =   mw_nh4_aer
	hygro_mastercomp_aer(3) = hygro_nh4_aer

	name_mastercomp_aer( 4) = 'orgaro1'
	dens_mastercomp_aer( 4) = dens_oc_aer
	mw_mastercomp_aer(   4) =   mw_oc_aer
	hygro_mastercomp_aer(4) = hygro_oc_aer

	name_mastercomp_aer( 5) = 'orgaro2'
	dens_mastercomp_aer( 5) = dens_oc_aer
	mw_mastercomp_aer(   5) =   mw_oc_aer
	hygro_mastercomp_aer(5) = hygro_oc_aer

	name_mastercomp_aer( 6) = 'orgalk'
	dens_mastercomp_aer( 6) = dens_oc_aer
	mw_mastercomp_aer(   6) =   mw_oc_aer
	hygro_mastercomp_aer(6) = hygro_oc_aer

	name_mastercomp_aer( 7) = 'orgole'
	dens_mastercomp_aer( 7) = dens_oc_aer
	mw_mastercomp_aer(   7) =   mw_oc_aer
	hygro_mastercomp_aer(7) = hygro_oc_aer

	name_mastercomp_aer( 8) = 'orgba1'
	dens_mastercomp_aer( 8) = dens_oc_aer
	mw_mastercomp_aer(   8) =   mw_oc_aer
	hygro_mastercomp_aer(8) = hygro_oc_aer

	name_mastercomp_aer( 9) = 'orgba2'
	dens_mastercomp_aer( 9) = dens_oc_aer
	mw_mastercomp_aer(   9) =   mw_oc_aer
	hygro_mastercomp_aer(9) = hygro_oc_aer

	name_mastercomp_aer( 10) = 'orgba3'
	dens_mastercomp_aer( 10) = dens_oc_aer
	mw_mastercomp_aer(   10) =   mw_oc_aer
	hygro_mastercomp_aer(10) = hygro_oc_aer

	name_mastercomp_aer( 11) = 'orgba4'
	dens_mastercomp_aer( 11) = dens_oc_aer
	mw_mastercomp_aer(   11) =   mw_oc_aer
	hygro_mastercomp_aer(11) = hygro_oc_aer

	name_mastercomp_aer( 12) = 'orgpa'
	dens_mastercomp_aer( 12) = dens_oc_aer
	mw_mastercomp_aer(   12) =   mw_oc_aer
	hygro_mastercomp_aer(12) = hygro_oc_aer

	name_mastercomp_aer( 13) = 'ec'
	dens_mastercomp_aer( 13) = dens_ec_aer
	mw_mastercomp_aer(   13) =   mw_ec_aer
	hygro_mastercomp_aer(13) = hygro_ec_aer

	name_mastercomp_aer( 14) = 'p25'
	dens_mastercomp_aer( 14) = dens_so4_aer
	mw_mastercomp_aer(   14) =   mw_so4_aer + mw_nh4_aer
	hygro_mastercomp_aer(14) = hygro_so4_aer + hygro_nh4_aer

	name_mastercomp_aer( 15) = 'anth'
	dens_mastercomp_aer( 15) = dens_so4_aer
	mw_mastercomp_aer(   15) =   mw_so4_aer + mw_nh4_aer
	hygro_mastercomp_aer(15) = hygro_so4_aer + hygro_nh4_aer

	name_mastercomp_aer( 16) = 'seas'
	dens_mastercomp_aer( 16) = dens_seas_aer
	mw_mastercomp_aer(   16) =   mw_seas_aer
	hygro_mastercomp_aer(16) = hygro_seas_aer

	name_mastercomp_aer( 17) = 'soil'
	dens_mastercomp_aer( 17) = dens_ca_aer
	mw_mastercomp_aer(   17) =  mw_ca_aer + mw_co3_aer
	hygro_mastercomp_aer(17) = hygro_ca_aer + hygro_co3_aer

	lptr_so4_aer(:,:,:)      = 1
	lptr_nh4_aer(:,:,:)      = 1
	lptr_no3_aer(:,:,:)      = 1
	lptr_orgaro1_aer(:,:,:)  = 1
	lptr_orgaro2_aer(:,:,:)  = 1
	lptr_orgalk_aer(:,:,:)  = 1
	lptr_orgole_aer(:,:,:)  = 1
	lptr_orgba1_aer(:,:,:)  = 1
	lptr_orgba2_aer(:,:,:)  = 1
	lptr_orgba3_aer(:,:,:)  = 1
	lptr_orgba4_aer(:,:,:)  = 1
	lptr_orgpa_aer(:,:,:)  = 1
	lptr_ec_aer(:,:,:)  = 1
	lptr_p25_aer(:,:,:)  = 1
	lptr_anth_aer(:,:,:) = 1
	lptr_seas_aer(:,:,:) = 1
	lptr_soil_aer(:,:,:) = 1
	numptr_aer(:,:,:)          = 1

! Accumulation mode
	ncomp_aer(1) = 14
      	  lptr_so4_aer(1,1,ai_phase)= p_so4aj
      	  lptr_nh4_aer(1,1,ai_phase) = p_nh4aj
      	  lptr_no3_aer(1,1,ai_phase) = p_no3aj
      	  lptr_orgaro1_aer(1,1,ai_phase) = p_orgaro1j
      	  lptr_orgaro2_aer(1,1,ai_phase) = p_orgaro2j
      	  lptr_orgalk_aer(1,1,ai_phase) = p_orgalk1j
      	  lptr_orgole_aer(1,1,ai_phase) = p_orgole1j
      	  lptr_orgba1_aer(1,1,ai_phase) = p_orgba1j
      	  lptr_orgba2_aer(1,1,ai_phase) = p_orgba2j
      	  lptr_orgba3_aer(1,1,ai_phase) = p_orgba3j
      	  lptr_orgba4_aer(1,1,ai_phase) = p_orgba4j
      	  lptr_orgpa_aer(1,1,ai_phase) = p_orgpaj
      	  lptr_ec_aer(1,1,ai_phase) = p_ecj
      	  lptr_p25_aer(1,1,ai_phase) = p_p25j
	numptr_aer(1,1,ai_phase)          = p_ac0
! Aitken mode
	ncomp_aer(2) = 14
      	  lptr_so4_aer(1,2,ai_phase)= p_so4ai
      	  lptr_nh4_aer(1,2,ai_phase) = p_nh4ai
      	  lptr_no3_aer(1,2,ai_phase) = p_no3ai
      	  lptr_orgaro1_aer(1,2,ai_phase) = p_orgaro1i
      	  lptr_orgaro2_aer(1,2,ai_phase) = p_orgaro2i
      	  lptr_orgalk_aer(1,2,ai_phase) = p_orgalk1i
      	  lptr_orgole_aer(1,2,ai_phase) = p_orgole1i
      	  lptr_orgba1_aer(1,2,ai_phase) = p_orgba1i
      	  lptr_orgba2_aer(1,2,ai_phase) = p_orgba2i
      	  lptr_orgba3_aer(1,2,ai_phase) = p_orgba3i
      	  lptr_orgba4_aer(1,2,ai_phase) = p_orgba4i
      	  lptr_orgpa_aer(1,2,ai_phase) = p_orgpai
      	  lptr_ec_aer(1,2,ai_phase) = p_eci
      	  lptr_p25_aer(1,2,ai_phase) = p_p25i
	numptr_aer(1,2,ai_phase)          = p_nu0
! coarse mode
	ncomp_aer(3) = 3
          lptr_anth_aer(1,3,ai_phase) = p_antha
      	  lptr_seas_aer(1,3,ai_phase) = p_seas
      	  lptr_soil_aer(1,3,ai_phase) = p_soila
	numptr_aer(1,3,ai_phase)          = p_corn
! aerosol in cloud water
        if(cw_phase.gt.0)then
! Accumulation mode
      	  lptr_so4_aer(1,1,cw_phase)= p_so4cwj
      	  lptr_nh4_aer(1,1,cw_phase) = p_nh4cwj
      	  lptr_no3_aer(1,1,cw_phase) = p_no3cwj
      	  lptr_orgaro1_aer(1,1,cw_phase) = p_orgaro1cwj
      	  lptr_orgaro2_aer(1,1,cw_phase) = p_orgaro2cwj
      	  lptr_orgalk_aer(1,1,cw_phase) = p_orgalk1cwj
      	  lptr_orgole_aer(1,1,cw_phase) = p_orgole1cwj
      	  lptr_orgba1_aer(1,1,cw_phase) = p_orgba1cwj
      	  lptr_orgba2_aer(1,1,cw_phase) = p_orgba2cwj
      	  lptr_orgba3_aer(1,1,cw_phase) = p_orgba3cwj
      	  lptr_orgba4_aer(1,1,cw_phase) = p_orgba4cwj
      	  lptr_orgpa_aer(1,1,cw_phase) = p_orgpacwj
      	  lptr_ec_aer(1,1,cw_phase) = p_eccwj
      	  lptr_p25_aer(1,1,cw_phase) = p_p25cwj
	numptr_aer(1,1,cw_phase)          = p_ac0cw
! Aitken mode
      	  lptr_so4_aer(1,2,cw_phase)= p_so4cwi
      	  lptr_nh4_aer(1,2,cw_phase) = p_nh4cwi
      	  lptr_no3_aer(1,2,cw_phase) = p_no3cwi
      	  lptr_orgaro1_aer(1,2,cw_phase) = p_orgaro1cwi
      	  lptr_orgaro2_aer(1,2,cw_phase) = p_orgaro2cwi
      	  lptr_orgalk_aer(1,2,cw_phase) = p_orgalk1cwi
      	  lptr_orgole_aer(1,2,cw_phase) = p_orgole1cwi
      	  lptr_orgba1_aer(1,2,cw_phase) = p_orgba1cwi
      	  lptr_orgba2_aer(1,2,cw_phase) = p_orgba2cwi
      	  lptr_orgba3_aer(1,2,cw_phase) = p_orgba3cwi
      	  lptr_orgba4_aer(1,2,cw_phase) = p_orgba4cwi
      	  lptr_orgpa_aer(1,2,cw_phase) = p_orgpacwi
      	  lptr_ec_aer(1,2,cw_phase) = p_eccwi
      	  lptr_p25_aer(1,2,cw_phase) = p_p25cwi
	numptr_aer(1,2,cw_phase)          = p_nu0cw
! coarse mode
          lptr_anth_aer(1,3,cw_phase) = p_anthcw
      	  lptr_seas_aer(1,3,cw_phase) = p_seascw
      	  lptr_soil_aer(1,3,cw_phase) = p_soilcw
	  numptr_aer(1,3,cw_phase)          = p_corncw
	endif

	massptr_aer(:,:,:,:) = -999888777
	mastercompptr_aer(:,:) = -999888777

	p1st = param_first_scalar

	do iphase=1,nphase_aer
	do itype=1,ntype_aer
	do n = 1, nsize_aer(itype)
	    ll = 0
	    if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 1
	    end if
	    if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 2
	    end if
	    if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 3
	    end if
	    if (lptr_orgaro1_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgaro1_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 4
	    end if
	    if (lptr_orgaro2_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgaro2_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 5
	    end if
	    if (lptr_orgalk_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgalk_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 6
	    end if
	    if (lptr_orgole_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgole_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 7
	    end if
	    if (lptr_orgba1_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgba1_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 8
	    end if
	    if (lptr_orgba2_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgba2_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 9
	    end if
	    if (lptr_orgba3_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgba3_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 10
	    end if
	    if (lptr_orgba4_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgba4_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 11
	    end if
	    if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 12
	    end if
	    if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 13
	    end if
	    if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 14
	    end if
	    if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 15
	    end if
	    if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 16
	    end if
	    if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then
		ll = ll + 1
		massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase)
		mastercompptr_aer(ll,itype) = 17
	    end if
	    ncomp_aer_nontracer(itype) = ll

	    ncomp_aer(itype) = ll

	    mprognum_aer(n,itype,iphase) = 0
	    if (numptr_aer(n,itype,iphase) .ge. p1st) then
		mprognum_aer(n,itype,iphase) = 1
	    end if

	end do ! size
	end do ! type
	end do ! phase
9320	format( a, i1, a, 10x )

        waterptr_aer(:,:) = 0.

	do itype=1,ntype_aer
	do l=1,ncomp_aer(itype)
	   dens_aer(l,itype) = dens_mastercomp_aer(mastercompptr_aer(l,itype))
	   mw_aer(l,itype) = mw_mastercomp_aer(mastercompptr_aer(l,itype))
	   hygro_aer(l,itype) = hygro_mastercomp_aer(mastercompptr_aer(l,itype))
	   name_aer(l,itype) = name_mastercomp_aer(mastercompptr_aer(l,itype))
	end do
	end do

	is_aerosol(:) = .false.
	do iphase=1,nphase_aer
	do itype=1,ntype_aer
	do n = 1, nsize_aer(itype)
	    do ll = 1, ncomp_aer(itype)
	      is_aerosol(massptr_aer(ll,n,itype,iphase))=.true.
	    end do
	    is_aerosol(numptr_aer(n,itype,iphase))=.true.
	end do ! size
	end do ! type
	end do ! phase
        
        pm2_5_dry(its:ite, kts:kte-1, jts:jte)    = 0.
        pm2_5_water(its:ite, kts:kte-1, jts:jte)  = 0.
        pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.

! *** Compute these once and they will all  be saved in COMMON
        xxlsgn = log(sginin)
        xxlsga = log(sginia)
        xxlsgc = log(sginic)

        l2sginin = xxlsgn**2
        l2sginia = xxlsga**2
        l2sginic = xxlsgc**2

        en1 = exp(0.125*l2sginin)
        ea1 = exp(0.125*l2sginia)
        ec1 = exp(0.125*l2sginic)

        dhi_sect(1,1)=1.e2*dginin*exp(l2sginin)
        dlo_sect(1,1)=1.e2*dginin/exp(l2sginin)
        dhi_sect(1,2)=1.e2*dginia*exp(l2sginia)
        dlo_sect(1,2)=1.e2*dginia/exp(l2sginia)
        dhi_sect(1,3)=1.e2*dginic*exp(l2sginic)
        dlo_sect(1,3)=1.e2*dginic/exp(l2sginic)

        sigmag_aer(1,1)=sginin
        sigmag_aer(1,2)=sginia
        sigmag_aer(1,3)=sginic

        esn04 = en1**4
        esa04 = ea1**4
        esc04 = ec1**4

        esn05 = esn04*en1
        esa05 = esa04*ea1

        esn08 = esn04*esn04
        esa08 = esa04*esa04
        esc08 = esc04*esc04

        esn09 = esn04*esn05
        esa09 = esa04*esa05

        esn12 = esn04*esn04*esn04
        esa12 = esa04*esa04*esa04
        esc12 = esc04*esc04*esc04

        esn16 = esn08*esn08
        esa16 = esa08*esa08
        esc16 = esc08*esc08

        esn20 = esn16*esn04
        esa20 = esa16*esa04
        esc20 = esc16*esc04

        esn24 = esn12*esn12
        esa24 = esa12*esa12
        esc24 = esc12*esc12

        esn25 = esn16*esn09
        esa25 = esa16*esa09

        esn28 = esn20*esn08
        esa28 = esa20*esa08
        esc28 = esc20*esc08

        esn32 = esn16*esn16
        esa32 = esa16*esa16
        esc32 = esc16*esc16

        esn36 = esn16*esn20
        esa36 = esa16*esa20
        esc36 = esc16*esc20

        esn49 = esn25*esn20*esn04
        esa49 = esa25*esa20*esa04

        esn52 = esn16*esn36
        esa52 = esa16*esa36

        esn64 = esn32*esn32
        esa64 = esa32*esa32
        esc64 = esc32*esc32

        esn100 = esn36*esn64

        esnm20 = 1.0/esn20
        esam20 = 1.0/esa20
        escm20 = 1.0/esc20

        esnm32 = 1.0/esn32
        esam32 = 1.0/esa32
        escm32 = 1.0/esc32

        xxm3 = 3.0*xxlsgn/ sqrt2
! factor used in error function cal
        nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)

        nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)

        nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)

! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
!     size distribution , then

!        vol = (p/6) * density * num * (dgemv_xx**3) *
!                            exp(- 4.5 * log( sgem_xx)**2 ) )
!        note minus sign!!

        factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
        factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
        factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
        ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
        ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
        mwso4=96.03
!
!
!  IF USING OLD SIMULATION, DO NOT REINITIALIZE!
!
!
        if(chem_in_opt == 1 ) return
        do l=p_so4aj,num_chem
         chem(ims:ime,kms:kme,jms:jme,l)=epsilc
        enddo
        chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
        chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
        do j=jts,jte
        jj=min(jde-1,j)
        do k=kts,kte-1
        kk=min(kde-1,k)
        do i=its,ite
        ii=min(ide-1,i)

!Option for alternate ic's
        if( aer_ic_opt == AER_IC_DEFAULT ) then
          chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4*splitfac*so4vaptoaer
          chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4* &
        (1.-splitfac)*so4vaptoaer
          chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
          chem(i,k,j,p_nh4aj) = 10.E-05
          chem(i,k,j,p_nh4ai) = 10.E-05
          chem(i,k,j,p_no3aj) = 10.E-05
          chem(i,k,j,p_no3ai) = 10.E-05
        elseif( aer_ic_opt == AER_IC_PNNL ) then
           zz = (z_at_w(i,k,j)+z_at_w(i,k+1,j))*0.5
           call sorgam_init_aer_ic_pnnl(   &
                chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
        else
           call wrf_error_fatal(   &
                "aerosols_sorgam_init: unable to parse aer_ic_opt" )
        end if

!... i-mode
      m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
        no3fac*chem(i,k,j,p_no3ai) + orgfac*chem(i,k,j,p_orgaro1i) + &
        orgfac*chem(i,k,j,p_orgaro2i) + orgfac*chem(i,k,j,p_orgalk1i) + &
        orgfac*chem(i,k,j,p_orgole1i) + orgfac*chem(i,k,j,p_orgba1i) + &
        orgfac*chem(i,k,j,p_orgba2i) + orgfac*chem(i,k,j,p_orgba3i) + &
        orgfac*chem(i,k,j,p_orgba4i) + orgfac*chem(i,k,j,p_orgpai) + &
        anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)

!... j-mode
      m3acc = so4fac*(chem(i,k,j,p_so4aj)) + nh4fac*(chem(i,k,j,p_nh4aj)) + &
        no3fac*(chem(i,k,j,p_no3aj)) + orgfac*(chem(i,k,j,p_orgaro1j)) + &
        orgfac*(chem(i,k,j,p_orgaro2j)) + orgfac*(chem(i,k,j,p_orgalk1j)) + &
        orgfac*(chem(i,k,j,p_orgole1j)) + orgfac*(chem(i,k,j,p_orgba1j)) + &
        orgfac*(chem(i,k,j,p_orgba2j)) + orgfac*(chem(i,k,j,p_orgba3j)) + &
        orgfac*(chem(i,k,j,p_orgba4j)) + orgfac*(chem(i,k,j,p_orgpaj)) + &
        anthfac*(chem(i,k,j,p_p25j)) + anthfac*(chem(i,k,j,p_ecj))

!...c-mode
      m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
        anthfac*chem(i,k,j,p_antha)

!...NOW CALCULATE INITIAL NUMBER CONCENTRATION
      chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)

      chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
        
      chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)

!jdf, added if statement, don't want to overide specified values for PNNL case
        if( aer_ic_opt == AER_IC_DEFAULT ) then
          chem(i,k,j,p_so4aj)=chem(i,k,j,p_so4aj)
          chem(i,k,j,p_so4ai)=chem(i,k,j,p_so4ai)
          chem(i,k,j,p_nh4aj) = 10.E-05
          chem(i,k,j,p_nh4ai) = 10.E-05
          chem(i,k,j,p_no3aj) = 10.E-05
          chem(i,k,j,p_no3ai) = 10.E-05
        endif
!jdf
        enddo
        enddo
        enddo

    return
    END SUBROUTINE aerosols_sorgam_init

!****************************************************************
!                                                               *
!   SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE           *
!   aer_ic_opt == aer_ic_pnnl OPTION.                           *
!                                                               *
!   wig, 21-Apr-2004, original version	                        *
!   rce, 25-apr-2004 - name changes for consistency with        *
!                          new aer_ic constants in Registry     *
!   wig,  7-May-2004, added height dependance                   *
!                                                               *
!   CALLS THE FOLLOWING SUBROUTINES: NONE                       *
!                                                               *
!   CALLED BY                      : aerosols_sorgam_init       *
!                                                               *
!****************************************************************
    SUBROUTINE sorgam_init_aer_ic_pnnl(                  &
         chem, z, i,k,j, ims,ime, jms,jme, kms,kme              )

      USE module_configure,only:num_chem
      implicit none

      INTEGER,INTENT(IN   ) :: i,k,j,                           &
                               ims,ime, jms,jme, kms,kme
      REAL,  DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),&
           INTENT(INOUT   ) :: chem

      real, intent(in     ) :: z
      real :: mult

!
! Determine height multiplier...
! This should mimic the calculation in sorgam_set_aer_bc_pnnl,
! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic
!!$!    Height(m)     Multiplier
!!$!    ---------     ----------
!!$!    <=2000        1.0
!!$!    2000<z<3000   linear transition zone to 0.5
!!$!    3000<z<5000   linear transision zone to 0.25
!!$!    >=3000        0.25
!!$!
!!$! which translates to:
!!$!    2000<z<3000   mult = 1.0 + (z-2000.)*(0.5-1.0)/(3000.-2000.)
!!$!    3000<z<5000   mult = 0.5 + (z-3000.)*(0.25-0.5)/(5000.-3000.)
!!$! or in reduced form:
!!$      if( z <= 2000. ) then
!!$         mult = 1.0
!!$      elseif( z > 2000. &
!!$           .and. z <= 3000. ) then
!!$         mult = 1.0 - 0.0005*(z-2000.)
!!$      elseif( z > 3000. &
!!$           .and. z <= 5000. ) then
!!$         mult = 0.5 - 1.25e-4*(z-3000.)
!!$      else
!!$         mult = 0.25
!!$      end if
! Updated aerosol profile multiplier 1-Apr-2005:
!    Height(m)     Multiplier
!    ---------     ----------
!    <=2000        1.0
!    2000<z<3000   linear transition zone to 0.25
!    3000<z<5000   linear transision zone to 0.125
!    >=5000        0.125
!
! which translates to:
!    2000<z<3000   mult = 1.00 + (z-2000.)*(0.25-1.0)/(3000.-2000.)
!    3000<z<5000   mult = 0.25 + (z-3000.)*(0.125-0.25)/(5000.-3000.)
! or in reduced form:
        if( z <= 2000. ) then
           mult = 1.0
        elseif( z > 2000. &
             .and. z <= 3000. ) then
           mult = 1.0 - 0.00075*(z-2000.)
        elseif( z > 3000. &
             .and. z <= 5000. ) then
           mult = 0.25 - 4.166666667e-5*(z-3000.)
        else
           mult = 0.125
        end if

! These should match what is in sorgam_set_aer_bc_pnnl.
! Values as of 2-Dec-2004:
      chem(i,k,j,p_sulf)     = mult*conmin
      chem(i,k,j,p_so4aj)    = mult*2.375
      chem(i,k,j,p_so4ai)    = mult*0.179
      chem(i,k,j,p_nh4aj)    = mult*0.9604
      chem(i,k,j,p_nh4ai)    = mult*0.0196
      chem(i,k,j,p_no3aj)    = mult*0.0650
      chem(i,k,j,p_no3ai)    = mult*0.0050
      chem(i,k,j,p_ecj)      = mult*0.1630
      chem(i,k,j,p_eci)      = mult*0.0120
      chem(i,k,j,p_p25j)     = mult*0.6350
      chem(i,k,j,p_p25i)     = mult*0.0490
      chem(i,k,j,p_antha)    = mult*2.2970
      chem(i,k,j,p_orgpaj)   = mult*0.9300
      chem(i,k,j,p_orgpai)   = mult*0.0700
      chem(i,k,j,p_orgaro1j) = conmin
      chem(i,k,j,p_orgaro1i) = conmin
      chem(i,k,j,p_orgaro2j) = conmin
      chem(i,k,j,p_orgaro2i) = conmin
      chem(i,k,j,p_orgalk1j) = conmin
      chem(i,k,j,p_orgalk1i) = conmin
      chem(i,k,j,p_orgole1j) = conmin
      chem(i,k,j,p_orgole1i) = conmin
      chem(i,k,j,p_orgba1j)  = conmin
      chem(i,k,j,p_orgba1i)  = conmin
      chem(i,k,j,p_orgba2j)  = conmin
      chem(i,k,j,p_orgba2i)  = conmin
      chem(i,k,j,p_orgba3j)  = conmin
      chem(i,k,j,p_orgba3i)  = conmin
      chem(i,k,j,p_orgba4j)  = conmin
      chem(i,k,j,p_orgba4i)  = conmin
      chem(i,k,j,p_seas)     = mult*0.229

    END SUBROUTINE sorgam_init_aer_ic_pnnl

END Module module_aerosols_sorgam