       SUBROUTINE  matslipbxds(sig,prop,ln)

c   Bi-Crystal Double-Slip System
C
C-----------------------------------------------------------------------
C
C     DESCRIPTION:
C
C
       use mod_parameters
      REAL phi1,phi2

      common/myvar/a,b,c,e,taur,twomu,xmhigh1,xmhigh2
      common/myvar1/gdotr(2),tau(2)
      common/myvar2/xmhigh3,xmhigh4
      common/myvar3/a01,b1,c1,e1,a02,b2,c2,e2,a03,b3,c3,e3
      common/intgrt/nintg
      common/bk16/maxint,hgc
      common/hokao/lst,nnn2(nume,4)
      common/berg/dels11(nelemg),dels22(nelemg),dels33(nelemg),
     > dels12(nelemg)
      common/vect21/sig11(nelemg),sig22(nelemg),sig33(nelemg),
     > sig12(nelemg)

      common/vect3/
     1 dgi1(nelemg,4),dgi2(nelemg,4),dgi3(nelemg,4),dgi4(nelemg,4),
     > dgi5(nelemg,4),
     2 dgt1(nelemg,4),dgt2(nelemg,4),dgt3(nelemg,4),dgt4(nelemg,4),
     3 f11v(nelemg),f22v(nelemg),f12v(nelemg),f21v(nelemg),
     > dsd5(nelemg),
     4 sig11s(nelemg),sig22s(nelemg),sig33s(nelemg),sig12s(nelemg),
     5 ddp1(nelemg,4),ddp2(nelemg,4),ddp3(nelemg,4),ddp4(nelemg,4),
     > ddp5(nelemg,4)

      common/bk08/kprint,nstep,ite,ilimit,newstf
      common/bk32/nsref,nequit,time,timep,lprint,nprint
      common/meng/
     1 f11dd(nelemg),f22dd(nelemg),f12dd(nelemg),f21dd(nelemg),
     > f33dd(nelemg),
     2 f11dv(nelemg),f22dv(nelemg),f12dv(nelemg),f21dv(nelemg),
     > f33dv(nelemg),
     3 vg11(nelemg),vg22(nelemg),vg12(nelemg),vg21(nelemg),
     > vg33(nelemg),fdet(nelemg),
     4 d1(nelemg),d2(nelemg),d3(nelemg),d4(nelemg),spin(nelemg)

      common/history/his1(nume,4),his2(nume,4),his3(nume,4),
     > his4(nume,4)
     1 ,his5(nume,4),his6(nume,4),his7(nume,4),his8(nume,4),
     > his9(nume,4)
     2 ,his10(nume,4),his11(nume,4),his12(nume,4),his13(nume,4)
     3 ,his14(nume,4),his15(nume,4),his16(nume,4),his17(nume,4)
     4 ,his18(nume,4),his19(nume,4)

      common/hist/abc1(nume,4),abc2(nume,4),abc3(nume,4),
     > abc4(nume,4)
     1 ,abc5(nume,4),abc6(nume,4),abc7(nume,4),abc8(nume,4),
     > abc9(nume,4)
     2 ,abc10(nume,4),abc11(nume,4),abc12(nume,4),abc13(nume,4)
     3 ,abc14(nume,4),abc15(nume,4),abc16(nume,4),abc17(nume,4)
     4 ,abc18(nume,4),abc19(nume,4)

      common/custr/sign1(nelemg),sign2(nelemg),sign3(nelemg),
     > sign4(nelemg)
      common/range/mft,mlt,lft,llt,nftm1
      common/bk26/dt,a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
      common/vect8/dsave(4,4,nelemg)
      common/cccc/ntt
      common/density/denim(4),denm(4),gdot(4)
      common/poutt/nst1,nst2,nst3,nst4
      common/nslipsys/nnns
      common/alamda/alamda1(nume,4),alamda2(nume,4),dnim(4),dnm(4)

      dimension sig(ln,*),p(2,2),p1(2,2),prop(*)
c
      open(30,file='rotation.f',status='unknown')
      open(31,file='sherslip.f',status='unknown')

c.....resolved shear stress(thisis TWO slip systems)
      open(32,file='restrss1.f',status='unknown')
      open(33,file='restrss2.f',status='unknown')
      open(36,file='restress.f',status='unknown')
      open(37,file='sliprat1.f',status='unknown')
      open(38,file='sliprat2.f',status='unknown')
      open(39,file='tempreture.out',status='unknown')

      open(222,file='interface.out',status='unknown')

!      data pi     /3.141592654/
!      data eta    /68.170/
!      data tempr  /1.00/
!      data xi     /0.5/
c
c
ck---------------------------
ck....timep : total time
ck....dt    : time step size
ck....nstep : no. of step
ck....nintg : intergr. point
ck....ntt   : iteration
ck---------------------------

      nnn1=nstep

ck---------------------------------
ck....define total current stresses
ck---------------------------------
      DO 5 i=mft,mlt
        sign1(i) = sig(1,i)
        sign2(i) = sig(2,i)
        sign3(i) = sig(3,i)
        sign4(i) = sig(4,i)
    5 CONTINUE

ck---------------------
ck....define properties
ck---------------------
      tauy    = prop(3)
      gdot01  = prop(5)
      gdot02  = prop(5)
      gdot03  = prop(5)
      gdot04  = prop(5)
      xmhigh1 = prop(4)
      xmhigh2 = prop(4)
      xmhigh3 = prop(4)
      xmhigh4 = prop(4)
      gdotcr  = prop(6)
      ielem   = prop(8)
      nst1    = prop(7)
      nst2    = 2*nst1
      nst3    = 3*nst1
      nst4    = 4*nst1

      IF (nstep.EQ.nst1.OR.nstep.EQ.nst2.OR.nstep.EQ.nst3
     $    .OR.nstep.EQ.nst4) THEN

c          WRITE(30,*) '------------> nstep = ',nstep
c          WRITE(31,*) '------------> nstep = ',nstep
c          WRITE(32,*) '------------> nstep = ',nstep
c          WRITE(33,*) '------------> nstep = ',nstep
c          WRITE(36,*) '------------> nstep = ',nstep
c          WRITE(37,*) '------------> nstep = ',nstep
c          WRITE(38,*) '------------> nstep = ',nstep
c          WRITE(39,*) '------------> nstep = ',nstep

      ENDIF

ck
      DO 10 i=mft,mlt

        ink=i+nftm1

ck---------------------------------
ck....define deviatoric deformation
ck---------------------------------
        traced=d1(i)+d2(i)+d3(i)
        dd1=d1(i)-traced/3.00
        dd2=d2(i)-traced/3.00
        dd3=d3(i)-traced/3.00
        dd4=d4(i)

ck------------------------------
ck....define deviatoric stresses
ck------------------------------
        press=(sign1(i)+sign2(i)+sign3(I))/3.00
        sdev1=sign1(i)-press
        sdev2=sign2(i)-press
        sdev3=sign3(i)-press
        sdev4=sign4(i)

ck-------------------------------------------------------
ck....update internal variables for multiple slip systems
ck-------------------------------------------------------
        IF(nnn1.eq.nnn2(ink,nintg)) THEN

           chi    = abc1(ink,nintg)*pi/180.0
           gamma  = abc2(ink,nintg)
           tau(1) = abc3(ink,nintg)
           tau(2) = abc4(ink,nintg)
           taur   = abc7(ink,nintg)
           gdot(1)= abc8(ink,nintg)
           gdot(2)= abc9(ink,nintg)
           temp   = (abc10(ink,nintg)+273.0)/293.0
           temp   = max(temp,tempr)

        ELSE

           chi    = abc1(ink,nintg)*pi/180.0
           gamma  = abc2(ink,nintg)
           tau(1) = abc3(ink,nintg)
           tau(2) = abc4(ink,nintg)
           taur   = abc7(ink,nintg)
           gdot(1)= abc8(ink,nintg)
           gdot(2)= abc9(ink,nintg)
           temp   = (abc10(ink,nintg)+273.0)/293.0
           temp   = max(temp,tempr)

ck
           abc1(ink,nintg)  = his1(ink,nintg)
           abc2(ink,nintg)  = his2(ink,nintg)
           abc3(ink,nintg)  = his3(ink,nintg)
           abc4(ink,nintg)  = his4(ink,nintg)
           abc7(ink,nintg)  = his7(ink,nintg)
           abc8(ink,nintg)  = his8(ink,nintg)
           abc9(ink,nintg)  = his9(ink,nintg)
           abc10(ink,nintg) = his10(ink,nintg)

           abc11(ink,nintg) = abc10(ink,nintg)/20.

ck---------------------------------------------------
ck....printout internal variables for current contour
ck---------------------------------------------------
       IF (nstep.eq.nst1.OR.nstep.eq.nst2.OR.nstep.eq.nst3
     $.OR.nstep.eq.nst4) THEN

c//---
c// Only to print out the angles to the file <interface.out>
c//
           IF(ink.EQ.2) THEN
              write(222,10020) (180.*phi1/pi),(180.*phi2/pi)
           ELSEIF(ink.EQ.(ielem+2)) THEN
              write(222,10021) (180.*phi1/pi),(180.*phi2/pi)
           ENDIF

           WRITE(30,1001) abc1(ink,nintg)
           WRITE(31,1001) abc2(ink,nintg)
           WRITE(32,1001) abc3(ink,nintg)
           WRITE(33,1001) abc4(ink,nintg)
           WRITE(36,1001) abc7(ink,nintg)
           WRITE(37,1001) abc8(ink,nintg)
           WRITE(38,1001) abc9(ink,nintg)
           WRITE(39,1001) abc11(ink,nintg)

           IF((ink.GE.71).AND.(ink.LE.80)) THEN
             WRITE(222,*) '    '
             WRITE(222,*) '==> Element No. :',ink
             WRITE(222,*) '-------------------------'
             WRITE(222,10011) abc1(ink,nintg)
             WRITE(222,10012) abc2(ink,nintg)
             WRITE(222,10013) abc3(ink,nintg)
             WRITE(222,10014) abc4(ink,nintg)
             WRITE(222,10015) abc7(ink,nintg)
             WRITE(222,10016) abc8(ink,nintg)
             WRITE(222,10017) abc9(ink,nintg)
             WRITE(222,10018) abc11(ink,nintg)
             WRITE(222,*) '    '
             WRITE(222,*) '    '
          ENDIF

 1001    FORMAT(5x,e15.8)
10011    FORMAT('Rotation ............................ = ',e15.8)
10012    FORMAT('Accumulated plastic shear strain .....= ',e15.8)
10013    FORMAT('Resolved shear stress for slip (1) .. = ',e15.8)
10014    FORMAT('Resolved shear stress for slip (2) .. = ',e15.8)
10015    FORMAT('Reference shear stress .............. = ',e15.8)
10016    FORMAT('Shear strain (slip) rate for slip (1) = ',e15.8)
10017    FORMAT('Shear strain (slip) rate for slip (2) = ',e15.8)
10018    FORMAT('Current temp. of solid (T) / Tr ..... = ',e15.8)

10020    FORMAT('Crystal (A): phi(1) = ',f6.2,' ; phi(2) = ',f6.2)
10021    FORMAT('Crystal (B): phi(1) = ',f6.2,' ; phi(2) = ',f6.2)

       ENDIF

      ENDIF

ck-------------------------------------------
ck....define initial angles from loading axis
ck-------------------------------------------
ck....single crystal case :
ck      if(ink.eq.1) then
ck....bicrystal case :

      IF(ink.le.ielem) THEN
         phi1   = (pi/180.0)*35.0
         phi2   = (pi/180.0)*35.0

         ym     = prop(1)
         g      = prop(1)/(2.0*(1.0+prop(2)))
         twomu  = g*2.0
         proppp = prop(1)/(3.*(1.-2.*prop(2)))
         alamdt = proppp*dt

      ELSE

         phi1   = (pi/180.0)*35.0
         phi2   = (pi/180.0)*35.0

         ym     = prop(49)
         g      = prop(49)/(2.0*(1.0+prop(2)))
         twomu  = g*2.0
         proppp = prop(49)/(3.*(1.-2.*prop(2)))
         alamdt = proppp*dt

      ENDIF

ck---------------------------------------
ck....compute tangent constitutive matrix
ck---------------------------------------
ck....single crystal case :
ck      if(ink.eq.1) then
ck....bicrystal case :

      IF(ink.le.ielem) THEN
         dsave(1,1,i) = prop(10)
         dsave(1,2,i) = prop(11)
         dsave(1,3,i) = prop(11)
         dsave(1,4,i) = 0.
         dsave(2,1,i) = prop(11)
         dsave(2,2,i) = prop(10)
         dsave(2,3,1) = prop(11)
         dsave(2,4,i) = 0.
         dsave(3,1,i) = prop(11)
         dsave(3,2,i) = prop(11)
         dsave(3,3,i) = prop(10)
         dsave(3,4,i) = 0.
         dsave(4,1,i) = 0.
         dsave(4,2,i) = 0.
         dsave(4,3,i) = 0.
         dsave(4,4,i) = prop(25)
      ELSE
         dsave(1,1,i) = prop(58)
         dsave(1,2,i) = prop(59)
         dsave(1,3,i) = prop(59)
         dsave(1,4,i) = 0.
         dsave(2,1,i) = prop(59)
         dsave(2,2,i) = prop(58)
         dsave(2,3,1) = prop(59)
         dsave(2,4,i) = 0.
         dsave(3,1,i) = prop(59)
         dsave(3,2,i) = prop(59)
         dsave(3,3,i) = prop(58)
         dsave(3,4,i) = 0.
         dsave(4,1,i) = 0.
         dsave(4,2,i) = 0.
         dsave(4,3,i) = 0.
         dsave(4,4,i) = prop(73)
      ENDIF

ck--------------------------
ck....check if gdot > gdotcr
ck--------------------------
      IF(gdot(1).ge.gdotcr) THEN
         xmhigh1 = 1.00
         gdot01  = gdotcr
      ENDIF

      IF(gdot(2).ge.gdotcr) THEN
         xmhigh2 = 1.00
         gdot02  = gdotcr
      ENDIF

ck--------------------------------------
ck....calculate Pij for each slip system
ck--------------------------------------
ck....single crystal case :
ck      if(ink.eq.1) then
ck....bicrystal case :

      IF(ink.le.ielem) THEN
         angl1  = (phi1-chi)
         angl2  = (phi2+chi)

         c2t  = cos(2.0*angl1)
         s2t  = sin(2.0*angl1)
         c2t1 = cos(2.0*angl2)
         s2t1 = sin(2.0*angl2)

ck....slip system 1 :
         p(1,1)  = -s2t/2.0
         p(1,2)  = -c2t/2.0
         p(2,2)  = s2t/2.0
         wp      = 0.5

ck....slip system 2 :
         p1(1,1) = -s2t1/2.0
         p1(1,2) = c2t1/2.0
         p1(2,2) = s2t1/2.0
         wp1     = -0.5

      ELSE

         angl1  = (phi1-chi)
         angl2  = (phi2+chi)

         c2t  = cos(2.0*angl1)
         s2t  = sin(2.0*angl1)
         c2t1 = cos(2.0*angl2)
         s2t1 = sin(2.0*angl2)

ck....slip system 1 :
         p(1,1) = -s2t/2.0
         p(1,2) = -c2t/2.0
         p(2,2) =  s2t/2.0
         wp     =  0.5

ck....slip system 2 :
        p1(1,1) = -s2t1/2.0
        p1(1,2) =  c2t1/2.0
        p1(2,2) =  s2t1/2.0
        wp1     = -0.5

      ENDIF

ck----------------------------------------
ck....perform multiplication of DDK*P(I,J)
ck----------------------------------------

      gdotr(1) = dd1*p(1,1)+dd2*p(2,2)+2.*dd4*p(1,2)
      gdotr(2) = dd1*p1(1,1)+dd2*p1(2,2)+2.*dd4*p1(1,2)

ck-------------------------
ck....define hardening laws
ck-------------------------
C:------>>
c.... corection factor for the tempr
       corfctr = (tempr/temp)**xi

ck....power laws :
       taur=tauy*((100.0*gamma+1.0)**0.1)

ck....hyberbolic hardening laws :
c       taur=tauy+(0.8*tauy*tanh(11.125*gamma))

ck....hyberbolic hardening (including thermal effects) :
ck      x=(tempr/temp)**v
ck      taur=tauy+(0.8*tauy*tanh(11.125*gamma))*x

ck....hardening from dislocation evolution :
C      taur=0.976923e-03+0.5*g*bv*(denim(1)**0.5+denim(2)**0.5
C     $+denim(3)**0.5+denim(4)**0.5)

ck------------------------------------------------------------
ck....define coefficients for nonlinear differential equations
ck....(obtain tau(i), i=1,12 for f.c.c.)
ck------------------------------------------------------------

      a = gdot01*(p(1,1)*p(1,1)+p(2,2)*p(2,2)+
     #    2.0*p(1,2)*p(1,2))
      b = gdot02*(p(1,1)*p1(1,1)+p(2,2)*p1(2,2)
     #    +2.0*p(1,2)*p1(1,2))
      c = gdot01*(p1(1,1)*p(1,1)+p1(2,2)*p(2,2)
     #    +2.0*p1(1,2)*p(1,2))
      e = gdot02*(p1(1,1)*p1(1,1)
     #    +p1(2,2)*p1(2,2)+2.0*p1(1,2)*p1(1,2))

ck--------------------------------------
ck
      IF (nstep.ne.0.and. ntt.eq.1) THEN
         timexx = timep-dt
      ELSE
         timexx = timep
      ENDIF

ck--------------------------------------

      CALL m2dsolve(dt,timexx)

ck--------------------------------------------------------
ck....calculate shear strain (shear strain should have the
ck....same sign as the resolved shear stress)
ck--------------------------------------------------------
      sat    = 1.0/1.00
      gdot(1)=gdot01*((abs(tau(1)/taur)*sat)**(xmhigh1-1.))
     1        *(tau(1)/taur)*sat
      gdot(2)=gdot02*((abs(tau(2)/taur)*sat)**(xmhigh2-1.))
     1        *(tau(2)/taur)*sat

c      write(7777,*) '- gdot(1): ', gdot(1)
c      write(7777,*) '- gdot(2): ', gdot(2)

ck-----------------------------------
ck....define plastic deformation rate
ck-----------------------------------
      dep1 = p(1,1)*gdot(1)+p1(1,1)*gdot(2)
      dep2 = p(2,2)*gdot(1)+p1(2,2)*gdot(2)
      dep4 = p(1,2)*gdot(1)+p1(1,2)*gdot(2)

ck-----------------------------
ck....calculate OMEGAP & OMEGAE
ck-----------------------------
      omegap = gdot(1)*wp+gdot(2)*wp1
      omegae = (spin(i)+omegap)*dt
ck
      o12    = dt*omegap*(sdev1-sdev2)
      o11    = -2.00*dt*omegap*(sdev4)
      o22    = -o11

ck------------------------------
ck....update deviatoric stresses
ck------------------------------
      ssdev4 = sdev4+twomu*dt*(dd4-dep4)+o12
      ssdev1 = sdev1+twomu*dt*(dd1-dep1)+o11
      ssdev2 = sdev2+twomu*dt*(dd2-dep2)+o22
      ssdev3 = sdev3+twomu*dt*dd3

      ss=abs(ssdev1*dep1)+abs(ssdev2*dep2)+abs(2.00*dep4*ssdev4)
      temp   = temp+dt*eta*ss

ck-------------------------------------------------------------------
ck....update pressure and add deviatoric part to get current stresses
ck-------------------------------------------------------------------
      press    = press+alamdt*traced
ck
      sign1(i) = ssdev1+press
      sign2(i) = ssdev2+press
      sign3(i) = ssdev3+press
      sign4(i) = ssdev4
c
      sig(1,i) = sign1(i)
      sig(2,i) = sign2(i)
      sig(3,i) = sign3(i)
      sig(4,i) = sign4(i)

ck
      chi             = chi+omegae
      his1(ink,nintg) = chi*(180.0/pi)
      gamma=dt*(abs(gdot(1))+abs(gdot(2)))+gamma
      his2(ink,nintg) = gamma
      his3(ink,nintg) = tau(1)
      his4(ink,nintg) = tau(2)
      his7(ink,nintg) = taur
      his8(ink,nintg) = gdot(1)
      his9(ink,nintg) = gdot(2)
      his10(ink,nintg)=(temp*293.0)-273.0

      nnn2(ink,nintg) = nnn1

  10  CONTINUE

c------------------------------
c.....obtain stresses increment
c------------------------------
      DO 440 i=mft,mlt
         dels11(i) = sign1(i)-sig(1,i)
         dels22(i) = sign2(i)-sig(2,i)
         dels33(i) = sign3(i)-sig(3,i)
         dels12(i) = sign4(i)-sig(4,i)

c----------------------------
c.....update rotated stresses
c----------------------------
        sig11(i)   = sig(1,i)
        sig22(i)   = sig(2,i)
        sig33(i)   = sig(3,i)
        sig12(i)   = sig(4,i)
ck
        sig11s(i)  = sig(1,i)
        sig22s(i)  = sig(2,i)
        sig33s(i)  = sig(3,i)
        sig12s(i)  = sig(4,i)
  440 CONTINUE

      RETURN
      END


subroutine general_read_nemsaero(grd,sp_a,filename,mype,gfschem_bundle, &
       naero,aeroname,init_head,iret_read)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    general_read_nemsaero   adaptation of general_read_gfsatm
!                                        for reading in aerosols from NEMSI/O
!
! abstract: copied from general_read_gfsatm, primarily for reading in aerosol
!           tracer variables from NEMS GFS I/O files
!
! program history log:
!   2019-04-19  Wei/Martin - copied and modified to read in aerosol arrays
!                            from either FV3-Chem or NEMS
!
!   input argument list:
!     grd      - structure variable containing information about grid
!                    (initialized by general_sub2grid_create_info,
!                    located in general_sub2grid_mod.f90)
!     sp_a     - structure variable containing spectral information for
!     analysis
!                    (initialized by general_init_spec_vars, located in
!                    general_specmod.f90)
!     filename - input sigma file name
!     mype     - mpi task id
!     naero    - number of aerosol tracers to read
!     aeroname - len(naero) character strings of aerosol tracers to read
!     init_head- flag to read header record.  Usually .true. unless
!     repeatedly
!                reading similar files (ensembles)
!
!   input/output list:
!     gfschem_bundle - GSI bundle containing chem/aerosol arrays
!
!   output argument list:
!     iret_read - return code, 0 for successful read.
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
    use kinds, only: r_kind,r_single,i_kind
    use gridmod, only: use_fv3_aero
    use general_commvars_mod, only: fill_ns,fill2_ns
    use general_sub2grid_mod, only: sub2grid_info
    use general_specmod, only: spec_vars
    use mpimod, only: npe
    use constants, only: zero,one,r0_01
    use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close
    use ncepnems_io, only: error_msg
    use nemsio_module, only: nemsio_gfile,nemsio_getfilehead,nemsio_readrecv
    use egrid2agrid_mod, only: g_egrid2agrid,g_create_egrid2agrid,egrid2agrid_parm,destroy_egrid2agrid
    use constants, only: two,pi,half,deg2rad,r60,r3600
    use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer

    implicit none

!   Declare local parameters
    real(r_kind),parameter:: r0_001 = 0.001_r_kind

!   Declare passed variables
    type(sub2grid_info)                   ,intent(in   ) :: grd
    type(spec_vars)                       ,intent(in   ) :: sp_a
    character(*)                          ,intent(in   ) :: filename
    integer(i_kind)                       ,intent(in   ) :: mype
    integer(i_kind)                       ,intent(in   ) :: naero
    character(*),dimension(naero)         ,intent(in   ) :: aeroname
    logical                               ,intent(in   ) :: init_head
    integer(i_kind)                       ,intent(  out) :: iret_read
    type(gsi_bundle)                      ,intent(inout) :: gfschem_bundle

!   Declare local variables
    character(len=120) :: my_name = 'general_read_nemsaero'
    character(len=1)   :: null = ' '
    character(len=20),dimension(npe) :: ch_aero
    integer(i_kind):: iret,nlatm2,nlevs,icm,nord_int
    integer(i_kind):: i,j,k,l,icount,kk,istatus,ier
    integer(i_kind) :: latb, lonb, levs, nframe
    integer(i_kind) :: nfhour, nfminute, nfsecondn, nfsecondd
    integer(i_kind) :: istop = 101
    integer(i_kind),dimension(npe)::ilev,iflag,mype_use
    integer(i_kind),dimension(7):: idate
    integer(i_kind),dimension(4):: odate
    real(r_kind) :: fhour
    real(r_kind),dimension(:,:,:),pointer :: &
               ae_d1,ae_d2,ae_d3,ae_d4,ae_d5,&
               ae_s1,ae_s2,ae_s3,ae_s4,ae_so4,&
               ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi

    real(r_kind),allocatable,dimension(:,:) :: grid, grid_v,grid_b
    real(r_kind),allocatable,dimension(:,:,:) :: grid_c, grid2
    real(r_kind),allocatable,dimension(:)   :: work
    real(r_kind),allocatable,dimension(:) :: rwork1d0, rwork1d1, rwork1d2
    real(r_kind),allocatable,dimension(:) :: rlats,rlons,clons,slons
    real(r_single),allocatable,dimension(:) :: r4lats,r4lons

    logical :: procuse,diff_res,eqspace
    type(nemsio_gfile) :: gfile
    type(egrid2agrid_parm) :: p_high
    logical,dimension(1) :: vector

!******************************************************************************
    if(mype==0) write(6,*) trim(my_name)," start and filename is ",trim(filename)

!   Initialize variables used below
    iret_read=0
    iret=0
    nlatm2=grd%nlat-2
    iflag = 0
    ilev = 0

    nlevs=grd%nsig
    mype_use=-1
    icount=0
    procuse=.false.
    if(mype == 0)procuse = .true.
    do i=1,npe
       if(grd%recvcounts_s(i-1) > 0)then
         icount = icount+1
         mype_use(icount)=i-1
         if(i-1 == mype) procuse=.true.
       end if
    end do
    icm=icount
    allocate( work(grd%itotsub))
    work=zero
    if(procuse)then

      if (init_head) call nemsio_init(iret=iret)
      if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'init',istop,iret)

      call nemsio_open(gfile,filename,'READ',iret=iret)
      if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'open',istop+1,iret)

      call nemsio_getfilehead(gfile,iret=iret, nframe=nframe, &
           nfhour=nfhour, nfminute=nfminute, nfsecondn=nfsecondn, nfsecondd=nfsecondd, &
           idate=idate, dimx=lonb, dimy=latb,dimz=levs)
      if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'getfilehead',istop+1,iret)

      if( nframe /= 0 ) then
         if ( mype == 0 ) &
         write(6,*)trim(my_name),': ***ERROR***  nframe /= 0 for global model read, nframe = ', nframe
         call stop2(101)
      end if

      fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
      odate(1) = idate(4)  !hour
      odate(2) = idate(2)  !month
      odate(3) = idate(3)  !day
      odate(4) = idate(1)  !year

      if ( iret == 0 .and. mype == 0 ) then
         write(6,'(''Aerosol file time='',i4.4,i2.2,i2.2,i2.2)') odate(4),odate(2),odate(3),odate(1)
      end if
!
!  g_* array already pre-allocate as (lat2,lon2,<nsig>) => 2D and <3D>
!  array
!
      diff_res=.false.
      if(latb /= nlatm2) then
         diff_res=.true.
         if ( mype == 0 ) write(6, &
            '(a,'': different spatial dimension nlatm2 = '',i4,tr1,''latb = '',i4)') &
            trim(my_name),nlatm2,latb
      end if
      if(lonb /= grd%nlon) then
         diff_res=.true.
         if ( mype == 0 ) write(6, &
            '(a,'': different spatial dimension nlon   = '',i4,tr1,''lonb = '',i4)') &
            trim(my_name),grd%nlon,lonb
      end if
      if(levs /= grd%nsig)then
         if ( mype == 0 ) write(6, &
            '(a,'': inconsistent spatial dimension nsig   = '',i4,tr1,''levs = '',i4)') &
            trim(my_name),grd%nsig,levs
         call stop2(101)
      end if

      allocate( grid(grd%nlon,nlatm2), grid_v(grd%nlon,nlatm2) )
      if(diff_res)then
         allocate( grid_b(lonb,latb),grid_c(latb+2,lonb,1),grid2(grd%nlat,grd%nlon,1))
      end if
      allocate( rwork1d0(latb*lonb) )
      allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb),r4lats(lonb*latb),r4lons(lonb*latb))
      allocate(rwork1d1(latb*lonb),rwork1d2(latb*lonb))
      call nemsio_getfilehead(gfile,lat=r4lats,iret=iret)
      call nemsio_getfilehead(gfile,lon=r4lons,iret=iret)
      do j=1,latb
        rlats(latb+2-j)=deg2rad*r4lats(lonb/2+(j-1)*lonb)
      end do
      do j=1,lonb
        rlons(j)=deg2rad*r4lons(j)
      end do
      deallocate(r4lats,r4lons)
      rlats(1)=-half*pi
      rlats(latb+2)=half*pi
      do j=1,lonb
         clons(j)=cos(rlons(j))
         slons(j)=sin(rlons(j))
      end do

      nord_int=4
      eqspace=.false.

      call g_create_egrid2agrid(grd%nlat,sp_a%rlats,grd%nlon,sp_a%rlons,&
                              latb+2,rlats,lonb,rlons,&
                              nord_int,p_high,.true.,eqspace=eqspace)
      deallocate(rlats,rlons)

    end if

    istatus=0
    do l=1,naero
       select case(trim(aeroname(l)))
       case ('sulf')
           call gsi_bundlegetpointer(gfschem_bundle,'sulf' ,ae_so4  ,ier); istatus=istatus+ier
       case ('oc1')
           call gsi_bundlegetpointer(gfschem_bundle,'oc1'  ,ae_ocpho,ier); istatus=istatus+ier
       case ('oc2')
           call gsi_bundlegetpointer(gfschem_bundle,'oc2'  ,ae_ocphi,ier); istatus=istatus+ier
       case ('bc1')
           call gsi_bundlegetpointer(gfschem_bundle,'bc1'  ,ae_bcpho,ier); istatus=istatus+ier
       case ('bc2')
           call gsi_bundlegetpointer(gfschem_bundle,'bc2'  ,ae_bcphi,ier); istatus=istatus+ier
       case ('dust1')
           call gsi_bundlegetpointer(gfschem_bundle,'dust1',ae_d1   ,ier); istatus=istatus+ier
       case ('dust2')
           call gsi_bundlegetpointer(gfschem_bundle,'dust2',ae_d2   ,ier); istatus=istatus+ier
       case ('dust3')
           call gsi_bundlegetpointer(gfschem_bundle,'dust3',ae_d3   ,ier); istatus=istatus+ier
       case ('dust4')
           call gsi_bundlegetpointer(gfschem_bundle,'dust4',ae_d4   ,ier); istatus=istatus+ier
       case ('dust5')
           call gsi_bundlegetpointer(gfschem_bundle,'dust5',ae_d5   ,ier); istatus=istatus+ier
       case ('seas1')
           call gsi_bundlegetpointer(gfschem_bundle,'seas1',ae_s1   ,ier); istatus=istatus+ier
       case ('seas2')
           call gsi_bundlegetpointer(gfschem_bundle,'seas2',ae_s2   ,ier); istatus=istatus+ier
       case ('seas3')
           call gsi_bundlegetpointer(gfschem_bundle,'seas3',ae_s3   ,ier); istatus=istatus+ier
       case ('seas4')
           call gsi_bundlegetpointer(gfschem_bundle,'seas4',ae_s4   ,ier); istatus=istatus+ier
       end select
    end do
    if ( istatus /= 0 ) then
       if ( mype == 0 ) then
         write(6,*) 'general_read_nemsaero: ERROR'
         write(6,*) 'Missing some of the required fields'
         write(6,*) 'Aborting ... '
      endif
      call stop2(999)
   endif

    icount=0
!   Process guess fields according to type of input file.   NCEP_SIGIO
!   files
!   are spectral coefficient files and need to be transformed to the
!   grid.
!   Once on the grid, fields need to be scattered from the full domain
!   to
!   sub-domains.
    do l=1,naero
      do k=1,nlevs
         icount=icount+1
         ilev(icount)=k
         ch_aero(icount)=trim(aeroname(l))
         vector(1)=.false.
         if (mype==mype_use(icount)) then

            if (use_fv3_aero) then
               ! variable names in FV3GFS-GSDChem
               if ( aeroname(l)(1:4) == 'seas') then
                  select case ( trim(aeroname(l)) )
                   case ('seas1')
                  call nemsio_readrecv(gfile,'seas1','mid layer',k,rwork1d1,iret=iret)
                  call nemsio_readrecv(gfile,'seas2','mid layer',k,rwork1d2,iret=iret)
                   rwork1d0=rwork1d1+rwork1d2
                   case ('seas2')
                  call nemsio_readrecv(gfile,'seas3','mid layer',k,rwork1d0,iret=iret)
                   case ('seas3')
                  call nemsio_readrecv(gfile,'seas4','mid layer',k,rwork1d0,iret=iret)
                   case ('seas4')
                  call nemsio_readrecv(gfile,'seas5','mid layer',k,rwork1d0,iret=iret)
                  end select
               else
                  ! many of the names are the same in the GSI bundle as they are
                  ! in the FV3GFS-GSDChem NEMSIO files
                  call nemsio_readrecv(gfile,trim(aeroname(l)),'mid layer',k,rwork1d0,iret=iret)
               end if
            else
               ! variable names in NGACv2
               select case ( trim(aeroname(l)) )
                case ('sulf')
               call nemsio_readrecv(gfile,'so4','mid layer',k,rwork1d0,iret=iret)
                case ('bc1')
               call nemsio_readrecv(gfile,'bcphobic','mid layer',k,rwork1d0,iret=iret)
                case ('bc2')
               call nemsio_readrecv(gfile,'bcphilic','mid layer',k,rwork1d0,iret=iret)
                case ('oc1')
               call nemsio_readrecv(gfile,'ocphobic','mid layer',k,rwork1d0,iret=iret)
                case ('oc2')
               call nemsio_readrecv(gfile,'ocphilic','mid layer',k,rwork1d0,iret=iret)
                case ('dust1')
               call nemsio_readrecv(gfile,'du001','mid layer',k,rwork1d0,iret=iret)
                case ('dust2')
               call nemsio_readrecv(gfile,'du002','mid layer',k,rwork1d0,iret=iret)
                case ('dust3')
               call nemsio_readrecv(gfile,'du003','mid layer',k,rwork1d0,iret=iret)
                case ('dust4')
               call nemsio_readrecv(gfile,'du004','mid layer',k,rwork1d0,iret=iret)
                case ('dust5')
               call nemsio_readrecv(gfile,'du005','mid layer',k,rwork1d0,iret=iret)
                case ('seas1')
               call nemsio_readrecv(gfile,'ss001','mid layer',k,rwork1d1,iret=iret)
               call nemsio_readrecv(gfile,'ss002','mid layer',k,rwork1d2,iret=iret)
                rwork1d0=rwork1d1+rwork1d2
                case ('seas2')
               call nemsio_readrecv(gfile,'ss003','mid layer',k,rwork1d0,iret=iret)
                case ('seas3')
               call nemsio_readrecv(gfile,'ss004','mid layer',k,rwork1d0,iret=iret)
                case ('seas4')
               call nemsio_readrecv(gfile,'ss005','mid layer',k,rwork1d0,iret=iret)
               end select

     ! Convert NGAC mixing ratio unit from kg/kg( 10^3 g/kg ) to ug/kg( 10^-6 g/kg )
               rwork1d0=rwork1d0*1.0e+9_r_kind
            end if ! NGAC vs FV3-Chem

            if (iret /= 0) call error_msg(trim(my_name),trim(filename),'tmp','read',istop+7,iret)
            if(diff_res)then
               grid_b=reshape(rwork1d0,(/size(grid_b,1),size(grid_b,2)/))
               call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
               call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
               do kk=1,grd%itotsub
                 i=grd%ltosi_s(kk)
                 j=grd%ltosj_s(kk)
                 work(kk)=grid2(i,j,1)
               end do
            else
               grid=reshape(rwork1d0,(/size(grid,1),size(grid,2)/))
               call general_fill_ns(grd,grid,work)
            end if

         end if
         if(icount == icm)then
            call aerosol_reload(grd,ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, &
                   ae_s1,ae_s2,ae_s3,ae_s4,ae_so4,&
                   ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi, &
                   icount,ilev,ch_aero,work)
         end if
      end do
    end do

    if(procuse)then
       if(diff_res) deallocate(grid_b,grid_c,grid2)
       call destroy_egrid2agrid(p_high)
       deallocate(rwork1d1,clons,slons)
       deallocate(rwork1d0)
       deallocate(grid)
       call nemsio_close(gfile,iret=iret)
       if (iret /= 0) call error_msg(trim(my_name),trim(filename),null,'close',istop+9,iret)
    end if
    deallocate(work)

!   Print date/time stamp
    if(mype==0) then
       write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,&
            fhour,odate
700    format('READ_GLOBAL_AEROSOL:  ges read/scatter, lonb,latb,levs=',&
            3i6,', nlon,nlat=',2i6,', hour=',f10.1,', idate=',4i5)
    end if

    return

!   ERROR detected while reading file
1000 continue
     write(6,*)'GENERAL_READ_GFSATM:  ***ERROR*** reading ',&
         trim(filename),' mype,iret_read=',mype,iret_read,grd%nsig,nlevs
     return

!   End of routine.  Return

    return
end subroutine general_read_nemsaero
!
subroutine aerosol_reload(grd,ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, &
           ae_s1,ae_s2,ae_s3,ae_s4,ae_so4, &
           ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi, &
           icount,ilev,chaero,work)

! !USES:

  use kinds, only: r_kind,i_kind
  use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype
  use general_sub2grid_mod, only: sub2grid_info
  implicit none

! !INPUT PARAMETERS:

  type(sub2grid_info)                   ,intent(in   ) :: grd
  integer(i_kind),intent(inout) ::icount
  integer(i_kind),dimension(npe),intent(inout):: ilev!,iflag
  real(r_kind),dimension(grd%itotsub),intent(in) :: work
  character(*),dimension(npe) , intent(in) :: chaero

! !OUTPUT PARAMETERS:

  real(r_kind),dimension(grd%lat2,grd%lon2,grd%nsig),intent(  out) :: &
           ae_d1,ae_d2,ae_d3,ae_d4,ae_d5, &
           ae_s1,ae_s2,ae_s3,ae_s4,ae_so4, &
           ae_ocpho,ae_ocphi,ae_bcpho,ae_bcphi

! !DESCRIPTION: Transfer contents of 2-d array to 3-d array
!
! !REVISION HISTORY:
!   2004-05-14  treadon
!   2004-07-15  todling, protex-compliant prologue
!
! !REMARKS:
!
!   language: f90
!   machine:  ibm rs/6000 sp; sgi origin 2000; compaq/hp
!
! !AUTHOR:
!   treadon          org: np23                date: 2004-05-14
!
!EOP
!-------------------------------------------------------------------------

  integer(i_kind) i,j,k,ij,klev
  real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub

  call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,&
       sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,&
       mpi_comm_world,ierror)
!$omp parallel do  schedule(dynamic,1) private(k,i,j,ij,klev)
  do k=1,icount
     klev=ilev(k)
     ij=0
     select case ( chaero(k) )
      case ('sulf')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_so4(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('bc1')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_bcpho(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('bc2')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_bcphi(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('oc1')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_ocpho(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('oc2')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_ocphi(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('dust1')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_d1(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('dust2')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_d2(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('dust3')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_d3(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('dust4')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_d4(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('dust5')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_d5(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('seas1')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_s1(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('seas2')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_s2(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('seas3')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_s3(i,j,klev)=sub(ij,k)
           end do
        end do
      case ('seas4')
        do j=1,grd%lon2
           do i=1,grd%lat2
              ij=ij+1
              ae_s4(i,j,klev)=sub(ij,k)
           end do
        end do
     end select
  end do
!$omp end parallel do
  icount=0
  ilev=0
  return
end subroutine aerosol_reload


*
*     --------------------------------------------------------------
*      D L S A 3
*     --------------------------------------------------------------
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville            February 1994   *
*
      SUBROUTINE DLSA3(K,JA1,JA2,KA,IRE,IAT,REC)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      REC=ZERO
      AA=ONE
      IMAX=JA2-1
      IMIN=JA1+1
      IF(JA1.EQ.1)IMIN=IMIN+1
      IF(IMIN.LT.JA2) THEN
        DO 1 I=IMIN,IMAX
          JI=J1QN1(I,K)-1
          K1=IHSH+I-2
          ITI=J1QN1(K1,K)-1
          ITIS=J1QN2(K1,K)-1
          K1=K1+1
          ITI1=J1QN1(K1,K)-1
          ITI1S=J1QN2(K1,K)-1
          IF(IRE.EQ.0) THEN
            IF(IXJTIK(KA,ITIS,ITI,JI,ITI1,ITI1S).EQ.0)RETURN
          ELSE
            CALL SIXJ(KA,ITIS,ITI,JI,ITI1,ITI1S,0,A3)
            A3=A3*DSQRT(DBLE((ITI+1)*(ITI1S+1)))
            IFAZ=KA+JI+ITI+ITI1S
            IF((IFAZ/4)*4.NE.IFAZ)A3=-A3
            AA=AA*A3
          ENDIF
    1   CONTINUE
      ENDIF
      REC=AA
      IAT=1
      RETURN
      END


!***********************************************************************
!     Perform the MODFLOW budget procedure for PRMS soil zone
!     mm, modifications made by M. Marchildon
!***********************************************************************
      MODULE GSFBUDGET
!   Local Variables
      INTEGER, SAVE :: Nreach
      INTEGER, SAVE :: Vbnm_index(14)
      DOUBLE PRECISION, SAVE :: Gw_bnd_in, Gw_bnd_out, Well_in, Well_out, Basin_actetgw, Basin_fluxchange
      REAL, SAVE, ALLOCATABLE :: Fluxchange(:)
      CHARACTER(LEN=13), SAVE :: MODNAME
!   Declared Variables
      DOUBLE PRECISION, SAVE :: Total_pump, Total_pump_cfs, StreamExchng2Sat_Q, Stream2Unsat_Q, Sat_S
      DOUBLE PRECISION, SAVE :: Stream_inflow, Basin_gw2sm, NetBoundaryFlow2Sat_Q
      DOUBLE PRECISION, SAVE :: Unsat_S, Sat_dS, LakeExchng2Sat_Q, Lake2Unsat_Q, Basin_szreject
      REAL, SAVE, ALLOCATABLE :: Reach_cfs(:), Reach_wse(:), Streamflow_sfr(:)
      REAL, SAVE, ALLOCATABLE :: Gw2sm(:), Actet_gw(:), Actet_tot_gwsz(:), Gw_rejected(:)
!      REAL, SAVE, ALLOCATABLE :: Uzf_infil_map(:), Sat_recharge(:), Mfoutflow_to_gvr(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Strm_seg_gwin(:), Strm_seg_us(:), Strm_seg_ds(:)                               ! mm
      END MODULE GSFBUDGET

!     ******************************************************************
!     Budget module to convert PRMS & MODFLOW states for use by GSFLOW
!     ******************************************************************
      INTEGER FUNCTION gsflow_budget()
      USE PRMS_MODULE, ONLY: Process, Save_vars_to_file, Init_vars_from_file
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: gsfbuddecl, gsfbudinit, gsfbudrun
      EXTERNAL :: gsflow_budget_restart
!***********************************************************************
      gsflow_budget = 0

      IF ( Process(:3)=='run' ) THEN
        gsflow_budget = gsfbudrun()
      ELSEIF ( Process(:4)=='decl' ) THEN
        gsflow_budget = gsfbuddecl()
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( Init_vars_from_file==1 ) CALL gsflow_budget_restart(1)
        gsflow_budget = gsfbudinit()
      ELSEIF ( Process(:5)=='clean' ) THEN
        IF ( Save_vars_to_file==1 ) CALL gsflow_budget_restart(0)
      ENDIF

      END FUNCTION gsflow_budget

!***********************************************************************
!     gsfbuddecl - set up parameters
!   Declared Parameters
!     hru_area, gvr_hru_id, gvr_cell_id, lake_hru_id
!***********************************************************************
      INTEGER FUNCTION gsfbuddecl()
      USE GSFBUDGET
      USE PRMS_MODULE, ONLY: Nhru, Nsegment
      IMPLICIT NONE
      INTEGER, EXTERNAL :: declvar, getdim
      EXTERNAL :: print_module, read_error
! Save Variables
      CHARACTER(LEN=80), SAVE :: Version_gsflow_budget
!***********************************************************************
      gsfbuddecl = 0

      Version_gsflow_budget = 'gsflow_budget.f90 2018-01-23 16:34:00Z'
      CALL print_module(Version_gsflow_budget, 'GSFLOW Output Budget Summary', 90)
      MODNAME = 'gsflow_budget'

      Nreach = getdim('nreach')
      IF ( Nreach==-1 ) CALL read_error(6, 'nreach')

! Declared Variables
      IF ( declvar(MODNAME, 'NetBoundaryFlow2Sat_Q', 'one', 1, 'double', &
     &     'Volumetric flow rate to the saturated zone along the external boundary'// &
     &     ' (negative value is flow out of model domain)', &
     &     'L3/T', NetBoundaryFlow2Sat_Q)/=0 ) CALL read_error(3, 'NetBoundaryFlow2Sat_Q')

      IF ( declvar(MODNAME, 'StreamExchng2Sat_Q', 'one', 1, 'double', &
     &     'Volumetric flow rate of exchange betweeen streams and the saturated'// &
     &     ' zone (value is equal to Strm2UZGW minus SatDisch2Stream_Q, where a'// &
     &     ' negative value indicates a net loss from streams)', &
     &     'L3/T', StreamExchng2Sat_Q)/=0 ) CALL read_error(3, 'StreamExchng2Sat_Q')

      IF ( declvar(MODNAME, 'Stream2Unsat_Q', 'one', 1, 'double', &
     &     'Volumetric flow rate betweeen streams and the unsaturated'// &
     &     ' zone (value is equal to Strm2UZGW minus SatDisch2Stream_Q, where a'// &
     &     ' negative value indicates a net loss from streams)', &
     &     'L3/T', Stream2Unsat_Q)/=0 ) CALL read_error(3, 'Stream2Unsat_Q')

      IF ( declvar(MODNAME, 'LakeExchng2Sat_Q', 'one', 1, 'double', &
     &     'Volumetric flow rate of exchange betweeen lakes and the saturated'// &
     &     ' zone (value is equal to Strm2UZGW minus SatDisch2Stream_Q, where a'// &
     &     ' negative value indicates a net loss from streams)', &
     &     'L3/T', LakeExchng2Sat_Q)/=0 ) CALL read_error(3, 'LakeExchng2Sat_Q')

      IF ( declvar(MODNAME, 'Lake2Unsat_Q', 'one', 1, 'double', &
     &     'Volumetric flow rate betweeen lakes and the unsaturated'// &
     &     ' zone (value is equal to Strm2UZGW minus SatDisch2Stream_Q, where a'// &
     &     ' negative value indicates a net loss from streams)', &
     &     'L3/T', Lake2Unsat_Q)/=0 ) CALL read_error(3, 'Lake2Unsat_Q')

      IF ( declvar(MODNAME, 'stream_inflow', 'one', 1, 'double', &
     &     'Specified volumetric stream inflow rate into model ', &
     &     'L3/T', Stream_inflow)/=0 ) CALL read_error(3, 'stream_inflow')

      IF ( declvar(MODNAME, 'Unsat_S', 'one', 1, 'double', &
     &     'Volume of water in the unsaturated zone', &
     &     'L3', Unsat_S)/=0 ) CALL read_error(3, 'Unsat_S')

      IF ( declvar(MODNAME, 'Sat_S', 'one', 1, 'double', &
     &     'Volume of water in the saturated zone', &
     &     'L3', Sat_S)/=0 ) CALL read_error(3, 'Sat_S')

      IF ( declvar(MODNAME, 'Sat_dS', 'one', 1, 'double', &
     &     'Change in saturated-zone storage', &
     &     'L3', Sat_dS)/=0 ) CALL read_error(3, 'Sat_dS')

      IF ( declvar(MODNAME, 'total_pump', 'one', 1, 'double', &
     &     'Total pumpage from all cells', &
     &     'L3', Total_pump)/=0 ) CALL read_error(3, 'total_pump')

      IF ( declvar(MODNAME, 'total_pump_cfs', 'one', 1, 'double', &
     &     'Total pumpage from all cells', &
     &     'cfs', Total_pump_cfs)/=0 ) CALL read_error(3, 'total_pump_cfs')

      ALLOCATE (Reach_cfs(Nreach))
      IF ( declvar(MODNAME, 'reach_cfs', 'nreach', Nreach, 'real', &
     &     'Stream flow leaving each stream reach', &
     &     'cfs', Reach_cfs)/=0 ) CALL read_error(3, 'reach_cfs')

      ALLOCATE (Reach_wse(Nreach))
      IF ( declvar(MODNAME, 'reach_wse', 'nreach', Nreach, 'real', &
     &     'Water surface elevation in each stream reach', &
     &     'L', Reach_wse)/=0 ) CALL read_error(3, 'reach_wse')

      IF ( declvar(MODNAME, 'basin_gw2sm', 'one', 1, 'double', &
     &     'Basin average water exfiltrated from unsaturated and saturated zones and added to soil zone', &
     &     'inches', Basin_gw2sm)/=0) CALL read_error(3, 'basin_gw2sm')

      IF ( declvar(MODNAME, 'basin_szreject', 'one', 1, 'double', &
     &     'Basin average recharge from SZ and rejected by UZF', &
     &     'inches', Basin_szreject)/=0) CALL read_error(3, 'basin_szreject')

      ALLOCATE (Gw2sm(Nhru))
      IF ( declvar(MODNAME, 'gw2sm', 'nhru', Nhru, 'real', &
     &     'HRU average water exfiltrated from groundwater model and added back to soil zone', &
     &     'inches', Gw2sm)/=0 ) CALL read_error(3, 'gw2sm')

      ALLOCATE (Actet_gw(Nhru))
      IF ( declvar(MODNAME, 'actet_gw', 'nhru', Nhru, 'real', &
     &     'Actual ET from each GW cell', &
     &     'inches', Actet_gw)/=0 ) CALL read_error(3, 'actet_gw')

      ALLOCATE (Actet_tot_gwsz(Nhru))
      IF ( declvar(MODNAME, 'actet_tot_gwsz', 'nhru', Nhru, 'real', &
     &     'Total actual ET from each GW cell and PRMS soil zone', &
     &     'inches', Actet_tot_gwsz)/=0 ) CALL read_error(3, 'actet_tot_gwsz')

      ALLOCATE (Streamflow_sfr(Nsegment))
      IF ( declvar(MODNAME, 'streamflow_sfr', 'nsegment', Nsegment, 'real', &
     &     'Streamflow as computed by SFR for each segment', &
     &     'cfs', Streamflow_sfr)/=0 ) CALL read_error(3, 'streamflow_sfr')

      ALLOCATE ( Strm_seg_gwin(Nsegment) )                                                                                ! mm begin
      IF ( declvar(MODNAME, 'strm_seg_gwin', 'nsegment', Nsegment, 'double', &
     &     'Groundwater discharge into each stream segment', &
     &     'cfs', Strm_seg_gwin)/=0 ) CALL read_error(3, 'strm_seg_gwin')

      ALLOCATE ( Strm_seg_us(Nsegment) )
      IF ( declvar(MODNAME, 'strm_seg_us', 'nsegment', Nsegment, 'double', &
     &     'Total discharge entering each stream segment', &
     &     'cfs', Strm_seg_us)/=0 ) CALL read_error(3, 'strm_seg_us')

      ALLOCATE ( Strm_seg_ds(Nsegment) )
      IF ( declvar(MODNAME, 'strm_seg_ds', 'nsegment', Nsegment, 'double', &
     &     'Total discharge leaving each stream segment', &
     &     'cfs', Strm_seg_ds)/=0 ) CALL read_error(3, 'strm_seg_ds')                                                       ! mm end

      ALLOCATE ( Gw_rejected(Nhru) )
      IF ( declvar(MODNAME, 'gw_rejected', 'nhru', Nhru, 'real', &
     &     'HRU average recharge rejected by UZF', 'inches', &
     &     Gw_rejected)/=0 ) CALL read_error(3, 'gw_rejected')

!      ALLOCATE ( Uzf_infil_map(Nhru) )
!      IF ( declvar(MODNAME, 'uzf_infil_map', 'nhru', Nhru, 'real', &
!     &     'HRU total gravity drainage to UZF cells', 'L3', &
!     &     Uzf_infil_map)/=0 ) CALL read_error(3, 'uzf_infil_map')

!      ALLOCATE ( Sat_recharge(Nhru) )
!      IF ( declvar(MODNAME, 'sat_recharge', 'nhru', Nhru, 'real', &
!     &     'HRU total recharge to the saturated zone', 'L3', &
!     &     Sat_recharge)/=0 ) CALL read_error(3, 'sat_recharge')

!      ALLOCATE ( Mfoutflow_to_gvr(Nhru) )
!      IF ( declvar(MODNAME, 'mfoutflow_to_gvr', 'nhru', Nhru, 'real', &
!     &     'MODFLOW total discharge and ET to each HRU', 'L3', &
!     &     Mfoutflow_to_gvr)/=0 ) CALL read_error(3, 'mfoutflow_to_gvr')

      END FUNCTION gsfbuddecl

!***********************************************************************
!     gsfbudinit - Initialize GSFBUDGET module - get parameter values
!***********************************************************************
      INTEGER FUNCTION gsfbudinit()
      USE GSFBUDGET
      USE PRMS_MODULE, ONLY: Init_vars_from_file, Nhru
      USE GWFSFRMODULE, ONLY: NSTRM
      USE GLOBAL, ONLY: IUNIT
      USE GWFUZFMODULE, ONLY: UZTSRAT
      IMPLICIT NONE
      EXTERNAL :: MODFLOW_GET_STORAGE_BCF, MODFLOW_GET_STORAGE_LPF, MODFLOW_GET_STORAGE_UPW
!***********************************************************************
      gsfbudinit = 0

      IF ( Nreach/=NSTRM ) THEN
        PRINT *, 'ERROR, nreach must equal to NSTRM', Nreach, NSTRM
        STOP
      ENDIF

      IF ( Init_vars_from_file==0 ) THEN
        Reach_cfs = 0.0 ! dimension NSTRM
        Reach_wse = 0.0 ! dimension NSTRM
        Total_pump = 0.0D0
        Total_pump_cfs = 0.0D0
        Unsat_S = UZTSRAT(6)
        IF ( IUNIT(1)>0 ) CALL MODFLOW_GET_STORAGE_BCF()
        IF ( IUNIT(23)>0 ) CALL MODFLOW_GET_STORAGE_LPF()
        IF ( IUNIT(62)>0 ) CALL MODFLOW_GET_STORAGE_UPW()
        Sat_dS = 0.0D0
        StreamExchng2Sat_Q = 0.0D0
        Stream2Unsat_Q = 0.0D0
        LakeExchng2Sat_Q = 0.0D0
        Lake2Unsat_Q = 0.0D0
        Stream_inflow = 0.0D0
        Basin_gw2sm = 0.0D0
!        Uzf_infil_map = 0.0 ! dimension nhru
!        Sat_recharge = 0.0 ! dimension nhru
!        Mfoutflow_to_gvr = 0.0 ! dimension nhru
        Gw2sm = 0.0 ! dimension nhru
        Actet_gw = 0.0 ! dimension nhru
        Actet_tot_gwsz = 0.0 ! dimension nhru
        Streamflow_sfr = 0.0 ! dimension nsegment
        Strm_seg_gwin = 0.0D0                                                                                ! mm
        Strm_seg_us = 0.0D0                                                                                ! mm
        Strm_seg_ds = 0.0D0                                                                                ! mm
      ENDIF

!  Set the volume budget indicies to -1 anytime "init" is called.
!  This will make "run" figure out the vbnm order.
      Vbnm_index = -1
      ALLOCATE ( Fluxchange(Nhru) )
      Fluxchange = 0.0
      Basin_fluxchange = 0.0D0
      Basin_szreject = 0.0D0
      Gw_rejected = 0.0

      END FUNCTION gsfbudinit

!***********************************************************************
! Compute basin budget for GSFLOW
! adjust gravity flow storage with last gw2sm and gw_rejected
!***********************************************************************
      INTEGER FUNCTION gsfbudrun()
      USE GSFBUDGET
      USE GSFMODFLOW, ONLY: Mfq2inch_conv, Mfl2_to_acre, & !, Cellarea, &
     &    Mfvol2inch_conv, Mfl3t_to_cfs, Mfl_to_inch, Gwc_col, Gwc_row, Have_lakes
!      USE GLOBAL, ONLY: IUNIT
!Warning, modifies Gw_rejected_grav
      USE GSFPRMS2MF, ONLY: Excess, Gw_rejected_grav
      USE PRMS_MODULE, ONLY: Nhrucell, Gvr_cell_id !, Gvr_cell_pct, Print_debug
      USE GWFBASMODULE, ONLY: VBVL, DELT
      USE GWFSFRMODULE, ONLY: NSS                                               !mm
      USE GWFUZFMODULE, ONLY: SEEPOUT, UZFETOUT, UZTSRAT, REJ_INF, GWET !, UZOLSFLX, UZFLWT
      USE GWFLAKMODULE, ONLY: EVAP, SURFA
!Warning, modifies Basin_gwflow_cfs, Basin_cfs, Basin_cms, Basin_stflow,
!                  Basin_ssflow_cfs, Basin_sroff_cfs
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_type, Active_area, &
     &    Basin_area_inv, Hru_area, NEARZERO, Lake_hru_id, Lake_area, CLOSEZERO
      USE PRMS_FLOWVARS, ONLY: Basin_ssflow, Basin_lakeevap, Hru_actet, &
     &    Basin_actet, Basin_ssstor, Ssres_stor, Slow_stor, Basin_ssflow_cfs, Basin_sroff_cfs, Basin_gwflow_cfs
      USE PRMS_SET_TIME, ONLY: Cfs_conv
!Warning, modifies Basin_soil_moist, Basin_ssstor
      USE PRMS_SRUNOFF, ONLY: Basin_sroff
!Warning, modifies Gw2sm_grav
      USE PRMS_SOILZONE, ONLY: Pref_flow_stor, Gravity_stor_res, Hrucheck, Gvr_hru_id, &
     &    Basin_slstor, Gw2sm_grav, Gvr_hru_pct_adjusted
      IMPLICIT NONE
! Functions
      INTRINSIC :: ABS, SNGL
!      EXTERNAL MODFLOW_GET_STORAGE_BCF, MODFLOW_GET_STORAGE_LPF
!      EXTERNAL MODFLOW_GET_STORAGE_UPW
      EXTERNAL MODFLOW_VB_DECODE, getStreamFlow, getPump
!     EXTERNAL getHeads, print_date
! Local Variables
      INTEGER :: i, ihru, icell, irow, icol, ii, lake
      REAL :: flux_change, gwdisch, harea, inches_on_lake, pct
      DOUBLE PRECISION :: modflow_in, modflow_out, area_fac
!***********************************************************************
      gsfbudrun = 0

! adjust gravity flow storage using last gw discharge and rejected
      area_fac = Cfs_conv*Active_area
      Basin_ssflow_cfs = Basin_ssflow*area_fac
      Basin_sroff_cfs = Basin_sroff*area_fac
      DO ii = 1, Active_hrus
        i = Hru_route_order(ii)
        Gw2sm(i) = 0.0
        Gw_rejected(i) = 0.0
        Actet_gw(i) = 0.0
        Slow_stor(i) = 0.0 !shouldn't be reset if any cells of HRU inactive and HRU active
!        Uzf_infil_map(i) = 0.0
!        Sat_recharge(i) = 0.0
!        Mfoutflow_to_gvr(i) = 0.0
        Fluxchange(i) = 0.0
      ENDDO
      Streamflow_sfr = 0.0

      DO i = 1, NSS                                                                                ! mm begin
        Strm_seg_gwin(i) = 0.0D0
        Strm_seg_us(i) = 0.0D0
        Strm_seg_ds(i) = 0.0D0
      ENDDO                                                                                ! mm end

      DO i = 1, Nhrucell
        ihru = Gvr_hru_id(i)
        icell = Gvr_cell_id(i)
        irow = Gwc_row(icell)
        icol = Gwc_col(icell)
        pct = SNGL( Gvr_hru_pct_adjusted(i) )
        ! which calculations need gvr_cell_pct ???
!        Uzf_infil_map(ihru) = Uzf_infil_map(ihru) + UZOLSFLX(icol, irow)*Gvr_cell_pct(i)*pct*Cellarea(icell)*DELT
!        Sat_recharge(ihru) = Sat_recharge(ihru) + UZFLWT(icol, irow)*Gvr_hru_pct_adjusted(i)
!        Mfoutflow_to_gvr(ihru) = Mfoutflow_to_gvr(ihru) + (SEEPOUT(icol,irow)+GWET(icol,irow))*pct
        IF ( Hrucheck(ihru)/=1 ) CYCLE ! don't compute the rest if inactive or lake HRU, not sure about 3 variable prior
!-----------------------------------------------------------------------
! Add any excess infiltration to Gw_rejected array
! rejected can be added now as water would not have been used for
! any other purpose, it was water that could have been sent to MODFLOW
! if MODFLOW could accept it, includes (1) binning (Excess) and rejected
! infiltration due to (2) inactive cells and too many waves
! (Gw_rejected_grav(i)), (3) exceeding K and high gw head (gw
! discharging into GVR) (REJ_INF).
!-----------------------------------------------------------------------
        gwdisch = SEEPOUT(icol, irow)*Mfq2inch_conv(i)
! flux equals current minus last GW discharge used with soilzone, usually iteration before convergence
        flux_change = gwdisch - Gw2sm_grav(i) ! gw2sm_grav last set in gsflow_mf2prms with values last used by soilzone
        Fluxchange(Ihru) = Fluxchange(Ihru) + flux_change*pct
        IF ( ABS(flux_change)<CLOSEZERO ) flux_change = 0.0 ! assume round-off error, so set to zero
        !Gw_rejected_grav includes rejected soil_to_gw
        Gw_rejected_grav(i) = Gw_rejected_grav(i) + Excess(icell)*Mfl_to_inch + REJ_INF(icol, irow)*Mfq2inch_conv(i)
        Gw_rejected(ihru) = Gw_rejected(ihru) + Gw_rejected_grav(i)*pct
        Gw2sm_grav(i) = gwdisch ! set in mf2prms
        Gw2sm(ihru) = Gw2sm(ihru) + gwdisch*pct
        Gravity_stor_res(i) = Gravity_stor_res(i) + Gw_rejected_grav(i) + flux_change
        Slow_stor(ihru) = Slow_stor(ihru) + Gravity_stor_res(i)*pct
        Actet_gw(ihru) = Actet_gw(ihru) + (GWET(icol,irow) + UZFETOUT(icol, irow))*Mfvol2inch_conv(i)*pct
      ENDDO

      Basin_ssstor = 0.0D0
      Basin_gw2sm = 0.0D0
      Basin_szreject = 0.0D0
      Basin_lakeevap = 0.0D0
      Basin_actetgw = 0.0D0
      Basin_actet = 0.0D0
      Basin_slstor = 0.0D0
      Basin_fluxchange = 0.0D0
      DO ii = 1, Active_hrus
        i = Hru_route_order(ii)
        harea = Hru_area(i)
        IF ( Have_lakes==1 ) THEN
!-----------------------------------------------------------------------
! Get actual et from lakes
!-----------------------------------------------------------------------
          IF ( Hru_type(i)==2 ) THEN
            lake = Lake_hru_id(i)
            !EVAP in mfl3/dt   SURFA in MFL2/dt
            IF ( SURFA(lake)>NEARZERO ) THEN
              inches_on_lake = EVAP(lake)*DELT/SURFA(lake)*Mfl_to_inch                            !RGN 5/23/15 added *DELT for time units other than days.
              Hru_actet(i) = inches_on_lake*SURFA(lake)*Mfl2_to_acre/Lake_area(lake)
            ELSE
              Hru_actet(i) = 0.0
            ENDIF
            ! does not include any ET from UZF, i.e., dry areas in lake
            Actet_tot_gwsz(i) = Hru_actet(i)
            Basin_lakeevap = Basin_lakeevap + Hru_actet(i)*harea
            Basin_actet = Basin_actet + Hru_actet(i)*harea
            CYCLE
          ENDIF
        ENDIF

        Actet_tot_gwsz(i) = Hru_actet(i) + Actet_gw(i)
        !rsr, need to adjust hru_actet for UZF
        Hru_actet(i) = Actet_tot_gwsz(i)
        Basin_actet = Basin_actet + Hru_actet(i)*harea
        Basin_actetgw = Basin_actetgw + Actet_gw(i)*harea
        Basin_gw2sm = Basin_gw2sm + Gw2sm(i)*harea
        Ssres_stor(i) = Slow_stor(i) + Pref_flow_stor(i)
        Basin_ssstor = Basin_ssstor + Ssres_stor(i)*harea
        Basin_szreject = Basin_szreject + Gw_rejected(i)*harea
        Basin_slstor = Basin_slstor + Slow_stor(i)*harea
        Basin_fluxchange = Basin_fluxchange + Fluxchange(i)*harea
      ENDDO

      Basin_actet = Basin_actet*Basin_area_inv
      Basin_actetgw = Basin_actetgw*Basin_area_inv
      Basin_ssstor = Basin_ssstor*Basin_area_inv
      Basin_gw2sm = Basin_gw2sm*Basin_area_inv
      Basin_szreject = Basin_szreject*Basin_area_inv
      Basin_lakeevap = Basin_lakeevap*Basin_area_inv
      Basin_slstor = Basin_slstor*Basin_area_inv
      Basin_fluxchange = Basin_fluxchange*Basin_area_inv

      !IF ( IUNIT(1)>0 ) CALL MODFLOW_GET_STORAGE_BCF()
      !IF ( IUNIT(23)>0 ) CALL MODFLOW_GET_STORAGE_LPF()
      !IF ( IUNIT(62)>0 ) CALL MODFLOW_GET_STORAGE_UPW()

      IF ( Vbnm_index(1)==-1 ) CALL MODFLOW_VB_DECODE(Vbnm_index)
      Sat_dS = VBVL(4,Vbnm_index(12)) - VBVL(3,Vbnm_index(12))
      Sat_S = Sat_S + Sat_dS

      Unsat_S = UZTSRAT(6)

!  Stuff from MODFLOW

      modflow_in = 0.0D0
      Gw_bnd_in = 0.0D0
      Well_in = 0.0D0
      IF ( Vbnm_index(1)/=-1 ) THEN ! constant heads
        modflow_in = modflow_in + VBVL(3, Vbnm_index(1))
        Gw_bnd_in = Gw_bnd_in + VBVL(3, Vbnm_index(1))
      ENDIF

      IF ( Vbnm_index(3)/=-1 ) THEN ! head dep bounds
        modflow_in = modflow_in + VBVL(3, Vbnm_index(3))
        Gw_bnd_in = Gw_bnd_in + VBVL(3, Vbnm_index(3))
      ENDIF

      IF ( Vbnm_index(4)/=-1 ) THEN ! specified heads
        modflow_in = modflow_in + VBVL(3, Vbnm_index(4))
        Gw_bnd_in = Gw_bnd_in + VBVL(3, Vbnm_index(4))
      ENDIF

      IF ( Vbnm_index(5)/=-1 ) THEN ! wells
!        modflow_in = modflow_in + VBVL(3, Vbnm_index(5))
        Well_in = Well_in + VBVL(3, Vbnm_index(5))
      ENDIF

      IF ( Vbnm_index(6)/=-1 ) THEN ! multi node wells (MNW1)
!        modflow_in = modflow_in + VBVL(3, Vbnm_index(6))
        Well_in = Well_in + VBVL(3, Vbnm_index(6))
      ENDIF

      IF ( Vbnm_index(14)/=-1 ) THEN ! multi node wells (MNW2)
!        modflow_in = modflow_in + VBVL(3, Vbnm_index(14))
        Well_in = Well_in + VBVL(3, Vbnm_index(14))
      ENDIF

      modflow_out = 0.0D0
      Gw_bnd_out = 0.0D0
      Well_out = 0.0D0
      IF ( Vbnm_index(1)/=-1 ) THEN ! constant heads
        modflow_out = modflow_out + VBVL(4, Vbnm_index(1))
        Gw_bnd_out = Gw_bnd_out + VBVL(4, Vbnm_index(1))
      ENDIF

      IF ( Vbnm_index(2)/=-1 ) THEN ! drains
        modflow_out = modflow_out + VBVL(4, Vbnm_index(2))
        Gw_bnd_out = Gw_bnd_out + VBVL(4, Vbnm_index(2))
      ENDIF

      IF ( Vbnm_index(3)/=-1 ) THEN ! head dep bounds
        modflow_out = modflow_out + VBVL(4, Vbnm_index(3))
        Gw_bnd_out = Gw_bnd_out + VBVL(4, Vbnm_index(3))
      ENDIF

      IF ( Vbnm_index(4)/=-1 ) THEN ! specified heads
        modflow_out = modflow_out + VBVL(4, Vbnm_index(4))
        Gw_bnd_out = Gw_bnd_out + VBVL(4, Vbnm_index(4))
      ENDIF

      IF ( Vbnm_index(5)/=-1 ) THEN ! wells
!        modflow_out = modflow_out + VBVL(4, Vbnm_index(5))
        Well_out = Well_out + VBVL(4, Vbnm_index(5))
      ENDIF

      IF ( Vbnm_index(6)/=-1 ) THEN ! multi node wells (MNW1)
!        modflow_out = modflow_out + VBVL(4, Vbnm_index(6))
        Well_out = Well_out + VBVL(4, Vbnm_index(6))
      ENDIF

       IF ( Vbnm_index(14)/=-1 ) THEN ! multi node wells (MNW2)
!        modflow_out = modflow_out + VBVL(4, Vbnm_index(14))
        Well_out = Well_out + VBVL(4, Vbnm_index(14))
      ENDIF

      NetBoundaryFlow2Sat_Q = modflow_in - modflow_out

      CALL getStreamFlow()

      Basin_gwflow_cfs = StreamExchng2Sat_Q*Mfl3t_to_cfs

!     CALL getHeads()

      CALL getPump()

      END FUNCTION gsfbudrun

!***********************************************************************
! Figure out the total storage of the cells in MODFLOW
! written by markstro but hijacked from MODFLOW subroutine SGWF1BCF6S
! Use Sat_S for display purposes only, don't use in budget.
!***********************************************************************
      SUBROUTINE MODFLOW_GET_STORAGE_BCF()
      USE GSFBUDGET, ONLY: Sat_S
      USE GLOBAL, ONLY: NCOL, NROW, NLAY, IBOUND, BOTM, HNEW, LBOTM
      USE GWFBASMODULE, ONLY: DELT
      USE GWFBCFMODULE, ONLY: LAYCON, SC1, SC2
      IMPLICIT NONE
! Local Variables
      INTEGER :: i, j, k, kt, lc
      DOUBLE PRECISION :: tled, top, bot, rho, storage, head
!***********************************************************************
      tled = 1.0D0/DELT
      Sat_S = 0.0D0

!5------LOOP THROUGH EVERY CELL IN THE GRID.
      kt = 0
      DO k = 1, NLAY
        lc = LAYCON(k)
        IF ( lc==3 .OR. lc==2 ) kt = kt + 1
        DO i = 1, NROW
          DO j = 1, NCOL

!6------SKIP NO-FLOW AND CONSTANT-HEAD CELLS.
            IF ( IBOUND(j, i, k)>0 ) THEN
              head = HNEW(j, i, k)
              top = BOTM(j, i, LBOTM(k)-1)
              bot = BOTM(j, i, LBOTM(k))

!7-----CHECK LAYER TYPE TO SEE IF ONE STORAGE CAPACITY OR TWO.
              IF ( lc==3 .OR. lc==2 ) THEN
                rho = SC2(j, i, kt)
!7A----TWO STORAGE CAPACITIES.
!                IF ( head>top ) THEN
!                  rho = SC1(j, i, k)
!                ELSE
!                  rho = SC2(j, i, kt)
!                ENDIF
              ELSE
!7B----ONE STORAGE CAPACITY.
                rho = SC1(j, i, k)
              ENDIF
              IF ( head>=top ) THEN
                storage = rho*(top-bot)*tled
              ELSE
                storage = rho*(head-bot)*tled
              ENDIF
              Sat_S = Sat_S + storage
            ENDIF

          ENDDO
        ENDDO
      ENDDO

      END SUBROUTINE MODFLOW_GET_STORAGE_BCF

!***********************************************************************
! Figure out the total storage of the cells in MODFLOW
! written by markstro but hijacked from MODFLOW subroutine SGWF1LPF1S
! Use Sat_S for display purposes only, don't use in budget.
!***********************************************************************
      SUBROUTINE MODFLOW_GET_STORAGE_LPF()
      USE GSFBUDGET, ONLY: Sat_S
      USE GLOBAL, ONLY: NCOL, NROW, NLAY, IBOUND, BOTM, HNEW, LBOTM
      USE GWFBASMODULE, ONLY: DELT
      USE GWFLPFMODULE, ONLY: LAYTYP, SC1, SC2
      IMPLICIT NONE
! Local Variables
      INTEGER :: i, j, k, kt, lc
      DOUBLE PRECISION :: tled, top, bot, rho, storage, head
!***********************************************************************
      tled = 1.0D0/DELT
      Sat_S = 0.0D0

!5------LOOP THROUGH EVERY CELL IN THE GRID.
      kt = 0
      DO k = 1, NLAY
        lc = LAYTYP(k)
        IF ( lc/=0 ) kt = kt + 1
        DO i = 1, NROW
          DO j = 1, NCOL

!6------SKIP NO-FLOW AND CONSTANT-HEAD CELLS.
            IF ( IBOUND(j, i, k)>0 ) THEN
              head = HNEW(j, i, k)
              top = BOTM(j, i, LBOTM(k)-1)
              bot = BOTM(j, i, LBOTM(k))

!7-----CHECK LAYER TYPE TO SEE IF ONE STORAGE CAPACITY OR TWO.
              IF ( lc/=0 ) THEN
!7A----TWO STORAGE CAPACITIES.
!  markstro - always use specific yield
                rho = SC2(j, i, kt)
!               IF ( head>top ) THEN
!                 rho = SC1(j, i, k)
!               ELSE
!                 rho = SC2(j, i, kt)
!               ENDIF
              ELSE
!7A----ONE STORAGE CAPACITY.
                rho = SC1(j, i, k)
              ENDIF
              IF ( head>=top ) THEN
                storage = rho*(top-bot)*tled
              ELSE
                storage = rho*(head-bot)*tled
              ENDIF
              Sat_S = Sat_S + storage
            ENDIF

          ENDDO
        ENDDO
      ENDDO

      END SUBROUTINE MODFLOW_GET_STORAGE_LPF

!***********************************************************************
! Figure out the total storage of the cells in MODFLOW
! written by markstro but hijacked from MODFLOW subroutine SGWF1LPF1S
! Use Sat_S for display purposes only, don't use in budget.
!***********************************************************************
      SUBROUTINE MODFLOW_GET_STORAGE_UPW()
      USE GSFBUDGET, ONLY: Sat_S
      USE PRMS_BASIN, ONLY: NEARZERO
      USE GLOBAL, ONLY: NCOL, NROW, NLAY, IBOUND, BOTM, HNEW, LBOTM
      USE GWFBASMODULE, ONLY: DELT, HDRY
      USE GWFUPWMODULE, ONLY: LAYTYPUPW, SC1, SC2UPW
      IMPLICIT NONE
! Functions
      INTRINSIC ABS
! Local Variables
      INTEGER :: i, j, k, kt, lc
      DOUBLE PRECISION :: tled, top, bot, rho, storage, head
!***********************************************************************
      tled = 1.0D0/DELT
      Sat_S = 0.0D0

!5------LOOP THROUGH EVERY CELL IN THE GRID.
      kt = 0
      DO k = 1, NLAY
        lc = LAYTYPUPW(k)
        IF ( lc/=0 ) kt = kt + 1
        DO j = 1, NCOL
          DO i = 1, NROW

!6------SKIP NO-FLOW AND CONSTANT-HEAD CELLS.
            IF ( IBOUND(j, i, k)>0 .AND. ABS(HNEW(j, i, k)-HDRY)>NEARZERO ) THEN
              head = HNEW(j, i, k)
              top = BOTM(j, i, LBOTM(k)-1)
              bot = BOTM(j, i, LBOTM(k))

!7-----CHECK LAYER TYPE TO SEE IF ONE STORAGE CAPACITY OR TWO.
              IF ( lc/=0 ) THEN
!7A----TWO STORAGE CAPACITIES.
!  markstro - always use specific yield
                rho = SC2UPW(j, i, kt)
              ELSE
!7A----ONE STORAGE CAPACITY.
                rho = SC1(j, i, k)
              ENDIF
              IF ( head>=top ) THEN
                storage = rho*(top-bot)*tled
              ELSE
                storage = rho*(head-bot)*tled
              ENDIF
              Sat_S = Sat_S + storage
            ENDIF

          ENDDO
        ENDDO
      ENDDO

      END SUBROUTINE MODFLOW_GET_STORAGE_UPW

!***********************************************************************
! Decode the MODFLOW VBNM array
!***********************************************************************
      SUBROUTINE MODFLOW_VB_DECODE(Vbnm_index)
      USE GWFBASMODULE, ONLY: VBNM, MSUM
      IMPLICIT NONE
! Arguments
      INTEGER :: Vbnm_index(14)
! Local Variables
      INTEGER :: i
!***********************************************************************
!  Stuff from MODFLOW
      DO i = 1, MSUM - 1
        IF ( VBNM(i)=='   CONSTANT HEAD' ) Vbnm_index(1) = i
        IF ( VBNM(i)=='          DRAINS' ) Vbnm_index(2) = i
        IF ( VBNM(i)==' HEAD DEP BOUNDS' ) Vbnm_index(3) = i
        IF ( VBNM(i)==' SPECIFIED FLOWS' ) Vbnm_index(4) = i
        IF ( VBNM(i)=='           WELLS' ) Vbnm_index(5) = i
        IF ( VBNM(i)=='             MNW' ) Vbnm_index(6) = i
        IF ( VBNM(i)=='    UZF RECHARGE' ) Vbnm_index(7) = i
        IF ( VBNM(i)=='           GW ET' ) Vbnm_index(8) = i
        IF ( VBNM(i)==' SURFACE LEAKAGE' ) Vbnm_index(9) = i
        IF ( VBNM(i)=='  STREAM LEAKAGE' ) Vbnm_index(10) = i
        IF ( VBNM(i)=='   LAKE  SEEPAGE' ) Vbnm_index(11) = i
        IF ( VBNM(i)=='         STORAGE' ) Vbnm_index(12) = i
        IF ( VBNM(i)=='INTERBED STORAGE' ) Vbnm_index(13) = i
        IF ( VBNM(i)=='            MNW2' ) Vbnm_index(14) = i
      ENDDO

      END SUBROUTINE MODFLOW_VB_DECODE

!***********************************************************************
!***********************************************************************
      SUBROUTINE getStreamFlow()
      USE GSFBUDGET, ONLY: Reach_cfs, Reach_wse, StreamExchng2Sat_Q, &
     &    Stream_inflow, Streamflow_sfr, Strm_seg_gwin, &                                                                   ! mm
     &    Strm_seg_us, Strm_seg_ds                                                                                ! mm
      USE GSFMODFLOW, ONLY: Mfl3t_to_cfs
      USE GWFSFRMODULE, ONLY: STRM, IOTSG, NSS, SGOTFLW, SFRRATOUT, &
     &    TOTSPFLOW, NSTRM, SFRRATIN, ISEG                                                                                ! mm
      USE PRMS_FLOWVARS, ONLY: Basin_cfs, Basin_cms, Basin_stflow_out
      USE PRMS_BASIN, ONLY: CFS2CMS_CONV
      USE PRMS_SET_TIME, ONLY: Cfs2inches
      IMPLICIT NONE
      INTRINSIC DBLE
! Local Variables
      INTEGER :: i, j, k, nrch                                                                                ! mm
!***********************************************************************
      DO i = 1, NSTRM
! Reach_cfs and reach_wse are not used except to be available for output
        Reach_cfs(i) = DBLE( STRM(9, i) )*Mfl3t_to_cfs
        Reach_wse(i) = STRM(15, i)
      ENDDO

      k = 0                                                                                ! mm begin
      DO i = 1, NSS
        nrch = ISEG(4, i)
        DO j = 1, nrch
          k = k + 1
          Strm_seg_gwin(i) = Strm_seg_gwin(i) - STRM(11, k)*Mfl3t_to_cfs
          IF ( j==1 ) Strm_seg_us(i) = STRM(10, k)*Mfl3t_to_cfs
          IF ( j==nrch ) Strm_seg_ds(i) = STRM(9, k)*Mfl3t_to_cfs
        ENDDO
      ENDDO                                                                                ! mm end

! Total streamflow out of basin for all streams leaving model area.
! Total specified streamflow into model area.
      Basin_cfs = 0.0D0
      Stream_inflow = 0.0D0
      DO i = 1, NSS
        IF ( IOTSG(i)==0 ) Basin_cfs = Basin_cfs + SGOTFLW(i)
        Streamflow_sfr(i) = DBLE( SGOTFLW(i) )*Mfl3t_to_cfs
      ENDDO
      IF ( TOTSPFLOW<0.0 ) THEN
        Basin_cfs = Basin_cfs + TOTSPFLOW
      ELSE
! RGN added specified inflows and outflows from SFR.
        Stream_inflow = Stream_inflow + TOTSPFLOW
      END IF
! RGN added next line.
      StreamExchng2Sat_Q = SFRRATIN - SFRRATOUT
      Basin_cfs = Basin_cfs*Mfl3t_to_cfs
      Basin_cms = Basin_cfs*CFS2CMS_CONV
      Basin_stflow_out = Basin_cfs*Cfs2inches

      END SUBROUTINE getStreamFlow

!***********************************************************************
!     READ AND PREPARE INFORMATION FOR STRESS PERIOD.
!***********************************************************************
      SUBROUTINE getPump()
      USE GSFBUDGET, ONLY: Total_pump, Total_pump_cfs, Vbnm_index
      USE GSFMODFLOW, ONLY: Mfl3t_to_cfs
      USE GWFBASMODULE, ONLY: VBVL
      IMPLICIT NONE

!***********************************************************************
      Total_pump = 0.0D0

      ! wells
      IF ( Vbnm_index(5)/=-1 ) Total_pump = Total_pump - VBVL(4, Vbnm_index(5))

      ! multi node wells (MNW1)
      IF ( Vbnm_index(6)/=-1 ) Total_pump = Total_pump - VBVL(4, Vbnm_index(6))

      ! multi node wells (MNW2)
      IF ( Vbnm_index(14)/=-1 ) Total_pump = Total_pump - VBVL(4, Vbnm_index(14))

      ! wells
      IF ( Vbnm_index(5)/=-1 ) Total_pump = Total_pump + VBVL(3, Vbnm_index(5))

      ! multi node wells (MNW1)
      IF ( Vbnm_index(6)/=-1 )Total_pump = Total_pump + VBVL(3, Vbnm_index(6))

      ! multi node wells (MNW2)
      IF ( Vbnm_index(14)/=-1 ) Total_pump = Total_pump + VBVL(3, Vbnm_index(14))

      Total_pump_cfs = Total_pump * Mfl3t_to_cfs

      END SUBROUTINE getPump

!***********************************************************************
!     gsflow_budget_restart - write to or read from restart file
!***********************************************************************
      SUBROUTINE gsflow_budget_restart(In_out)
      USE PRMS_MODULE, ONLY: Restart_outunit, Restart_inunit
      USE GSFBUDGET
      ! Argument
      INTEGER, INTENT(IN) :: In_out
      EXTERNAL check_restart
      ! Local Variable
      CHARACTER(LEN=13) :: module_name
!***********************************************************************
      IF ( In_out==0 ) THEN
        WRITE ( Restart_outunit ) MODNAME
        WRITE ( Restart_outunit ) Total_pump, Total_pump_cfs, Unsat_S, Sat_S, &
     &          Sat_dS, StreamExchng2Sat_Q, Stream2Unsat_Q, Stream_inflow, &
     &          Basin_gw2sm, LakeExchng2Sat_Q, Lake2Unsat_Q
        WRITE ( Restart_outunit ) Gw2sm
        WRITE ( Restart_outunit ) Actet_gw
        WRITE ( Restart_outunit ) Actet_tot_gwsz
        WRITE ( Restart_outunit ) Streamflow_sfr
!        WRITE ( Restart_outunit ) Uzf_infil_map
!        WRITE ( Restart_outunit ) Sat_recharge
!        WRITE ( Restart_outunit ) Mfoutflow_to_gvr
        WRITE ( Restart_outunit ) Reach_cfs
        WRITE ( Restart_outunit ) Reach_wse
      ELSE
        READ ( Restart_inunit ) module_name
        CALL check_restart(MODNAME, module_name)
        READ ( Restart_inunit ) Total_pump, Total_pump_cfs, Unsat_S, Sat_S, &
     &         Sat_dS, StreamExchng2Sat_Q, Stream2Unsat_Q, Stream_inflow, &
     &         Basin_gw2sm, LakeExchng2Sat_Q, Lake2Unsat_Q
        READ ( Restart_inunit ) Gw2sm
        READ ( Restart_inunit ) Actet_gw
        READ ( Restart_inunit ) Actet_tot_gwsz
        READ ( Restart_inunit ) Streamflow_sfr
!        READ ( Restart_inunit ) Uzf_infil_map
!        READ ( Restart_inunit ) Sat_recharge
!        READ ( Restart_inunit ) Mfoutflow_to_gvr
        READ ( Restart_inunit ) Reach_cfs
        READ ( Restart_inunit ) Reach_wse
      ENDIF
      END SUBROUTINE gsflow_budget_restart