!*******************************************************************************
!   Copyright(C) 2010-2014 Intel Corporation. All Rights Reserved.
!
!   The source code, information  and  material ("Material") contained herein is
!   owned  by Intel Corporation or its suppliers or licensors, and title to such
!   Material remains  with Intel Corporation  or its suppliers or licensors. The
!   Material  contains proprietary information  of  Intel or  its  suppliers and
!   licensors. The  Material is protected by worldwide copyright laws and treaty
!   provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
!   modified, published, uploaded, posted, transmitted, distributed or disclosed
!   in any way  without Intel's  prior  express written  permission. No  license
!   under  any patent, copyright  or  other intellectual property rights  in the
!   Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
!   implication, inducement,  estoppel or  otherwise.  Any  license  under  such
!   intellectual  property  rights must  be express  and  approved  by  Intel in
!   writing.
!
!   *Third Party trademarks are the property of their respective owners.
!
!   Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
!   this  notice or  any other notice embedded  in Materials by Intel or Intel's
!   suppliers or licensors in any way.
!
!*******************************************************************************
!  Content:
!   Intel(R) Math Kernel Library (MKL) FORTRAN 95 interface for service routines
!*******************************************************************************

MODULE MKL_SERVICE

    IMPLICIT NONE

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DOMAIN_ALL  = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DOMAIN_BLAS = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DOMAIN_FFT  = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DOMAIN_VML  = 3
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DOMAIN_PARDISO = 4

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DYNAMIC_TRUE  = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_DYNAMIC_FALSE = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_ENABLE_AVX512_MIC = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_ENABLE_AVX512 = 3
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_INTERFACE_LP64  = Z"00000000"
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_INTERFACE_ILP64 = Z"00000001"
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_INTERFACE_GNU   = Z"00000002"
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_THREADING_INTEL = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_THREADING_SEQUENTIAL = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_THREADING_PGI = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_THREADING_GNU = 3

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_BRANCH         = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ALL            = -1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_OFF            = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_UNSET_ALL      = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_BRANCH_OFF     = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_AUTO           = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_COMPATIBLE     = 3
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SSE2           = 4
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SSSE3          = 6
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SSE4_1         = 7
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SSE4_2         = 8
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_AVX            = 9
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_AVX2           = 10
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_AVX512_MIC     = 11
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_AVX512         = 12

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SUCCESS                 =  0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ERR_INVALID_SETTINGS    = -1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ERR_INVALID_INPUT       = -2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ERR_UNSUPPORTED_BRANCH  = -3
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ERR_UNKNOWN_BRANCH      = -4
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_ERR_MODE_CHANGE_FAILURE = -8

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_PEAK_MEM_DISABLE        =  0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_PEAK_MEM_ENABLE         =  1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_PEAK_MEM_RESET          = -1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_PEAK_MEM                =  2

    INTERFACE
      SUBROUTINE MKL_GET_VERSION_STRING(BUF)
      CHARACTER*(*), INTENT(OUT) :: BUF
      END
    END INTERFACE

    INTERFACE
      DOUBLE PRECISION FUNCTION MKL_GET_CPU_FREQUENCY()
      END
    END INTERFACE

    INTERFACE
      DOUBLE PRECISION FUNCTION MKL_GET_MAX_CPU_FREQUENCY()
      END
    END INTERFACE

    INTERFACE
      DOUBLE PRECISION FUNCTION MKL_GET_CLOCKS_FREQUENCY()
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_GET_CPU_CLOCKS(CPU_CLOCKS)
      INTEGER(8), INTENT(OUT) ::  CPU_CLOCKS
      END
    END INTERFACE

! Threading control functions

    INTERFACE
      INTEGER(4) FUNCTION MKL_GET_MAX_THREADS()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_DOMAIN_GET_MAX_THREADS(DOMAIN)
      INTEGER(4), INTENT(IN) :: DOMAIN
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION  MKL_SET_NUM_THREADS_LOCAL(NTHRS)
      INTEGER(4), INTENT(IN) :: NTHRS
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_SET_NUM_THREADS(NTHRS)
      INTEGER(4), INTENT(IN) :: NTHRS
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_DOMAIN_SET_NUM_THREADS(NTHRS,DOMAIN)
      INTEGER(4), INTENT(IN) :: NTHRS
      INTEGER(4), INTENT(IN) :: DOMAIN
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_GET_DYNAMIC()
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_SET_DYNAMIC(MKL_DYNAMIC)
      INTEGER(4), INTENT(IN) :: MKL_DYNAMIC
      END
    END INTERFACE

! MKL Memory functions

    INTERFACE
      SUBROUTINE MKL_FREE(PTR)
      POINTER (PTR,MKL_DUMMY_VAR)
      INTEGER(8) :: MKL_DUMMY_VAR(1)
      END
    END INTERFACE

    INTERFACE
      INTEGER(8) FUNCTION MKL_MEM_STAT(N_BUFF)
      INTEGER(4), INTENT(OUT) :: N_BUFF
      END
    END INTERFACE

    INTERFACE
      INTEGER(8) FUNCTION MKL_PEAK_MEM_USAGE(RESET)
      INTEGER(4), INTENT(IN) :: RESET
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_FREE_BUFFERS()
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_THREAD_FREE_BUFFERS()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_DISABLE_FAST_MM()
      END
    END INTERFACE

! MKL Progress routine

    INTERFACE
      FUNCTION MKL_PROGRESS( THREAD, STEP, STAGE )
      INTEGER(4), INTENT(IN)    :: THREAD,STEP
      CHARACTER*(*), INTENT(IN) :: STAGE
      INTEGER          MKL_PROGRESS
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_ENABLE_INSTRUCTIONS(TYPE)
      INTEGER(4), INTENT(IN) :: TYPE
      END
    END INTERFACE

! MKL layer routines

    INTERFACE
      INTEGER(4) FUNCTION MKL_SET_INTERFACE_LAYER(MKL_INTERFACE)
      INTEGER(4), INTENT(IN) :: MKL_INTERFACE
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_SET_THREADING_LAYER(MKL_THREADING)
      INTEGER(4), INTENT(IN) :: MKL_THREADING
      END
    END INTERFACE

! MKL CBWR routines

    INTERFACE
      INTEGER(4) FUNCTION MKL_CBWR_GET(MKL_CBWR)
      INTEGER(4), INTENT(IN) :: MKL_CBWR
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_CBWR_SET(MKL_CBWR)
      INTEGER(4), INTENT(IN) :: MKL_CBWR
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_CBWR_GET_AUTO_BRANCH()
      END
    END INTERFACE

! MKL MIC service routines

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_TARGET_NONE = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_TARGET_HOST = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_TARGET_MIC  = 2

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_DEFAULT_TARGET_TYPE   = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_DEFAULT_TARGET_NUMBER = 0

    DOUBLE PRECISION, PARAMETER, PUBLIC :: MKL_MIC_AUTO_WORKDIVISION = -1.0
    DOUBLE PRECISION, PARAMETER, PUBLIC :: MKL_MPI_PPN = -1.0

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_ENABLE()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_DISABLE()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_DEVICE_COUNT()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_WORKDIVISION(TARGET_TYPE, TARGET_NUMBER, WD)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      DOUBLE PRECISION, INTENT(OUT) :: WD
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_WORKDIVISION(TARGET_TYPE, TARGET_NUMBER, WD)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      DOUBLE PRECISION, INTENT(IN)  :: WD
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_MAX_MEMORY(TARGET_TYPE, TARGET_NUMBER, MEM)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      INTEGER(8),       INTENT(IN)  :: MEM
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_FREE_MEMORY(TARGET_TYPE, TARGET_NUMBER)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_OFFLOAD_REPORT(ENABLED)
      INTEGER(4),       INTENT(IN)  :: ENABLED
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_DEVICE_NUM_THREADS(TARGET_TYPE, TARGET_NUMBER, NUM_THREADS)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER, NUM_THREADS
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_RESOURCE_LIMIT(FRACTION)
      DOUBLE PRECISION, INTENT(OUT) :: FRACTION
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_RESOURCE_LIMIT(FRACTION)
      DOUBLE PRECISION, INTENT(IN)  :: FRACTION
      END
    END INTERFACE

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_DEFAULT_FLAGS = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_DISABLE_HOST_FALLBACK  = 1

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_FLAGS()
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_SET_FLAGS(FLAG)
      INTEGER(4), INTENT(IN)  :: FLAG
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_MEMINFO(TARGET_TYPE, TARGET_NUMBER, TOTALMEM, FREEMEM)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      INTEGER(4),       INTENT(OUT) :: TOTALMEM
      INTEGER(4),       INTENT(OUT) :: FREEMEM
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_CPUINFO(TARGET_TYPE, TARGET_NUMBER, NCORES, NTHREADS, FREQ)
      INTEGER(4),       INTENT(IN)  :: TARGET_TYPE, TARGET_NUMBER
      INTEGER(4),       INTENT(OUT) :: NCORES
      INTEGER(4),       INTENT(OUT) :: NTHREADS
      DOUBLE PRECISION, INTENT(OUT) :: FREQ
      END
    END INTERFACE

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_SUCCESS           = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_NOT_IMPL          = 1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_HOST_FALLBACK     = 2
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_DISABLED          = 3
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_FAILED            = -1
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_HOST_FALLBACK_DISABLED = -2

    INTERFACE
      INTEGER(4) FUNCTION MKL_MIC_GET_STATUS()
      END
    END INTERFACE

    INTERFACE
      SUBROUTINE MKL_MIC_CLEAR_STATUS()
      END
    END INTERFACE

    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_REGISTRATION_DISABLE = 0
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_MIC_REGISTRATION_ENABLE  = 1

    INTERFACE
      SUBROUTINE MKL_MIC_REGISTER_MEMORY(ENABLE)
      INTEGER(4),        INTENT(IN) :: ENABLE
      END SUBROUTINE
    END INTERFACE

! MKL verbose function

    INTERFACE
      INTEGER(4) FUNCTION MKL_VERBOSE(ENABLE)
      INTEGER(4), INTENT(IN) :: ENABLE
      END
    END INTERFACE

    INTERFACE
      INTEGER(4) FUNCTION MKL_SET_ENV_MODE(MODE)
      INTEGER(4), INTENT(IN) :: MODE
      END
    END INTERFACE

! Obsolete names and routines
    INTEGER (KIND=4), PARAMETER, PUBLIC :: MKL_CBWR_SSE3           = 5

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

END MODULE MKL_SERVICE


*deck sf3eq2
      subroutine sf3eq2( a,        cx,       eta,      g4,
     &         h4,       icb,      icc,      ipt,      is,
     &         isf,      ls,       lsf,      ijgt,     ijx,
     &         ijy,      ijz,      klgt,     klx,      kly,
     &         klz,      lmnp1,    lmnv,     mcons,    nc,
     &         ncon,     nfct,     ngw,      nrcr,     nt,
     &         ntl,      ntu,      x,        y,        z,
     &         zet )
      implicit real*8 (a-h,o-z)
      logical ec
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      common /cxindx/ ntij,ntik,ntil,ntkl,ntjl,ntjk,ntij1,ntjk1,ntkl1,
     1  ijcxst(2),ikcxst(2),ilcxst(2),klcxst(2),jlcxst(2),jkcxst(2)
      common /dim21/ ipq(256)
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
      common /sf3ao/ ibl
      dimension a(*),cx(*),eta(mrcru,mconu,*),g4(*),h4(*),icb(4,24,*),
     1  ipt(*),ijgt(*),ijx(*),ijy(*),ijz(*),klgt(*),klx(*),kly(*),
     2  klz(*),lmnp1(*),lmnv(3,*),mcons(*),nc(*),ncon(*),nfct(*),ngw(*),
     3  nrcr(*),nt(*),ntl(*),ntu(*),x(mcu,*),y(mcu,*),z(mcu,*),
     4  zet(mconu,*)
      dimension ec(3), icxbg(3,3), jbl(2), kcxbg(3)
c
      ic=icb(inx,1,icc)
      jc=icb(jnx,1,icc)
      kc=icb(knx,1,icc)
      lc=icb(lnx,1,icc)
      icxbg(1,1)=ijcxst(1)+ipq((ic-1)*nt(isf)+1)*npri(1,1)+(jc-1)*ntij1
      icxbg(1,2)=icxbg(1,1)+(kc-jc)*ntij1
      kcxbg(3)=ilcxst(2)+((ic-1)*nc(ls)+(lc-1))*ntil
      kcxbg(1)=kcxbg(3)+(kc-ic)*(nc(ls)*ntil)
      kcxbg(2)=kcxbg(1)+(jc-kc)*(nc(ls)*ntil)
      icxbg(1,3)=ijcxst(1)+ipq((jc-1)*nt(isf)+1)*npri(1,1)+(kc-1)*ntij1
      icxbg(2,1)=ijcxst(2)+((ic-1)*nc(is)+(jc-1))*ntij
      icxbg(3,1)=icxbg(2,1)-(ic-jc)*((nc(is)-1)*ntij)
      icxbg(2,2)=icxbg(2,1)+(kc-jc)*ntij
      icxbg(3,2)=icxbg(2,2)-(ic-kc)*((nc(is)-1)*ntij)
      icxbg(2,3)=icxbg(2,2)+(jc-ic)*nc(is)*ntij
      icxbg(3,3)=icxbg(2,3)-(jc-kc)*((nc(is)-1)*ntij)
      ec(1)=ic.eq.jc
      ec(3)=jc.eq.kc
      ec(2)=ic.eq.kc
      do 12 jesfb=1,2
        jbl(jesfb)=0
        do 10 ist=1,nst
          jbl(jesfb)=jbl(jesfb)+npriri(jesfb,1,ist)*nprirk(2,1,ist)
   10   continue
   12 continue
      jbl1=(ircru*lrcru)*jbl(1)
      jbl2=(ircru*lrcru)*jbl(2)
      jbld=jbl2-jbl1
      if(ec(1)) then
        nwt1(1) = 1
        if(ec(3)) then
          iscmu = 1
          go to 48
        else
          iscmu = 2
          go to 44
        endif
      endif
      if(ec(3)) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 1
        go to 52
      endif
      if(ngw(icc).eq.1) go to 40
      isw2 = 2
      isw3 = 3
      do 24 igw=2,ngw(icc)
        if(icb(lnx,igw,icc).ne.lc) go to 24
        if(icb(jnx,igw,icc).eq.kc) isw2=1
        if(icb(inx,igw,icc).eq.jc) isw3=min(isw3,2)
        if(icb(inx,igw,icc).eq.kc) isw3=1
   24 continue
      if(isw3.eq.1) then
        if(isw2.eq.1) then
          iscmu = 1
          nwt1 (1) = 3
          go to 48
        else
          iscmu = 2
          nwt1(1) = 2
          go to 44
        endif
      endif
      if(isw3.eq.2) then
        iscmu = 2
        nwt1(1) = 1
        nwt1(2) = 2
        go to 48
      endif
      if(isw2.eq.1) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 2
        go to 52
      endif
   40 iscmu = 3
      nwt1(1) = 1
   44 nwt1(2) = 1
   48 iscml = 1
   52 nwt2 = nwt * nfct(icc)
      ngt=nt(isf)*(nt(isf)*(nt(isf)*nt(lsf)))
      do 98 iscm=iscml,iscmu
      fnfct=nwt1(iscm)*nwt2
      if(iscm-2) 56, 60, 64
   56 call jandk(a,eta,g4,ipt,is,isf,ic,is,isf,jc,is,isf,kc,ls,lsf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 68
   60 call jandk(a,eta,g4,ipt,is,isf,ic,is,isf,kc,is,isf,jc,ls,lsf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 68
   64 call jandk(a,eta,g4,ipt,is,isf,jc,is,isf,kc,is,isf,ic,ls,lsf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
   68 ndx=1
      do 96 ircr=1,ircru
      if(ec(iscm)) jrcru=ircr
      do 94 jrcr=1,jrcru
      if(ircr-jrcr) 70, 72, 74
   70 iblb=(ipq(jrcr)+(ircr-1))*jbl2-(jrcr-1)*jbld
      iesfb=2
      icxbg1=icxbg(3,iscm)
      ngti=(nt(isf)*nt(lsf))
      ngtj=(nt(isf)*(nt(isf)*nt(lsf)))
      go to 78
   72 iblb=ipq(ircr)*jbl2+(ircr-1)*jbl1
      iesfb=1
      go to 76
   74 iblb=(ipq(ircr)+(jrcr-1))*jbl2-(ircr-1)*jbld
      iesfb=2
   76 icxbg1=icxbg(iesfb,iscm)
      ngti=(nt(isf)*(nt(isf)*nt(lsf)))
      ngtj=(nt(isf)*nt(lsf))
   78 do 92 krcr=1,ircru
      do 90 lrcr=1,lrcru
      icxs(iesfb,iscm)=icxbg1
      ndxi=ndx
      do 88 it=itl,itu
        if(ircr.eq.jrcr.and.ec(iscm)) jtu = it
        ndxj=ndxi
        do 86 jt=itl,jtu
          kcxs(2,iscm)=kcxbg(iscm)
          ndxl=ndxj
          do 84 kt=itl,itu
            do 82 lt=ltl,ltu
              val=g4(ndxl)
              if(abs(val).le.cutoff) go to 80
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, iscm, val )
   80         ndxl=ndxl+1
              kcxs(2,iscm)=kcxs(2,iscm)+nprk(2,1)
   82       continue
   84     continue
          ndxj=ndxj+ngtj
          icxs(iesfb,iscm)=icxs(iesfb,iscm)+npri(iesfb,1)
   86   continue
        ndxi=ndxi+ngti
   88 continue
      iblb=iblb+jbl(iesfb)
      ndx=ndx+ngt
   90 continue
   92 continue
   94 continue
   96 continue
   98 continue
      return
      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE LTSORT (MDIM, LINK, ID, IPNTR, ADDLNK)
C***********************************************************************

C  SUBROUTINE LTSORT = LOOKUP TABLE SORT FOR DATA POINTER ARRAYS

C***********************************************************************

C  VARIABLES USED:
C     MDIM   = DIMENSION OF LINK ARRAY,  AND BASE FOR LOOKUP START
C     LINK   = LOOKUP TABLE ARRAY OF ID'S AND POINTERS
C              LINK (1, I) = ID VALUE STORED IN I'TH ROW  (0 IF EMPTY)
C              LINK (2, I) = DATA POINTER ASSOCIATED W/THIS I'TH ID VALUE
C     ID     = THE ID OF THE DATA BEING FOUND OR PLACED
C     IPNTR  = THE DATA POINTER ASSOCIATED WITH THE ID BEING USED
C     ADDLNK = .TRUE. IF DATA IS BEING PLACED IN THE LOOKUP TABLE
C            = .FALSE. IF DATA IS BEING FOUND ONLY

C***********************************************************************

      DIMENSION LINK (2, MDIM)

      LOGICAL ADDLNK

C  CALCULATE THE BEGINNING LOOKUP VALUE

      if (id .lt. 0) stop 'LTSORT: Internal error'

      HOLD = DBLE(ID) * 3.1830989
      LOOKUP =  INT((HOLD - INT (HOLD)) * DBLE(MDIM) + 1)

C  SET UP THE LOOP TO ONLY SEARCH THROUGH THE TABLE ONCE

      DO 100 I = 1, MDIM

C  IF LOOKUP SPOT IS EMPTY THEN FILL AND RETURN IF ADDING AND IPNTR .NE. 0
C  OR FLAG IPNTR AS BEING EMPTY AND RETURN IF FINDING

         IF (LINK (1, LOOKUP) .EQ. 0) THEN
            IF ( (ADDLNK) .AND. (IPNTR .NE. 0)) THEN
               LINK (1, LOOKUP) = ID
               LINK (2, LOOKUP) = IPNTR
            ELSEIF (IPNTR .NE. 0) THEN
               IPNTR = 0
            ENDIF
            RETURN

C  IF LOOKUP SLOT IS FULL,  CHECK TO SEE IF IT MATCHES THE CURRENT ID
C  IF IT MATCHES AND IF ADDING,  SET THE NEW POINTER  (OVERWRITE)
C  IF IT MATCHES AND IF FINDING,  RETURN THE CORRECT POINTER
C  IF NO MATCH,  THEN INCREMENT LOOKUP AND TRY AGAIN IN THE TABLE

         ELSE
            IF (ID .EQ. LINK (1, LOOKUP)) THEN
               IF (ADDLNK) THEN
                  LINK (2, LOOKUP) = IPNTR
               ELSE
                  IPNTR = LINK (2, LOOKUP)
               ENDIF
               RETURN
            ELSE
               LOOKUP = LOOKUP + 1
               IF (LOOKUP .GT. MDIM)LOOKUP = 1
            ENDIF
         ENDIF
  100 CONTINUE

C  ACT ON THE EXHAUSTED SEARCH

      IF (ADDLNK) THEN
         CALL MESAGE ('LOOKUP TABLE OVERFLOW')
         CALL MESAGE ('SERIOUS DATA PROBLEMS HAVE BEEN CAUSED')
      ELSE
         IPNTR = 0
      ENDIF
      RETURN

      END


	SUBROUTINE MT_VISB ( strvs1, strvs2, ivis, idecd, twofld,
     +			     dirvis, iret)
C************************************************************************
C* MT_VISB                                                              *
C*                                                                      *
C* This subroutine will decode up to two visibility groups.  The	*
C* values are stored in common.						*
C* 								        *
C* MT_VISB ( STRVS1, STRVS2, IVIS, IDECD, TWOFLD, DIRVIS, IRET )	*
C*								        *
C* Input parameters: 						        *
C*      STRVS1		CHAR*		Visibility field       		*
C*      STRVS2		CHAR*		Fractional part of visibility	*
C*	IVIS		INTEGER		Relative number of vis. group   *
C*								        *
C* Output parameters:						        *
C*	RIVALS(IRVSBY)  REAL            Horizontal visibility (sm)      *
C*	RIVALS(IRVSBK)  REAL            Horizontal visibility (km)      *
C*	RIVALS(IRVSFL)  REAL            Visibility P or M indicator     *
C*	RIVALS(IRNVSB)  REAL            Number of visibility groups     *
C*	IDECD		INTEGER		Decode decision flag            *
C*					  2 = auto report with field	*
C*						decoded having slashes	*
C*					  1 = field decoded     	*
C*					  0 = field not decoded		*
C*	TWOFLD		LOGICAL		Two field flag			*
C*	DIRVIS		LOGICAL		Directional visibility flag	*
C*	IRET		INTEGER		Return code                     *
C*	      		    		  0 = normal return		*
C*					  9 = miscoded field		*
C*	                                 -1 = no field found		*
C**								        *
C* Log:									*
C* D. Kidwell/NCEP 	 4/95                                           *
C* D. Kidwell/NCEP    	 6/95   Added international group / meters      *
C* K. Tyle/GSC		 1/97	Set "M1/4SM" to 0; correctly decode 	*
C*				some miscoded fractional visibilities;	*
C*				change call to DC_WLOG; reorganize	*
C*				header and comments			*
C* K. Tyle/GSC		 2/97	Changed error processing		*
C* D. Kidwell/NCEP    	 5/97   Removed ERMISS reference to integer arg *
C* D. Kidwell/NCEP    	 6/97   ST_LSTR -> INDEX and ST_CRNM -> ST_INTG *
C* D. Kidwell/NCEP    	 6/97   Added check for string of length .ge. 40*
C* D. Kidwell/NCEP    	 4/98   New interface; reinstate "M1/4SM" as ok *
C* A. Hardy/GSC          7/98   Added ability to decode vis. in KM      *
C* D. Kidwell/NCEP    	 9/02   Moved most of code to BR_VISB           *
C* F. J. Yen/NCEP	 2/04	Updated call to BR_VISB due to CSC.	*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
	INCLUDE 	'mtcmn.cmn'
C*
	CHARACTER*(*) 	strvs1, strvs2
	LOGICAL 	twofld, dirvis
C*
	INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret   = 0
C
	autof = rivals ( irauto )
	CALL BR_VISB ( strvs1, strvs2, autof, visby, visbk, visfl,
     +		       idecd, twofld, dirvis, iret )
	IF ( .not. ERMISS ( visby ) )
     +		   rivals ( irvsby ( ivis ) ) = visby
	IF ( .not. ERMISS ( visbk ) )
     +		   rivals ( irvsbk ( ivis ) ) = visbk
	IF ( .not. ERMISS ( visfl ) )
     +		   rivals ( irvsfl ( ivis ) ) = visfl
	IF ( ( .not. ERMISS (visby) ) .or. ( .not. ERMISS (visbk) ) )
     +		   rivals ( irnvsb ) = ivis
C*
	RETURN
	END


      SUBROUTINE ADMDUM(N,DELTAT,DEP,DER,UPBND,DNBND,FACTOR,FRQ
     1                 ,TTSTP,LSAVE,T,DELMIT)
C
C     'ADMDUM' COMPUTES STATE VECTOR WITHOUT INTEGRATION IE NO MOTION
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      COMMON/CENVRN/ GGMOM(3),SPMOM(3),ADMOM(3),HUBSPM(3),HUBADM(3)
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/CNBODY/ ZJ2,ZJ3,ZJ4,ZJ22,ZJ20,ZMU,WWO,FLAT,AEARTH
C
      COMMON/CSTVAL/ TSTART,ZLDUM(40)
C
      COMMON/IMAIN1/ IDATE,ISAVE,INOPT,IPLOT,NUMEQS,IPLTPE,IORB,ITAPE
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/INOMOT/ NOINTG,NOIOUT(20)
C
      COMMON/KNERGY/ S,OMC,BT
C
      COMMON/LIBDPR/ ZK1D,ZK2D,PHIS,PHILD,DPHILD,BETLD,GAMLD,ZMDO
     *              ,ZMDBO,CNV,DECAY
C
      COMMON/ORBNEW/ ROD(3),VOD(3),TST
C
      COMMON/OUTTHR/ SMAGB(3)
C
      COMMON/RMGNTC/ SMAGI(3)
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL2/ PO,SD(3),DUMRP2(72),SD1(3),DT1,P1,AERO,DTO1,YZK(3)
     .              ,PO1
C
      COMMON/RPOOL6/ FM(3,3),CIY(3,3),CIZ(3,3),SAT(3,3),SZ1,SZ2,SZ3
C
      COMMON/SUNVTR/ SDBODY(3)
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
      COMMON/XIN2  / ALFAE,BETAE,GAMAE,OMBC(3),ITEST2
C
C
C
      DIMENSION S(3,3),ST(3,3),BS(3,3),BT(3,3),OMC(3),SXOMC(3)
     .          ,DEPEND(150),DEP(150),DER(150),UPBND(150),DNBND(150)
     .          ,SSPM(3),SADM(3)
C
      REAL*4 BUFF(450)
C
      IF(NOINTG.NE.0) GO TO 2
C
      CALL ADMIMP(N,DELTAT,DEP,DER,UPBND,DNBND,FACTOR,FRQ
     1           ,TTSTP,LSAVE,T,DELMIT)
C
      DO 1 I=1,3
      SSPM(I)=SPMOM(I) + HUBSPM(I)
      SADM(I)=ADMOM(I) + HUBADM(I)
    1 CONTINUE
C
      RETURN
C
    2 CONTINUE
C
C
      IF(LSAVE.EQ.1) GO TO 100
C
C     INCREASE TIME TO NEXT PRINT TIME
C
      T=T+FRQ
C
      LSAVE=1
C
      IF(INOPT.EQ.1) GO TO 100
C
      CALL XFIND(ROD,VOD,ZMU,TSTART,T,XSAT,XSATDT)
C
      RADIUS=0.D0
      DO 5 I=1,3
    5 RADIUS=RADIUS + XSAT(I)*XSAT(I)
      RADIUS=DSQRT(RADIUS)
C
      ALFAE=ALFAE*RADIAN
      BETAE=BETAE*RADIAN
      GAMAE=GAMAE*RADIAN
C
      SALFAE=DSIN(ALFAE)
      CALFAE=DCOS(ALFAE)
      SBETAE=DSIN(BETAE)
      CBETAE=DCOS(BETAE)
      SGAMAE=DSIN(GAMAE)
      CGAMAE=DCOS(GAMAE)
C
      ANG1=CBETAE*CGAMAE
      ANG2=CBETAE*SGAMAE
      ANG3=SBETAE*SGAMAE
      ANG4=SBETAE*CGAMAE
C
      S(1,1)= ANG1 + SALFAE*ANG3
      S(2,1)=-ANG2 + SALFAE*ANG4
      S(3,1)= CALFAE*SBETAE
C
      S(1,2)= CALFAE*SGAMAE
      S(2,2)= CALFAE*CGAMAE
      S(3,2)=-SALFAE
C
      S(1,3)=-ANG4 + SALFAE*ANG2
      S(2,3)= ANG3 + SALFAE*ANG1
      S(3,3)= CALFAE*CBETAE
C
      DO 10 I=1,3
      DO 10 J=1,3
   10 ST(I,J)=S(J,I)
C
      DO 20 I=1,3
   20 BS(3,I)=XSAT(I)/RADIUS
      YZ=XSAT(2)*XSATDT(3) - XSAT(3)*XSATDT(2)
      ZX=XSAT(3)*XSATDT(1) - XSAT(1)*XSATDT(3)
      XY=XSAT(1)*XSATDT(2) - XSAT(2)*XSATDT(1)
C
      RXVMAG=DSQRT(YZ*YZ + ZX*ZX + XY*XY)
C
      BS(2,1)=YZ/RXVMAG
      BS(2,2)=ZX/RXVMAG
      BS(2,3)=XY/RXVMAG
C
      BS(1,1)=BS(2,2)*BS(3,3)-BS(2,3)*BS(3,2)
      BS(1,2)=BS(2,3)*BS(3,1)-BS(2,1)*BS(3,3)
      BS(1,3)=BS(2,1)*BS(3,2)-BS(2,2)*BS(3,1)
C
      DO 30 I=1,3
      DO 30 J=1,3
   30 BT(I,J)=BS(J,I)
C
      CALL MATMPY(BT,ST,SA,3,3)
C
      DO 40 I=1,3
      DO 40 J=1,3
   40 SAT(I,J)=SA(J,I)
C
C
      ALFAE=ALFAE/RADIAN
      BETAE=BETAE/RADIAN
      GAMAE=GAMAE/RADIAN
C
      L=0
      DO 80 I=1,2
      DO 80 J=1,3
      L=L + 1
   80 DEP(L)  = SA(I,J)
C
C
C
  100 CONTINUE
C
C
      IF(LSAVE.NE.1) GO TO 110
C
      DO 105 I = 1,3
      ROD(I) =  XSAT(I)
      VOD(I) =  XSATDT(I)
  105 CONTINUE
C
      TSTART=T
      TST = TSTART
  110 CONTINUE
C
C
C
      CALL ADMIMP(N,DELTAT,DEP,DER,UPBND,DNBND,FACTOR,FRQ
     1           ,TTSTP,LSAVE,T,DELMIT)
C
C
C
      DO 120 I=1,3
      SSPM(I)=SPMOM(I) + HUBSPM(I)
      SADM(I)=ADMOM(I) + HUBADM(I)
  120 CONTINUE
C
C
C
      RETURN
C
C   *************************************************************
      ENTRY ADMWRP(BUFF,INDEX)
C   *************************************************************
C
C     CALLED FROM GPPLOT
C
      DO 201 I=1,3
      I1=INDEX + I - 1
      I2=I1 + 3
      I3=I2 + 3
      BUFF(I1)=GGMOM(I)
      BUFF(I2)= SSPM(I)
      BUFF(I3)= SADM(I)
  201 CONTINUE
C
C
      RETURN
C
C
C   *************************************************************
      ENTRY ADMPRN
C   *************************************************************
C
C     CALLED FROM GPSOUT
C
      DATA I8/',A8,'/
C
      IF(NOIOUT(1).EQ.0) GO TO 315
C
      DO 310 I=1,3
      CALL SET('GG MOM  ',I,0,GGMOM(I),I8)
  310 CONTINUE
C
  315 CONTINUE
C
      IF(NOIOUT(2).EQ.0) GO TO 325
C
      DO 320 I=1,3
      CALL SET('SP MOM  ',I,0,SSPM(I) ,I8)
  320 CONTINUE
C
  325 CONTINUE
C
      IF(NOIOUT(3).EQ.0) GO TO 335
C
      DO 330 I=1,3
      CALL SET('AD MOM  ',I,0,SADM(I) ,I8)
  330 CONTINUE
C
  335 CONTINUE
C
      RETURN
      END


Subroutine cellre(i, t)
  Implicit Double Precision (A-H, O-Z)
  Parameter (maxptn=400001)
  Common /para5/iconfg, iordsc
  Common /prec2/gx(maxptn), gy(maxptn), gz(maxptn), ft(maxptn), px(maxptn), py(maxptn), pz(maxptn), e(maxptn), xmass(maxptn), ityp(maxptn)
  Common /prec4/vx(maxptn), vy(maxptn), vz(maxptn)
  Common /aurec1/jxa, jya, jza
  Common /aurec2/dgxa(maxptn), dgya(maxptn), dgza(maxptn)
  Common /ilist1/iscat, jscat, next(maxptn), last(maxptn), ictype, icsta(maxptn), nic(maxptn), icels(maxptn)
  Common /ilist2/icell, icel(10, 10, 10)
  Common /ilist3/size1, size2, size3, v1, v2, v3, size
  Common /ilist4/ifmpt, ichkpt, indx(maxptn)
  Common /ilist5/ct(maxptn), ot(maxptn), tlarge
  Save
  Logical good
  External integ
  t0 = t
1000 Continue
  If (iconfg==3 .Or. iconfg==5) Then
     k = mod(icsta(i), 10)
     If (k==1) Then
        gx(i) = gx(i) - 10D0*size1
        dgxa(i) = dgxa(i) + 10D0*size1
        Do ii = 1, ichkpt
           If (next(ii)==i) Then
              dgxa(ii) = dgxa(ii) - 10D0*size1
           End If
        End Do
     End If
     If (k==2) Then
        gx(i) = gx(i) + 10D0*size1
        dgxa(i) = dgxa(i) - 10D0*size1
        Do ii = 1, ichkpt
           If (next(ii)==i) Then
              dgxa(ii) = dgxa(ii) + 10D0*size1
           End If
        End Do
     End If
     If (k==3) Then
        gy(i) = gy(i) - 10D0*size2
        dgya(i) = dgya(i) + 10D0*size2
        Do ii = 1, ichkpt
           If (next(ii)==i) Then
              dgya(ii) = dgya(ii) - 10D0*size2
           End If
        End Do
     End If
     If (k==4) Then
        gy(i) = gy(i) + 10D0*size2
        dgya(i) = dgya(i) - 10D0*size2
        Do ii = 1, ichkpt
           If (next(ii)==i) Then
              dgya(ii) = dgya(ii) + 10D0*size2
           End If
        End Do
     End If
     If (iconfg==5) Then
        If (k==5) Then
           gz(i) = gz(i) - 10D0*size3
           dgza(i) = dgza(i) + 10D0*size3
           Do ii = 1, ichkpt
              If (next(ii)==i) Then
                 dgza(ii) = dgza(ii) - 10D0*size3
              End If
           End Do
        End If
        If (k==6) Then
           gz(i) = gz(i) + 10D0*size3
           dgza(i) = dgza(i) - 10D0*size3
           Do ii = 1, ichkpt
              If (next(ii)==i) Then
                 dgza(ii) = dgza(ii) + 10D0*size3
              End If
           End Do
        End If
     End If
  Else
     icels0 = icels(i)
     i1 = icels0/10000
     i2 = (icels0-i1*10000)/100
     i3 = icels0 - i1*10000 - i2*100
     If (i1>=1 .And. i1<=10 .And. i2>=1 .And. i2<=10 .And. i3>=1 .And. i3<=10) Then
        If (icel(i1,i2,i3)==i) icel(i1, i2, i3) = nic(i)
        Call oldcre(i)
        k = mod(icsta(i), 10)
        If (iconfg==1) Then
           good = (i1==1 .And. k==2) .Or. (i1==10 .And. k==1) .Or. (i2==1 .And. k==4) .Or. (i2==10 .And. k==3) .Or. (i3==1 .And. k==6) .Or. (i3==10 .And. k==5)
        End If
        If (iconfg==2) Then
           good = (i3==1 .And. k==6) .Or. (i3==10 .And. k==5)
        End If
        If (good) Then
           Call newcre(i, icell)
           icels(i) = 111111
        Else
           If (k==1) i1 = i1 + 1
           If (k==2) i1 = i1 - 1
           If (k==3) i2 = i2 + 1
           If (k==4) i2 = i2 - 1
           If (k==5) i3 = i3 + 1
           If (k==6) i3 = i3 - 1
           If (iconfg==2 .Or. iconfg==4) Then
              If (i1==0) Then
                 i1 = 10
                 gx(i) = gx(i) + 10D0*size1
              End If
              If (i1==11) Then
                 i1 = 1
                 gx(i) = gx(i) - 10D0*size1
              End If
              If (i2==0) Then
                 i2 = 10
                 gy(i) = gy(i) + 10D0*size2
              End If
              If (i2==11) Then
                 i2 = 1
                 gy(i) = gy(i) - 10D0*size2
              End If
              If (iconfg==4) Then
                 If (i3==0) Then
                    i3 = 10
                    gz(i) = gz(i) + 10D0*size3
                 End If
                 If (i3==11) Then
                    i3 = 1
                    gz(i) = gz(i) - 10D0*size3
                 End If
              End If
           End If
           j = icel(i1, i2, i3)
           Call newcre(i, j)
           icel(i1, i2, i3) = j
           icels(i) = i1*10000 + i2*100 + i3
        End If
     Else
        If (icell==i) icell = nic(i)
        Call oldcre(i)
        k = mod(icsta(i), 10)
        ddt = t - ft(i)
        dtt = t - size
        If (dtt<=0D0) Then
           i1 = integ((gx(i)+vx(i)*ddt)/size1) + 6
           i2 = integ((gy(i)+vy(i)*ddt)/size2) + 6
           i3 = integ((gz(i)+vz(i)*ddt)/size3) + 6
        Else
           i1 = integ((gx(i)+vx(i)*ddt)/(size1+v1*dtt)) + 6
           i2 = integ((gy(i)+vy(i)*ddt)/(size2+v2*dtt)) + 6
           i3 = integ((gz(i)+vz(i)*ddt)/(size3+v3*dtt)) + 6
        End If
        If (k==1) i1 = 1
        If (k==2) i1 = 10
        If (k==3) i2 = 1
        If (k==4) i2 = 10
        If (k==5) i3 = 1
        If (k==6) i3 = 10
        j = icel(i1, i2, i3)
        Call newcre(i, j)
        icel(i1, i2, i3) = j
        icels(i) = i1*10000 + i2*100 + i3
     End If
  End If
  If (next(i)/=0) Then
     otmp = ot(next(i))
     ctmp = ct(next(i))
  End If
  If (i1==11 .And. i2==11 .And. i3==11) Then
     Call dchout(i, k, t)
  Else
     If (iconfg==1) Then
        Call dchin1(i, k, i1, i2, i3, t)
     Else If (iconfg==2) Then
        Call dchin2(i, k, i1, i2, i3, t)
     Else If (iconfg==4) Then
        Call dchin3(i, k, i1, i2, i3, t)
     End If
  End If
  If (icsta(i)/10==11) Then
     ot(next(i)) = otmp
     ct(next(i)) = ctmp
     next(next(i)) = i
     Call wallc(i, i1, i2, i3, t0, tmin1)
     If (tmin1<ct(i)) Then
        icsta(i) = icsta(i) + 10
        t0 = tmin1
        Goto 1000
     End If
  End If
  Return
End Subroutine cellre


!***********************************************************************
!  Integrated Water Flow Model (IWFM)
!  Copyright (C) 2005-2021
!  State of California, Department of Water Resources
!
!  This program is free software; you can redistribute it and/or
!  modify it under the terms of the GNU General Public License
!  as published by the Free Software Foundation; either version 2
!  of the License, or (at your option) any later version.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!  (http://www.gnu.org/copyleft/gpl.html)
!
!  You should have received a copy of the GNU General Public License
!  along with this program; if not, write to the Free Software
!  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
!
!  For tecnical support, e-mail: IWFMtechsupport@water.ca.gov
!***********************************************************************
MODULE Class_Lake
  USE MessageLogger          , ONLY: SetLastMessage           , &
                                     MessageArray             , &
                                     iFatal
  USE GeneralUtilities       , ONLY: AllocArray               , &
                                     GetUniqueArrayComponents , &
                                     ShellSort                , &
                                     LocateInList             , &
                                     IntToText                , &
                                     ConvertID_To_Index
  USE IOInterface            , ONLY: GenericFileType
  USE Package_Misc           , ONLY: PairedDataType
  USE Package_Discretization , ONLY: AppGridType
  IMPLICIT NONE

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** VARIABLE DEFINITIONS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- PUBLIC ENTITIES
  ! -------------------------------------------------------------
  PRIVATE
  PUBLIC :: LakeType              , &
            ReadInitialLakeElevs

  ! -------------------------------------------------------------
  ! --- LAKE DATA TYPE
  ! -------------------------------------------------------------
  TYPE LakeType
      CHARACTER(LEN=200)   :: cName           = ''       !Name of the lake
      INTEGER              :: ID              = 0        !Lake ID
      INTEGER              :: NElements       = 0        !Number of lake elements
      INTEGER              :: NNodes          = 0        !Number of groundwater nodes under lake
      REAL(8)              :: Area            = 0.0      !Lake area
      REAL(8)              :: Storage         = 0.0      !Lake storage at current time
      REAL(8)              :: Storage_P       = 0.0      !Lake storage at previous time
      REAL(8)              :: Elev            = 0.0      !Lake elevation at current time
      REAL(8)              :: Elev_P          = 0.0      !Lake elevation at the previous time
      REAL(8)              :: MaxElev         = 0.0      !Maximum lake elevation
      INTEGER              :: iColPrecip      = 0        !Pointer to a data column in precipitation data file
      INTEGER              :: iColET          = 0        !Pointer to data column in the potential ET data file
      REAL(8)              :: ETp_Rate        = 0.0      !Potential ET rate at lake
      REAL(8)              :: ETa             = 0.0      !Actual ET at lake
      REAL(8)              :: InflowUpLake    = 0.0      !Inflow into lake from upstream lakes
      REAL(8)              :: Outflow         = 0.0      !Lake outflow
      INTEGER              :: OutflowDestType = 0        !Destination type for outflow
      INTEGER              :: OutflowDest     = 0        !Outflow destination
      REAL(8)              :: PrecipRate      = 0.0      !Precipitation rate over lake
      INTEGER,ALLOCATABLE  :: Elements(:)                !List of elements under lake
      INTEGER,ALLOCATABLE  :: Nodes(:)                   !List of nodes under lake
      REAL(8),ALLOCATABLE  :: NodeAreas(:)               !Lake area associated with a lake node
      TYPE(PairedDataType) :: RatingTable                !Elevation vs. storage rating table
  CONTAINS
      PROCEDURE,PASS :: CompileLakeNodes
      PROCEDURE,PASS :: ComputeLakeNodeAreas
  END TYPE LakeType

  ! -------------------------------------------------------------
  ! --- MISC. DATA
  ! -------------------------------------------------------------
  INTEGER,PARAMETER                   :: ModNameLen = 12
  CHARACTER(LEN=ModNameLen),PARAMETER :: ModName    = 'Class_Lake::'

CONTAINS

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** MISC. METHODS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- COMPILE LIST OF GROUNDWATER NODES FOR ALL LAKE
  ! -------------------------------------------------------------
  SUBROUTINE CompileLakeNodes(Lake,AppGrid,iStat)
    CLASS(LakeType)              :: Lake
    TYPE(AppGridType),INTENT(IN) :: AppGrid
    INTEGER,INTENT(OUT)          :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+16) :: ThisProcedure = ModName // 'CompileLakeNodes'
    INTEGER                      :: indxElem,iCounter,ErrorCode,ElemNo,NVertex,NNodes
    INTEGER,ALLOCATABLE          :: Nodes(:)

    !Initialize
    iStat    = 0
    iCounter = 0

    !Total number of nodes
    NNodes = SUM(AppGrid%NVertex(Lake%Elements))

    !Allocate memory
    CALL AllocArray(Nodes,NNodes,ThisProcedure,iStat)
    IF (iStat .EQ. -1) RETURN

    !Compile all nodes
    DO indxElem=1,Lake%NElements
      ElemNo                             = Lake%Elements(indxElem)
      NVertex                            = AppGrid%NVertex(ElemNo)
      Nodes(iCounter+1:iCounter+NVertex) = AppGrid%Vertex(1:NVertex,ElemNo)
      iCounter                           = iCounter + NVertex
    END DO

    !Store unique nodes in persistent array
    CALL GetUniqueArrayComponents(Nodes,Lake%Nodes)

    !Sort the nodes
    CALL ShellSort(Lake%Nodes)

    !Number of nodes
    Lake%NNodes = SIZE(Lake%Nodes)

    !Clear memory
    DEALLOCATE (Nodes , STAT=ErrorCode)

  END SUBROUTINE CompileLakeNodes

  ! -------------------------------------------------------------
  ! --- COMPUTE LAKE NODE AREAS
  ! -------------------------------------------------------------
  SUBROUTINE ComputeLakeNodeAreas(Lake,AppGrid)
    CLASS(LakeType)              :: Lake
    TYPE(AppGridType),INTENT(IN) :: AppGrid

    !Local variables
    INTEGER :: indxElem,indxNode,iNode,ElemNo,NVertex,Vertex(4),iLoc
    REAL(8) :: VertexArea(4)

    !Initialize
    ALLOCATE (Lake%NodeAreas(Lake%NNodes))
    Lake%NodeAreas = 0.0

    !Compute nodal areas
    DO indxElem=1,Lake%NElements
        ElemNo                = Lake%Elements(indxElem)
        NVertex               = AppGrid%NVertex(ElemNo)
        Vertex                = AppGrid%Vertex(:,ElemNo)
        VertexArea(1:NVertex) = AppGrid%AppElement(ElemNo)%VertexArea
        DO indxNode=1,NVertex
            iNode = Vertex(indxNode)
            iLoc  = LocateInList(iNode,Lake%Nodes)
            Lake%NodeAreas(iLoc) = Lake%NodeAreas(iLoc) + VertexArea(indxNode)
        END DO
    END DO

    !Total lake area
    Lake%Area = SUM(Lake%NodeAreas)

  END SUBROUTINE ComputeLakeNodeAreas

  ! -------------------------------------------------------------
  ! --- READ INITIAL LAKE ELEVATIONS
  ! -------------------------------------------------------------
  SUBROUTINE ReadInitialLakeElevs(LakeDataFile,Lakes,iLakeIDs,iStat)
    TYPE(GenericFileType) :: LakeDataFile
    TYPE(LakeType)        :: Lakes(:)
    INTEGER,INTENT(IN)    :: iLakeIDs(:)
    INTEGER,INTENT(OUT)   :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+20) :: ThisProcedure = ModName // 'ReadInitialLakeElevs'
    INTEGER                      :: NLakes,indxLake,ID,iLake
    REAL(8)                      :: Fact,DummyArray(2)
    LOGICAL                      :: lProcessed(SIZE(iLakeIDs))

    !Initialize
    iStat      = 0
    NLakes     = SIZE(Lakes)
    lProcessed = .FALSE.

    !Read conversion factor
    CALL LakeDataFile%ReadData(Fact,iStat)
    IF(iStat .EQ. -1) RETURN

    !Read initial lake elavtions and process
    DO indxLake=1,NLakes
        CALL LakeDataFile%ReadData(DummyArray,iStat)
        IF(iStat .EQ. -1) RETURN

        !Make sure that lake ID number is recognized
        ID = INT(DummyArray(1))
        CALL ConvertID_To_Index(ID,iLakeIDs,iLake)
        IF (iLake .EQ. 0) THEN
            CALL SetLastMessage('Lake ID '//TRIM(IntToText(ID))//' listed for inital lake elevation is not recognized!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Make sure lake data was not entered previously
        IF (lProcessed(iLake)) THEN
            CALL SetLastMessage('Initial elevation for lake '//TRIM(IntToText(ID))//' is entered more than once!',iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF
        lProcessed(iLake) = .TRUE.

        !Assign initial elevations
        Lakes(iLake)%Elev   = DummyArray(2) * Fact
        Lakes(iLake)%Elev_P = Lakes(iLake)%Elev

        !Make sure that initial elevations are not less than the lowest ground surface elevation
        IF (Lakes(iLake)%Elev .LT. Lakes(iLake)%RatingTable%XPoint(1)) THEN
            MessageArray(1) = 'Initial lake elevation for lake '//TRIM(IntToText(ID))//' is lower than the lowest ground surface elevation!'
            WRITE(MessageArray(2),'(A,F8.4)') 'Lowest ground surface elevation = ',Lakes(iLake)%RatingTable%XPoint(1)
            WRITE(MessageArray(3),'(A,F8.4)') 'Initial lake elevation          = ',Lakes(iLake)%Elev
            CALL SetLastMessage(MessageArray(1:3),iFatal,ThisProcedure)
            iStat = -1
            RETURN
        END IF

        !Compute initial storages
        Lakes(iLake)%Storage   = Lakes(iLake)%RatingTable%Evaluate(Lakes(iLake)%Elev)
        Lakes(iLake)%Storage_P = Lakes(iLake)%Storage

    END DO

  END SUBROUTINE ReadInitialLakeElevs

END MODULE


subroutine read_species(species_dat, err)
  use photochem_data, only: iSL, ISPEC, mass, redoxstate, &
                            atomsO, atomsH, atomsC, atomsS, atomsN, atomsCl, &
                            LSO2, LH2CO, lh2so4, lso4aer, lh2s, &
                            LCO, LH2O, LH2, LCH4, LO2, LH, &
                            Ls8aer, Lhcaer, Lhcaer2, ls2, ls3, ls4, &
                            lno, lo, LCO2, ln2, ls, background_mu, background_spec, &
                            nq, nsp, np
  use photochem_vars, only: LBOUND, VDEP0, veff0, FIXEDMR, distflux, sgflux, &
                            distheight, mbound, smflux, vdep, veff
  implicit none

  ! input
  character(len=*), intent(in) :: species_dat
  character(len=err_len), intent(out) :: err
  integer :: iLL, iSP, iIN, iM_HV
  integer :: io, io1
  character(len=8) :: species, spectype
  character(len=8) :: AX
  integer :: LX
  integer :: LA,LB,LD,LE,LF,LM
  integer :: LBC, LG
  real*8 :: XX,YY,ZZ,XXX,YYY,ZZZ
  real*8, dimension(6) :: atom_mass
  err = ''
  ! open species.dat
  open(4, file=trim(species_dat),status='OLD')

  iLL=0
  ! counter for short lived species
  iSL=0
  ! counter for number of lines in species.dat file
  iSP=0
  ! counter for inert species. There should only be one
  iIN=0
  ! counter for HV and M
  iM_HV = 0

  ! mass of O, H, C, S, N, Cl (g/mol)
  atom_mass = (/15.999, 1.00784, 12.0107, 32.065, 14.0067, 35.453/)

  ! will be zero if NO is not present
  lno = 0

  ! FN2=0.
  io = 0
  do while (io == 0)
    read(4,*,iostat=io) SPECIES,SPECTYPE
    if ((scan(species,'*').LT.1) .and. (io == 0)) then
      iSP=iSP+1
      ISPEC(iSP)=species
      ! This loads the "Lnumbers" for ease of use later in the code
      ! call LNUM(ISPEC(isP),iSP)
      if(trim(species).eq.'SO2') LSO2=iSP
      if(trim(species).eq.'H2CO') LH2CO=iSP
      if(trim(species).eq.'H2SO4') LH2SO4=iSP
      if(trim(species).eq.'SO4AER') LSO4AER=iSP
      if(trim(species).eq.'H2S') LH2S=iSP
      if(trim(species).eq.'CO') LCO=iSP
      if(trim(species).eq.'H2O') LH2O=iSP
      if(trim(species).eq.'H2') LH2=iSP
      if(trim(species).eq.'CH4') LCH4=iSP
      if(trim(species).eq.'O2') LO2=iSP
      if(trim(species).eq.'S8AER') Ls8aer=iSP
      if(trim(species).eq.'HCAER') Lhcaer=iSP
      if(trim(species).eq.'HCAER2') lhcaer2=iSP
      if(trim(species).eq.'S2') ls2=iSP
      if(trim(species).eq.'S3') ls3=iSP
      if(trim(species).eq.'S4') ls4=iSP
      if(trim(species).eq.'S') ls=iSP
      if(trim(species).eq.'NO') lno=iSP
      if(trim(species).eq.'O') lo=iSP
      if(trim(species).eq.'H') lh=iSP
      if(trim(species).eq.'CO2') lco2=iSP
      if(trim(species).eq.'N2') lN2=iSP
      ! Return to previous line in species.dat file
      backspace 4

      ! read in atmoic number data, NEVER use LC,LH,LN,LO,LS as placeholders
      ! as they mean something else...
      read(4,*,iostat = io1) AX,AX,LA,LB,LD,LE,LF,LM
      if (io1 /= 0) then
        err = 'Problem reading number of atoms for '//trim(species)//' in '// &
              trim(species_dat)
        return
      endif

      if (SPECTYPE.EQ.'LL') then
        iLL=iLL+1
        ! Return to previous line in species.dat file
        backspace 4

        ! This section reads in the boundary conditions from species.dat.
        read(4,*,iostat=io1) AX,AX,LX,LX,LX,LX,LX,LX,LBC,XX,YY,ZZ,XXX,LG,YYY,ZZZ
        if (io1 /= 0) then
          err = 'Problem reading boundary conditions for '//trim(species)//' in '// &
                trim(species_dat)
          return
        endif
        if ((lbc < -1) .or. (lbc > 3)) then
          write(ax,'(i8)') lbc
          err = 'lbound = '//trim(adjustl(AX))//' for '//trim(species)//' in '// &
                trim(species_dat)//' is not a valid boundary condition'
          return
        endif
        if ((LG < 0) .or. (LG > 2)) then
          write(ax,'(i8)') lbc
          err = 'mbound = '//trim(adjustl(AX))//' for '//trim(species)//' in '// &
                trim(species_dat)//' is not a valid boundary condition'
          return
        endif
        if (YY < -1.d-100) then
          err = 'fixedmr for '//trim(species)//' in '// &
                trim(species_dat)//' can not be negative.'
          return
        endif

        LBOUND(iLL)=LBC
        VDEP0(iLL)=XX
        FIXEDMR(iLL)=YY
        if (LBOUND(iLL).eq.3) then
          ! distributed flux
          distflux(iLL)=ZZ
        else
          ! lower boundary flux
          SGFLUX(iLL)=ZZ
        endif
        distheight(iLL)=XXX
        MBOUND(iLL)=LG
        SMFLUX(iLL)=YYY
        VEFF0(iLL)=ZZZ

        mass(iLL) = la*atom_mass(1) + lb*atom_mass(2) + &
                    ld*atom_mass(3) + le*atom_mass(4) + &
                    lf*atom_mass(5) + lm*atom_mass(6)
        if (iSP > nq) then
          err = "All long lived species must preceed short lived species in "//trim(species_dat)
          return
        endif
        if ((index(species,'AER') /= 0) .and. ((iSP <= nq-np) .or. (iSP > nq))) then
          err = "Aersols must be the last long lived species in "//trim(species_dat)
          return
        endif

      elseif (SPECTYPE.EQ.'IN') then
        iIN=iIN+1
        if (iSP /= nsp) then
          err = "The background inert (IN) species must follow the short lived species in " &
                //trim(species_dat)
          return
        endif
        background_spec = species
        background_mu = la*atom_mass(1) + lb*atom_mass(2) + &
                        ld*atom_mass(3) + le*atom_mass(4) + &
                        lf*atom_mass(5) + lm*atom_mass(6)
        if ((species /= "CO2") .and. (species /= "N2") .and. (species /= "H2")) then
          err = "Only H2, N2, or CO2 can be the background atmosphere."
          return
        endif
      elseif (SPECTYPE.EQ.'SL') then
        if (iSP < nq) then
          err = "Short lived species must follow the long lived species in "//trim(species_dat)
          return
        endif
        iSL=iSL+1
      elseif (SPECTYPE.EQ.'HV') then
        if (ISP /= nsp+1) then
          err = '"M" must be the last species in the file '//trim(species_dat)
          return
        endif
        iM_HV=iM_HV+1
      elseif (SPECTYPE.EQ.'M') then
        if (ISP /= nsp+2) then
          err = '"M" must be the last species in the file '//trim(species_dat)
          return
        endif
        iM_HV=iM_HV+1
      else
        err = "Species type "//trim(spectype)//' in the file '//trim(species_dat)// &
              ' is not a valid species type.'
        return
      endif

      atomsO(iLL+iSL+iIN+iM_HV)=LA
      atomsH(iLL+iSL+iIN+iM_HV)=LB
      atomsC(iLL+iSL+iIN+iM_HV)=LD
      atomsS(iLL+iSL+iIN+iM_HV)=LE
      atomsN(iLL+iSL+iIN+iM_HV)=LF
      atomsCL(iLL+iSL+iIN+iM_HV)=LM

    endif
  enddo
  ! close the file
  close(4)

  redoxstate = atomsO*1.0 + atomsH*(-0.5) + atomsS*(-2.) + &
               atomsCL*(-1.0) + atomsC*(-2)

  VDEP = VDEP0
  VEFF = VEFF0

  if (iIN > 1) then
    err = 'Only one background inert ("IN") gas, like N2, is allowed.'
    return
  elseif (iIN < 1) then
    err = 'The atmosphere is missing a background gas.'
    return
  endif

end subroutine


       subroutine rtout

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine summarizes data for reaches

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units      |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ammonian(:)   |mg N/L     |ammonia concentration in reach
!!    bury          |mg pst     |loss of pesticide from active sediment layer
!!                              |by burial
!!    ch_l2(:)      |km         |length of main channel
!!    ch_w(2,:)     |m          |average width of main channel
!!    chlora(:)     |mg chl-a/L |chlorophyll-a concentration in reach
!!    difus         |mg pst     |diffusion of pesticide from sediment to reach
!!    disolvp(:)    |mg P/L     |dissolved phosphorus concentration in reach
!!    hbactlp(:)    |# cfu/100mL|less persistent bacteria in reach/outflow
!!                              |during hour
!!    hbactp(:)     |# cfu/100mL|persistent bacteria in reach/outflow during
!!                              |hour
!!    hbod(:)       |mg O2/L    |carbonaceous biochemical oxygen demand in
!!                              |reach at end of hour
!!    hchla(:)      |mg chl-a/L |chlorophyll-a concentration in reach at end of
!!                              |hour
!!    hdisox(:)     |mg O2/L    |dissolved oxygen concentration in reach at
!!                              |end of hour
!!    hnh4(:)       |mg N/L     |ammonia concentration in reach at end of hour
!!    hno2(:)       |mg N/L     |nitrite concentration in reach at end of hour
!!    hno3(:)       |mg N/L     |nitrate concentration in reach at end of hour
!!    horgn(:)      |mg N/L     |organic nitrogen concentration in reach at
!!                              |end of hour
!!    horgp(:)      |mg P/L     |organic phosphorus concentration in reach at
!!                              |end of hour
!!    hsedyld(:)    |metric tons|sediment transported out of reach during hour
!!    hsolp(:)      |mg P/L     |dissolved phosphorus concentration in reach at
!!                              |end of hour
!!    hsolpst(:)    |mg pst/m^3 |soluble pesticide concentration in outflow
!!                              |on day
!!    hsorpst(:)    |mg pst/m^3 |sorbed pesticide concentration in outflow
!!                              |on day
!!    hrtwtr(:)     |m^3 H2O    |water leaving reach during hour
!!    ievent      |none          |rainfall/runoff code
!!                               |0 daily rainfall/curve number technique
!!                               |1 sub-daily rainfall/Green&Ampt/hourly
!!                               |  routing
!!                               |3 sub-daily rainfall/Green&Ampt/hourly routing
!!    ihout         |none       |outflow hydrograph location
!!    inum1         |none       |reach number
!!    inum2         |none       |inflow hydrograph location
!!    nitraten(:)   |mg N/L     |nitrate concentration in reach
!!    nitriten(:)   |mg N/L     |nitrite concentration in reach
!!    organicn(:)   |mg N/L     |organic nitrogen concentration in reach
!!    organicp(:)   |mg P/L     |organic phosphorus concentration in reach
!!    rch_bactlp(:) |# cfu/100ml|less persistent bacteria in reach/outflow
!!                              |at end of day
!!    rch_bactp(:)  |# cfu/100ml|persistent bacteria in reach/outflow at end
!!                              |of day
!!    rch_cbod(:)   |mg O2/L    |carbonaceous biochemical oxygen demand in
!!                              |reach
!!    rch_dox(:)    |mg O2/L    |dissolved oxygen concentration in reach
!!    reactb        |mg pst     |amount of pesticide in sediment that is lost
!!                              |through reactions
!!    reactw        |mg pst     |amount of pesticide in reach that is lost
!!                              |through reactions
!!    resuspst      |mg pst     |amount of pesticide moving from sediment to
!!                              |reach due to resuspension
!!    rnum1         |none       |fraction of inflow that is overland flow
!!    rtevp         |m^3 H2O    |evaporation from reach on day
!!    rttlc         |m^3 H2O    |transmission losses from reach on day
!!    rtwtr         |m^3 H2O    |water leaving reach on day
!!    sedpst_act(:) |m          |depth of active sediment layer in reach for
!!                              |pesticide
!!    sedpst_conc(:)|mg/(m**3)  |inital pesticide concentration in river bed
!!                              |sediment
!!    sedrch        |metric tons|sediment transported out of channel
!!                              |during time step
!!    setlpst       |mg pst     |amount of pesticide moving from water to
!!                              |sediment due to settling
!!    solpesto      |mg pst/m^3 |soluble pesticide concentration in outflow
!!                              |on day
!!    sorpesto      |mg pst/m^3 |sorbed pesticide concentration in outflow
!!                              |on day
!!    volatpst      |mg pst     |amount of pesticide in reach lost by
!!                              |volatilization
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name             |units      |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hhvaroute(1,:,:) |deg C      |temperature
!!    hhvaroute(2,:,:) |m^3 H2O    |water
!!    hhvaroute(3,:,:) |metric tons|sediment or suspended solid load
!!    hhvaroute(4,:,:) |kg N       |organic nitrogen
!!    hhvaroute(5,:,:) |kg P       |organic phosphorus
!!    hhvaroute(6,:,:) |kg N       |nitrate
!!    hhvaroute(7,:,:) |kg P       |mineral phosphorus
!!    hhvaroute(11,:,:)|mg pst     |pesticide in solution
!!    hhvaroute(12,:,:)|mg pst     |pesticide sorbed to sediment
!!    hhvaroute(13,:,:)|kg         |chlorophyll-a
!!    hhvaroute(16,:,:)|kg         |carbonaceous biological oxygen demand
!!    hhvaroute(17,:,:)|kg         |dissolved oxygen
!!    hhvaroute(18,:,:)|# cfu/100ml|persistent bacteria
!!    hhvaroute(19,:,:)|# cfu/100ml|less persistent bacteria
!!    hhvaroute(20,:,:)|kg         |conservative metal #1
!!    hhvaroute(21,:,:)|kg         |conservative metal #2
!!    hhvaroute(22,:,:)|kg         |conservative metal #3
!!    rchdy(1,:)       |m^3/s      |flow into reach on day
!!    rchdy(2,:)       |m^3/s      |flow out of reach on day
!!    rchdy(3,:)       |m^3/s      |evaporation from reach on day
!!    rchdy(4,:)       |m^3/s      |transmission losses from reach on day
!!    rchdy(5,:)       |metric tons|sediment transported into reach on day
!!    rchdy(6,:)       |metric tons|sediment transported out of reach on day
!!    rchdy(7,:)       |mg/L       |sediment concentration in outflow
!!    rchdy(8,:)       |kg N       |organic N transported into reach on day
!!    rchdy(9,:)       |kg N       |organic N transported out of reach on day
!!    rchdy(10,:)      |kg P       |organic P transported into reach on day
!!    rchdy(11,:)      |kg P       |organic P transported out of reach on day
!!    rchdy(12,:)      |kg N       |nitrate transported into reach on day
!!    rchdy(13,:)      |kg N       |nitrate transported out of reach on day
!!    rchdy(14,:)      |kg N       |ammonia transported into reach on day
!!    rchdy(15,:)      |kg N       |ammonia transported out of reach on day
!!    rchdy(16,:)      |kg N       |nitrite transported into reach on day
!!    rchdy(17,:)      |kg N       |nitrite transported out of reach on day
!!    rchdy(18,:)      |kg P       |soluble P transported into reach on day
!!    rchdy(19,:)      |kg P       |soluble P transported out of reach on day
!!    rchdy(20,:)      |kg chla    |chlorophyll-a transported into reach on day
!!    rchdy(21,:)      |kg chla    |chlorophyll-a transported out of reach on
!!                                 |day
!!    rchdy(22,:)      |kg O2      |CBOD transported into reach on day
!!    rchdy(23,:)      |kg O2      |CBOD transported out of reach on day
!!    rchdy(24,:)      |kg O2      |dissolved oxygen transported into reach on
!!                                 |day
!!    rchdy(25,:)      |kg O2      |dissolved oxygen transported out of reach on
!!                                 |day
!!    rchdy(26,:)      |mg pst     |soluble pesticide transported into reach on
!!                                 |day
!!    rchdy(27,:)      |mg pst     |soluble pesticide transported out of reach
!!                                 |on day
!!    rchdy(28,:)      |mg pst     |sorbed pesticide transported into reach on
!!                                 |day
!!    rchdy(29,:)      |mg pst     |sorbed pesticide transported out of reach on
!!                                 |day
!!    rchdy(30,:)      |mg pst     |amount of pesticide lost through reactions
!!                                 |in reach on day
!!    rchdy(31,:)      |mg pst     |amount of pesticide lost through
!!                                 |volatilization from reach on day
!!    rchdy(32,:)      |mg pst     |amount of pesticide settling out of reach to
!!                                 |bed sediment on day
!!    rchdy(33,:)      |mg pst     |amount of pesticide resuspended from bed
!!                                 |sediment to reach on day
!!    rchdy(34,:)      |mg pst     |amount of pesticide diffusing from reach to
!!                                 |bed sediment on day
!!    rchdy(35,:)      |mg pst     |amount of pesticide in sediment layer lost
!!                                 |through reactions on day
!!    rchdy(36,:)      |mg pst     |amount of pesticide in sediment layer lost
!!                                 |through burial on day
!!    rchdy(37,:)      |mg pst     |amount of pesticide stored in river bed
!!                                 |sediments
!!    rchdy(38,:)      |# cfu/100mL|persistent bacteria transported out of reach
!!                                 |on day
!!    rchdy(39,:)      |# cfu/100mL|less persistent bacteria transported out of
!!                                 |reach on day
!!    rchdy(40,:)      |kg         |amount of conservative metal #1 transported
!!                                 |out of reach on day
!!    rchdy(41,:)      |kg         |amount of conservative metal #2 transported
!!                                 |out of reach on day
!!    rchdy(42,:)      |kg         |amount of conservative metal #3 transported
!!                                 |out of reach on day
!!    rchmono(1,:)     |m^3/s      |flow into reach during month
!!    rchmono(2,:)     |m^3/s      |flow out of reach during month
!!    rchmono(3,:)     |metric tons|sediment transported into reach during month
!!    rchmono(4,:)     |metric tons|sediment transported out of reach during
!!                                 |month
!!    rchmono(5,:)     |mg/L       |sediment concentration in outflow during
!!                                 |month
!!    rchmono(6,:)     |kg N       |organic N transported into reach during
!!                                 |month
!!    rchmono(7,:)     |kg N       |organic N transported out of reach during
!!                                 |month
!!    rchmono(8,:)     |kg P       |organic P transported into reach during
!!                                 |month
!!    rchmono(9,:)     |kg P       |organic P transported out of reach during
!!                                 |month
!!    rchmono(10,:)    |m^3/s      |evaporation from reach during month
!!    rchmono(11,:)    |m^3/s      |transmission losses from reach during month
!!    rchmono(12,:)    |kg         |conservative metal #1 transported out of
!!                                 |reach during month
!!    rchmono(13,:)    |kg         |conservative metal #2 transported out of
!!                                 |reach during month
!!    rchmono(14,:)    |kg         |conservative metal #3 transported out of
!!                                 |reach during month
!!    rchmono(15,:)    |kg N       |nitrate transported into reach during month
!!    rchmono(16,:)    |kg N       |nitrate transported out of reach during
!!                                 |month
!!    rchmono(17,:)    |kg P       |soluble P transported into reach during
!!                                 |month
!!    rchmono(18,:)    |kg P       |soluble P transported out of reach during
!!                                 |month
!!    rchmono(19,:)    |mg pst     |soluble pesticide transported into reach
!!                                 |during month
!!    rchmono(20,:)    |mg pst     |soluble pesticide transported out of reach
!!                                 |during month
!!    rchmono(21,:)    |mg pst     |sorbed pesticide transported into reach
!!                                 |during month
!!    rchmono(22,:)    |mg pst     |sorbed pesticide transported out of reach
!!                                 |during month
!!    rchmono(23,:)    |mg pst     |amount of pesticide lost through reactions
!!                                 |in reach during month
!!    rchmono(24,:)    |mg pst     |amount of pesticide lost through
!!                                 |volatilization from reach during month
!!    rchmono(25,:)    |mg pst     |amount of pesticide settling out of reach to
!!                                 |bed sediment during month
!!    rchmono(26,:)    |mg pst     |amount of pesticide resuspended from bed
!!                                 |sediment to reach during month
!!    rchmono(27,:)    |mg pst     |amount of pesticide diffusing from reach to
!!                                 |bed sediment during month
!!    rchmono(28,:)    |mg pst     |amount of pesticide in sediment layer lost
!!                                 |through reactions during month
!!    rchmono(29,:)    |mg pst     |amount of pesticide in sediment layer lost
!!                                 |through burial during month
!!    rchmono(30,:)    |kg chla    |chlorophyll-a transported into reach during
!!                                 |month
!!    rchmono(31,:)    |kg chla    |chlorophyll-a transported out of reach
!!                                 |during month
!!    rchmono(32,:)    |kg N       |ammonia transported into reach during month
!!    rchmono(33,:)    |kg N       |ammonia transported out of reach during
!!                                 |month
!!    rchmono(34,:)    |kg N       |nitrite transported into reach during month
!!    rchmono(35,:)    |kg N       |nitrite transported out of reach during
!!                                 |month
!!    rchmono(36,:)    |kg O2      |CBOD transported into reach during month
!!    rchmono(37,:)    |kg O2      |CBOD transported out of reach during month
!!    rchmono(38,:)    |kg O2      |dissolved oxygen transported into reach
!!                                 |during month
!!    rchmono(39,:)    |kg O2      |dissolved oxygen transported out of reach
!!                                 |during month
!!    rchmono(40,:)    |# cfu/100mL|persistent bacteria transported out of reach
!!                                 |during month
!!    rchmono(41,:)    |# cfu/100mL|less persistent bacteria transported out of
!!                                 |reach during month
!!    varoute(2,:)     |m^3 H2O    |water
!!    varoute(3,:)     |metric tons|sediment or suspended solid load
!!    varoute(4,:)     |kg N       |organic nitrogen
!!    varoute(5,:)     |kg P       |organic phosphorus
!!    varoute(6,:)     |kg N       |nitrate
!!    varoute(7,:)     |kg P       |soluble phosphorus
!!    varoute(11,:)    |mg pst     |pesticide in solution
!!    varoute(12,:)    |mg pst     |pesticide sorbed to sediment
!!    varoute(13,:)    |kg         |chlorophyll-a
!!    varoute(14,:)    |kg N       |ammonia
!!    varoute(15,:)    |kg N       |nitrite
!!    varoute(16,:)    |kg         |carbonaceous biological oxygen demand
!!    varoute(17,:)    |kg         |dissolved oxygen
!!    varoute(18,:)    |# cfu/100mL|persistent bacteria
!!    varoute(19,:)    |# cfu/100mL|less persistent bacteria
!!    varoute(20,:)    |kg         |conservative metal #1
!!    varoute(21,:)    |kg         |conservative metal #2
!!    varoute(22,:)    |kg         |conservative metal #3
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bedvol      |m^3           |volume of river bed sediment
!!    ii          |none          |counter
!!    jrch        |none          |reach number
!!    sedcon      |mg/L          |sediment concentration in outflow
!!    sedpest     |mg pst        |pesticide in river bed sediment
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm
      implicit none

      integer :: jrch, ii
      real*8 :: sedcon, bedvol, sedpest, wtmp

      jrch = 0
      jrch = inum1

      wtmp = 0.
      wtmp = 5.0 + 0.75 * tmpav(jrch)
!! set values for routing variables
      varoute(1,ihout) = wtmp
      varoute(2,ihout) = rtwtr
      varoute(3,ihout) = sedrch
      varoute(8,ihout) = 0.
      varoute(9,ihout) = 0.
      varoute(10,ihout) = 0.
      varoute(18,ihout) = rch_bactp(jrch)
      varoute(19,ihout) = rch_bactlp(jrch)
      varoute(20,ihout) = varoute(20,inum2) * (1. - rnum1)
      varoute(21,ihout) = varoute(21,inum2) * (1. - rnum1)
      varoute(22,ihout) = varoute(22,inum2) * (1. - rnum1)
!!    sediment routing
      varoute(23,ihout) = rch_san
      varoute(24,ihout) = rch_sil
      varoute(25,ihout) = rch_cla
      varoute(26,ihout) = rch_sag
      varoute(27,ihout) = rch_lag
      varoute(28,ihout) = rch_gra
      if (ievent == 0) then
       varoute(4,ihout) = organicn(jrch) * rtwtr / 1000. + ch_orgn(jrch)
       varoute(5,ihout) = organicp(jrch) * rtwtr / 1000. + ch_orgp(jrch)
       varoute(6,ihout) = nitraten(jrch) * rtwtr / 1000.
       varoute(7,ihout) = disolvp(jrch) * rtwtr / 1000.
       varoute(11,ihout) = solpesto * rtwtr
       varoute(12,ihout) = sorpesto * rtwtr
       varoute(13,ihout) = chlora(jrch) * rtwtr / 1000.
       varoute(14,ihout) = ammonian(jrch) * rtwtr / 1000.
       varoute(15,ihout) = nitriten(jrch) * rtwtr / 1000.
       varoute(16,ihout) = rch_cbod(jrch) *  rtwtr/ 1000.
       varoute(17,ihout) = rch_dox(jrch) *  rtwtr/ 1000.
      else
       do ii = 1, nstep
          hhvaroute(2,ihout,ii) = hrtwtr(ii)     ! urban modeling by J.Jeong
          hhvaroute(3,ihout,ii) = hsedyld(ii)  ! urban modeling by J.Jeong

	! From this point, check each variables if it is simulated at subdaily interval before using the output - Jaehak 9/11/09
         hhvaroute(1,ihout,ii) = 0.
!          hhvaroute(2,ihout,ii) = hrtwtr(ii)
!          hhvaroute(3,ihout,ii) = hsedyld(ii)
          hhvaroute(4,ihout,ii) = horgn(ii) * hrtwtr(ii) / 1000.
          hhvaroute(5,ihout,ii) = horgp(ii) *  hrtwtr(ii) / 1000.
          hhvaroute(6,ihout,ii) = hno3(ii) * hrtwtr(ii) / 1000.
          hhvaroute(7,ihout,ii) = hsolp(ii) * hrtwtr(ii) / 1000.
          hhvaroute(8,ihout,ii) = 0.
          hhvaroute(9,ihout,ii) = 0.
          hhvaroute(10,ihout,ii) = 0.
          hhvaroute(11,ihout,ii) = hsolpst(ii) * hrtwtr(ii)
          hhvaroute(12,ihout,ii) = hsorpst(ii) * hrtwtr(ii)
          hhvaroute(13,ihout,ii) = hchla(ii) * hrtwtr(ii) / 1000.
          hhvaroute(14,ihout,ii) = hnh4(ii) * hrtwtr(ii) / 1000.
          hhvaroute(15,ihout,ii) = hno2(ii) * hrtwtr(ii) / 1000.
          hhvaroute(16,ihout,ii) = hbod(ii) *  hrtwtr(ii)/ 1000.
          hhvaroute(17,ihout,ii) = hdisox(ii) *  hrtwtr(ii)/ 1000.
          hhvaroute(18,ihout,ii) = hbactp(ii)
          hhvaroute(19,ihout,ii) = hbactlp(ii)
          hhvaroute(20,ihout,ii) = hhvaroute(20,inum2,ii) * (1. - rnum1)
          hhvaroute(21,ihout,ii) = hhvaroute(21,inum2,ii) * (1. - rnum1)
          hhvaroute(22,ihout,ii) = hhvaroute(22,inum2,ii) * (1. - rnum1)

          varoute(4,ihout) = varoute(4,ihout) + hhvaroute(4,ihout,ii)
          varoute(5,ihout) = varoute(5,ihout) + hhvaroute(5,ihout,ii)
          varoute(6,ihout) = varoute(6,ihout) + hhvaroute(6,ihout,ii)
          varoute(7,ihout) = varoute(7,ihout) + hhvaroute(7,ihout,ii)
          varoute(11,ihout) = varoute(11,ihout) + hhvaroute(11,ihout,ii)
          varoute(12,ihout) = varoute(12,ihout) + hhvaroute(12,ihout,ii)
          varoute(13,ihout) = varoute(13,ihout) + hhvaroute(13,ihout,ii)
          varoute(14,ihout) = varoute(14,ihout) + hhvaroute(14,ihout,ii)
          varoute(15,ihout) = varoute(15,ihout) + hhvaroute(15,ihout,ii)
          varoute(16,ihout) = varoute(16,ihout) + hhvaroute(16,ihout,ii)
          varoute(17,ihout) = varoute(17,ihout) + hhvaroute(17,ihout,ii)
        end do
      end if

!! set subdaily reach output    - by jaehak jeong for urban project, subdaily output in output.rch file
	if (ievent==1.and.iprint==3) then
	  do ii=1,nstep
!! determine sediment concentration in outflow
          sedcon = 0.
          if (hrtwtr(ii) > 0.01) then
            sedcon = hsedyld(ii) / hrtwtr(ii) * 1.e6
          else
            sedcon = 0.
          end if
          rchhr(1,jrch,ii) = hhvaroute(2,inum2,ii) * (1. - rnum1)!!flow in (m^3/s)
     &      / (idt * 60.)
          rchhr(2,jrch,ii) = hrtwtr(ii) / (idt * 60.)            !!flow out (m^3/s)
          rchhr(3,jrch,ii) = hrtevp(ii) / (idt * 60.)            !!evap (m^3/s)
          rchhr(4,jrch,ii) = hrttlc(ii) / (idt * 60.)            !!tloss (m^3/s)
          rchhr(5,jrch,ii) = hhvaroute(3,inum2,ii) * (1. - rnum1)   !!sed in (tons)
          rchhr(6,jrch,ii) = hsedyld(ii)                         !!sed out (tons)
          rchhr(7,jrch,ii) = sedcon						       !!sed conc (mg/L)
	  end do
	endif

!! determine sediment concentration in outflow
      sedcon = 0.
      if (rtwtr > 0.01) then
        sedcon = sedrch / rtwtr * 1.e6
      else
        sedcon = 0.
      end if
      if (sedcon > 200000.) sedcon = 200000.

!! determine amount of pesticide in river bed sediments
      bedvol = 0.
      sedpest = 0.
      bedvol = ch_w(2,jrch) * ch_l2(jrch) * 1000. * sedpst_act(jrch)
      sedpest = sedpst_conc(jrch) * bedvol

!! set daily reach output
      rchdy(1,jrch) = varoute(2,inum2) * (1. - rnum1) / 86400. !!flow in (m^3/s)
      rchdy(2,jrch) = rtwtr / 86400. !!flow out (m^3/s)

      rchdy(3,jrch) = rtevp / 86400.                     !!evap (m^3/s)
      rchdy(4,jrch) = rttlc / 86400.                     !!tloss (m^3/s)
      rchdy(5,jrch) = varoute(3,inum2) * (1. - rnum1)    !!sed in (tons)
      rchdy(6,jrch) = sedrch                             !!sed out (tons)
      rchdy(7,jrch) = sedcon                             !!sed conc (mg/L)
      rchdy(8,jrch) = varoute(4,inum2) * (1. - rnum1)    !!orgN in (kg N)
      rchdy(9,jrch) = varoute(4,ihout)                   !!orgN out (kg N)
      rchdy(10,jrch) = varoute(5,inum2) * (1. - rnum1)   !!orgP in (kg P)
      rchdy(11,jrch) = varoute(5,ihout)                  !!orgP out (kg P)
      rchdy(12,jrch) = varoute(6,inum2) * (1. - rnum1)   !!NO3 in (kg N)
      rchdy(13,jrch) = varoute(6,ihout)                  !!NO3 out (kg N)
      rchdy(14,jrch) = varoute(14,inum2) * (1. - rnum1)  !!NH4 in (kg)
      rchdy(15,jrch) = varoute(14,ihout)                 !!NH4 out (kg)
      rchdy(16,jrch) = varoute(15,inum2) * (1. - rnum1)  !!NO2 in (kg)
      rchdy(17,jrch) = varoute(15,ihout)                 !!NO2 out (kg)
      rchdy(18,jrch) = varoute(7,inum2) * (1. - rnum1)   !!solP in (kg P)
      rchdy(19,jrch) = varoute(7,ihout)                  !!solP out (kg P)
      rchdy(20,jrch) = varoute(13,inum2) * (1. - rnum1)  !!chl-a in (kg)
      rchdy(21,jrch) = varoute(13,ihout)                 !!chl-a out (kg)
      rchdy(22,jrch) = varoute(16,inum2) * (1. - rnum1)  !!CBOD in (kg)
      rchdy(23,jrch) = varoute(16,ihout)                 !!CBOD out (kg)
      rchdy(24,jrch) = varoute(17,inum2) * (1. - rnum1)  !!dis O2 in (kg)
      rchdy(25,jrch) = varoute(17,ihout)                 !!dis O2 out (kg)
      rchdy(26,jrch) = varoute(11,inum2) * (1. - rnum1)  !!solpst in (mg pst)
      rchdy(27,jrch) = varoute(11,ihout)                 !!solpst out (mg pst)
      rchdy(28,jrch) = varoute(12,inum2) * (1. - rnum1)  !!srbpst in (mg pst)
      rchdy(29,jrch) = varoute(12,ihout)                 !!srbpst out (mg pst)
      rchdy(30,jrch) = reactw                            !!reacted pst (mg pst)
      rchdy(31,jrch) = volatpst                          !!volatilized pst (mg)
      rchdy(32,jrch) = setlpst                           !!pst settling (mg pst)
      rchdy(33,jrch) = resuspst                          !!pst resuspension (mg)
      rchdy(34,jrch) = -difus                            !!pst diffuse to sed mg
      rchdy(35,jrch) = reactb                            !!react pst/sed (mg)
      rchdy(36,jrch) = bury                              !!pst bury (mg)
      rchdy(37,jrch) = sedpest                           !!pst in rivbed sed mg
      rchdy(38,jrch) = varoute(18,ihout)                 !!persistent bact out
      rchdy(39,jrch) = varoute(19,ihout)                 !!lpersistent bact out
      rchdy(40,jrch) = varoute(20,ihout)                 !!cmetal #1
      rchdy(41,jrch) = varoute(21,ihout)                 !!cmetal #2
      rchdy(42,jrch) = varoute(22,ihout)                 !!cmetal #3
      rchdy(60,jrch) = varoute(1,ihout)                  !!water temp deg c
!!    sediment routing
!!    Assumed all silt for default sediment routine
!!    For other sediment routing models particle size are tracked
       if (ch_eqn(jrch) .NE. 0) then
       rchdy(43,jrch) = varoute(23,inum2) * (1. - rnum1)  !!sand in
       rchdy(44,jrch) = varoute(23,ihout)                 !!sand out
       rchdy(45,jrch) = varoute(24,inum2) * (1. - rnum1)  !!silt in
       rchdy(46,jrch) = varoute(24,ihout)                 !!silt out
       rchdy(47,jrch) = varoute(25,inum2) * (1. - rnum1)  !!clay in
       rchdy(48,jrch) = varoute(25,ihout)                 !!clay out
       rchdy(49,jrch) = varoute(26,inum2) * (1. - rnum1)  !!sm ag in
       rchdy(50,jrch) = varoute(26,ihout)                 !!sm ag out
       rchdy(51,jrch) = varoute(27,inum2) * (1. - rnum1)  !!lg ag in
       rchdy(52,jrch) = varoute(27,ihout)                 !!lg ag out
       rchdy(53,jrch) = varoute(28,inum2) * (1. - rnum1)  !!gravel in
       rchdy(54,jrch) = varoute(28,ihout)                 !!gravel out
	 else
       rchdy(43,jrch) = 0.                 !!sand in
       rchdy(44,jrch) = 0.                 !!sand out
       rchdy(45,jrch) = varoute(3,inum2) * (1. - rnum1)   !!silt in
       rchdy(46,jrch) = varoute(3,ihout)                  !!silt out
       rchdy(47,jrch) = 0.                 !!clay in
       rchdy(48,jrch) = 0.                 !!clay out
       rchdy(49,jrch) = 0.                 !!sm ag in
       rchdy(50,jrch) = 0.                 !!sm ag out
       rchdy(51,jrch) = 0.                 !!lg ag in
       rchdy(52,jrch) = 0.                 !!lg ag out
       rchdy(53,jrch) = 0.                 !!gravel in
       rchdy(54,jrch) = 0.                 !!gravel out
       end if

!! summarize monthly reach output
      rchmono(1,jrch) = rchmono(1,jrch) + rchdy(1,jrch)
      rchmono(2,jrch) = rchmono(2,jrch) + rchdy(2,jrch)
      rchmono(3,jrch) = rchmono(3,jrch) + rchdy(5,jrch)
      rchmono(4,jrch) = rchmono(4,jrch) + rchdy(6,jrch)
      rchmono(5,jrch) = rchmono(5,jrch) + rchdy(7,jrch)
      rchmono(6,jrch) = rchmono(6,jrch) + rchdy(8,jrch)
      rchmono(7,jrch) = rchmono(7,jrch) + rchdy(9,jrch)
      rchmono(8,jrch) = rchmono(8,jrch) + rchdy(10,jrch)
      rchmono(9,jrch) = rchmono(9,jrch) + rchdy(11,jrch)
      rchmono(10,jrch) = rchmono(10,jrch) + rchdy(3,jrch)
      rchmono(11,jrch) = rchmono(11,jrch) + rchdy(4,jrch)
      rchmono(12,jrch) = rchmono(12,jrch) + rchdy(40,jrch)
      rchmono(13,jrch) = rchmono(13,jrch) + rchdy(41,jrch)
      rchmono(14,jrch) = rchmono(14,jrch) + rchdy(42,jrch)
      rchmono(15,jrch) = rchmono(15,jrch) + rchdy(12,jrch)
      rchmono(16,jrch) = rchmono(16,jrch) + rchdy(13,jrch)
      rchmono(17,jrch) = rchmono(17,jrch) + rchdy(18,jrch)
      rchmono(18,jrch) = rchmono(18,jrch) + rchdy(19,jrch)
      rchmono(19,jrch) = rchmono(19,jrch) + rchdy(26,jrch)
      rchmono(20,jrch) = rchmono(20,jrch) + rchdy(27,jrch)
      rchmono(21,jrch) = rchmono(21,jrch) + rchdy(28,jrch)
      rchmono(22,jrch) = rchmono(22,jrch) + rchdy(29,jrch)
      rchmono(23,jrch) = rchmono(23,jrch) + rchdy(30,jrch)
      rchmono(24,jrch) = rchmono(24,jrch) + rchdy(31,jrch)
      rchmono(25,jrch) = rchmono(25,jrch) + rchdy(32,jrch)
      rchmono(26,jrch) = rchmono(26,jrch) + rchdy(33,jrch)
      rchmono(27,jrch) = rchmono(27,jrch) + rchdy(34,jrch)
      rchmono(28,jrch) = rchmono(28,jrch) + rchdy(35,jrch)
      rchmono(29,jrch) = rchmono(29,jrch) + rchdy(36,jrch)
      rchmono(30,jrch) = rchmono(30,jrch) + rchdy(20,jrch)
      rchmono(31,jrch) = rchmono(31,jrch) + rchdy(21,jrch)
      rchmono(32,jrch) = rchmono(32,jrch) + rchdy(14,jrch)
      rchmono(33,jrch) = rchmono(33,jrch) + rchdy(15,jrch)
      rchmono(34,jrch) = rchmono(34,jrch) + rchdy(16,jrch)
      rchmono(35,jrch) = rchmono(35,jrch) + rchdy(17,jrch)
      rchmono(36,jrch) = rchmono(36,jrch) + rchdy(22,jrch)
      rchmono(37,jrch) = rchmono(37,jrch) + rchdy(23,jrch)
      rchmono(38,jrch) = rchmono(38,jrch) + rchdy(24,jrch)
      rchmono(39,jrch) = rchmono(39,jrch) + rchdy(25,jrch)
      rchmono(40,jrch) = rchmono(40,jrch) + rchdy(38,jrch)
      rchmono(41,jrch) = rchmono(41,jrch) + rchdy(39,jrch)
!!    sediment routing
       rchmono(42,jrch) = rchmono(42,jrch) + rchdy(43,jrch)
       rchmono(43,jrch) = rchmono(43,jrch) + rchdy(44,jrch)
       rchmono(44,jrch) = rchmono(44,jrch) + rchdy(45,jrch)
       rchmono(45,jrch) = rchmono(45,jrch) + rchdy(46,jrch)
       rchmono(46,jrch) = rchmono(46,jrch) + rchdy(47,jrch)
       rchmono(47,jrch) = rchmono(47,jrch) + rchdy(48,jrch)
       rchmono(48,jrch) = rchmono(48,jrch) + rchdy(49,jrch)
       rchmono(49,jrch) = rchmono(49,jrch) + rchdy(50,jrch)
       rchmono(50,jrch) = rchmono(50,jrch) + rchdy(51,jrch)
       rchmono(51,jrch) = rchmono(51,jrch) + rchdy(52,jrch)
       rchmono(52,jrch) = rchmono(52,jrch) + rchdy(53,jrch)
       rchmono(53,jrch) = rchmono(53,jrch) + rchdy(54,jrch)
       rchmono(54,jrch) = rchmono(54,jrch) + rchdy(55,jrch)
       rchmono(55,jrch) = rchmono(55,jrch) + rchdy(56,jrch)
       rchmono(56,jrch) = rchmono(56,jrch) + rchdy(57,jrch)
       rchmono(57,jrch) = rchmono(57,jrch) + rchdy(58,jrch)
	   rchmono(58,jrch) = rchmono(58,jrch) + rchdy(59,jrch)

      return
      end


! Code in this file is from MODFLOW-NWT ver. 1.0.9, file gwf2wel7_NWT.f
      MODULE GWFWELMODULE
        INTEGER,SAVE,POINTER  ::NWELLS,MXWELL,NWELVL,IWELCB,IPRWEL
        INTEGER,SAVE,POINTER  ::NPWEL,IWELPB,NNPWEL,IRDPSI
        CHARACTER(LEN=16),SAVE, DIMENSION(:),   POINTER     ::WELAUX
        double precision, SAVE, DIMENSION(:,:), POINTER     ::WELL
        double precision, SAVE,                 POINTER     ::PSIRAMP
        INTEGER,          SAVE,                 POINTER     ::IUNITRAMP
      TYPE GWFWELTYPE
        INTEGER,POINTER  ::NWELLS,MXWELL,NWELVL,IWELCB,IPRWEL
        INTEGER,POINTER  ::NPWEL,IWELPB,NNPWEL,IRDPSI
        CHARACTER(LEN=16), DIMENSION(:),   POINTER     ::WELAUX
        double precision,  DIMENSION(:,:), POINTER     ::WELL
        double precision,                  POINTER     ::PSIRAMP
        INTEGER,                           POINTER     ::IUNITRAMP
      END TYPE
      TYPE(GWFWELTYPE), SAVE:: GWFWELDAT(10)
      END MODULE GWFWELMODULE


	SUBROUTINE CCPLOT  ( cval, clabel, ilabel, scflag, iret )
C************************************************************************
C* CCPLOT								*
C*									*
C* This subroutine applies a smoothing function and draws a line	*
C* connecting the array of points.  The points are specified in grid	*
C* coordinates.								*
C*									*
C* CCPLOT  ( CVAL, CLABEL, ILABEL, SCFLAG, IRET )			*
C*									*
C* Input parameters:							*
C*	CVAL		REAL		Contour level			*
C*	CLABEL		CHAR*		Contour Label			*
C*	ILABEL		INTEGER		Label type			*
C*	SCFLAG		LOGICAL		Suppress small contour flag	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* WOLFPLOT			Original code for SACC			*
C* M. desJardins/GSFC	 7/85	Adapted from AOIPS code for GEMPAK 3.1	*
C* M. desJardins/GSFC	 6/89	Rewritten for GEMPAK 5			*
C* K. Brill/NMC          9/90   Added gaps for contour labels		*
C* J. Nielsen/SUNYA	 3/91	Simplified and fixed gap algorithm	*
C* K. Brill/NMC		01/92	CALL CLBBOX for label gap		*
C* S. Jacobs/EAI	10/93	Changed CLABEL --> GR_LABL		*
C* S. Jacobs/NMC	 9/94	Changed the check for number of points	*
C*				   from 23 to 7				*
C* S. Jacobs/NCEP	 1/99	Added groups and non-break for label	*
C* S. Jacobs/NCEP	10/00	Added call to CCLIP for latlon clipping	*
C* C. Bailey/HPC	 6/06	Added contour label as input parameter	*
C* C. Bailey/HPC	10/06	Added suppress small contour flag	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'CONTUR.CMN'
C*
	CHARACTER*(*)	clabel
	LOGICAL		done, labflg, more, scflag
	CHARACTER	text*24
	REAL		xlcl (1024), ylcl (1024)
C------------------------------------------------------------------------
	iret = 0
	labflg = .false.
C
C*	Start a new group for the line and label text.
C*	Group type 8 is for LABELs.
C
	CALL GSGRP ( 8, ier )
C
C*	Apply the smoothing function and draw a line connecting
C*	the specified array of points on the plot in grid coordinates.
C
	IF  ( jsmoth .gt. 0 )  THEN
	    CALL CSMTHN  ( jsmoth, number, xval, yval, ier )
	END IF
C
C*	Transform the points to the actual grid coordindates.
C
	IF  ( ( offx .ne. 0. ) .or. ( offy .ne. 0. ) .or.
     +	      ( skip .gt. 0. ) )  THEN
	    CALL CTRANG  ( number, xval, yval, xval, yval, ier )
	END IF
C
C*	If the device is VG, then clip the line at the map bounds.
C
	more = .true.
	ipnt = 1
	DO WHILE  ( more )
	    IF  ( ddev .eq. 'VG' )  THEN
		CALL CCLIP ( number, xval, yval, ipnt,
     +			     nlcl, xlcl, ylcl, more, ier )
	      ELSE
		more = .false.
		nlcl = number
		DO  i = 1, nlcl
		    xlcl (i) = xval (i)
		    ylcl (i) = yval (i)
		END DO
	    END IF
C
C*	    Add label if requested.
C
	    IF  ( ilabel .gt. 0 .and. nlcl .gt. 7 )  THEN
		text = clabel
		CALL ST_LSTR  ( text, nchar, ier )
		labflg = .true.
		ihalf = nlcl / 2
		xl    = xlcl ( ihalf )
		yl    = ylcl ( ihalf )
C
C*	        Blank out a space in the contour line to make the label
C*              visible.  Allow for a blank rectangle surrounding the
C*	        label with a margin of 0.1 characters on the top and
C*	        bottom and 0.2 characters on a side.
C
		CALL GTRANS ( 'G', 'N', 1, xlcl ( ihalf ),
     +                        ylcl ( ihalf ), x0, y0, ier )
C
C*	    	Set the bounds of the label box.
C
		CALL GQSYSZ ( wmk, zmk, c1, c2, blx, bly, ier )
		c1 = c1 * ( FLOAT ( nchar ) + 0.4 ) * .5
		c2 = c2 * .6
		xin = 0.
		yin = 0.
		xf = x0
		yf = y0
C
C*	        Start at the median point and step backward to find the
C*	        first point outside of the label box.
C
		iback = ihalf
		done = .false.
		DO WHILE ( .not. done )
		    iback = iback - 1
		    IF ( iback .lt. 1 ) THEN
			done = .true.
			iback = 1
		    ELSE
			CALL GTRANS ( 'G', 'N', 1, xlcl (iback),
     + 		     	              ylcl (iback), xf, yf, ier )
			IF ( ABS (xf-x0) .gt. c1 ) done = .true.
			IF ( ABS (yf-y0) .gt. c2 ) done = .true.
			IF ( .not. done ) THEN
			    xin = xf - x0
			    yin = yf - y0
			END IF
		    END IF
		END DO
		xll = -c1
		yll = -c2
		xf = xf - x0
		yf = yf - y0
		CALL CLBBOX ( xll, yll, c1, c2, xin, yin, xf, yf, ier )
		xf = xf + x0
		yf = yf + y0
		istop = iback + 1
		CALL GTRANS ( 'N', 'G', 1, xf, yf, xlcl (istop),
     +			      ylcl (istop), ier )
C
C*	        Draw the contour to the edge of the label space.
C
		CALL GLINE ( 'G', istop, xlcl, ylcl, iret )
C*
		ifrwd = ihalf
		done = .false.
		xin = 0.
		yin = 0.
		xf = x0
		yf = y0
C
C*	        Start at the median point and step foreward to find the
C*	        first point outside of the label box.
C
		DO WHILE ( .not. done )
		    ifrwd = ifrwd + 1
		    IF ( ifrwd .gt. nlcl ) THEN
			done = .true.
			ifrwd = nlcl
		    ELSE
			CALL GTRANS ( 'G', 'N', 1, xlcl (ifrwd),
     + 		     	              ylcl (ifrwd), xf, yf, ier )
			IF ( ABS (xf-x0) .gt. c1 ) done = .true.
			IF ( ABS (yf-y0) .gt. c2 ) done = .true.
			IF ( .not. done ) THEN
			    xin = xf - x0
			    yin = yf - y0
			END IF
		    END IF
		END DO
		xf = xf - x0
		yf = yf - y0
		CALL CLBBOX ( xll, yll, c1, c2, xin, yin, xf, yf, ier )
		xf = xf + x0
		yf = yf + y0
		istrt = ifrwd - 1
		CALL GTRANS ( 'N', 'G', 1, xf, yf, xlcl (istrt),
     +			      ylcl (istrt), ier )
		nfrwd = nlcl - istrt + 1
C
C*	        Draw the rest of the contour.
C
		CALL GLINE ( 'G', nfrwd, xlcl (istrt), ylcl (istrt),
     +                       iret )
C
C*	        Plot the label.
C
		ixoff = -nchar + 1
		CALL GTEXT  ( 'G', xl, yl, text, 0., ixoff, 0, ier )
C*
	      ELSE IF  ( ilabel .lt. 0 .and. nlcl .gt. 7 )  THEN
C
C*	    	If the label value is negative, plot the contour value,
C*	    	but DO NOT break the line.
C
		text = clabel
		CALL ST_LSTR  ( text, nchar, ier )
		labflg = .true.
		ihalf = nlcl / 2
		xl    = xlcl ( ihalf )
		yl    = ylcl ( ihalf )
C
C*	    	Draw the line.
C
		CALL GLINE  ( 'G', nlcl, xlcl, ylcl, iret )
C
C*	    	Plot the label.
C
		CALL GTEXT  ( 'G', xl, yl, text, 0., 0, 0, ier )
	    END IF
C
C*	    Draw the line.
C
	    IF  ( ( scflag .and. nlcl .gt. 7 ) .or. .not. scflag) THEN
	        IF  ( nlcl .ge. 2 .and. .not. labflg )  THEN
		  CALL GLINE  ( 'G', nlcl, xlcl, ylcl, iret )
	        END IF
	    END IF
C
	END DO
C
C*	End the group for the line and label text.
C
	CALL GEGRP ( ier )
C*
	RETURN
	END


      SUBROUTINE DT_EVENTA(Id,Ip,It,Ncsy,Irej)

C***********************************************************************
C Treatment of nucleon-nucleon interactions in a two-chain             *
C approximation.                                                       *
C  (input) ID       BAMJET-index of projectile hadron (in case of      *
C                   h-K scattering)                                    *
C          IP/IT    mass number of projectile/target nucleus           *
C          NCSY     number of two chain systems                        *
C          IREJ     rejection flag                                     *
C This version dated 15.01.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      INTEGER i , Id , idum , ifp1 , ifp2 , ift1 , ift2 , Ip , Irej ,
     &        irej1 , It , k , mop1 , mop2 , mot1 , mot2 , nc , Ncsy ,
     &        npymem
      DOUBLE PRECISION pp1 , pp2 , pt1 , pt2 , TINY10
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY10=1.0D-10)

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C rejection counter
      INCLUDE 'inc/dtrejc'
C flags for diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtflg3'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'
C flags for input different options
      INCLUDE 'inc/dtflg1'
C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'

      DIMENSION pp1(4) , pp2(4) , pt1(4) , pt2(4)

      Irej = 0
      NPOint(3) = NHKk + 1

C skip following treatment for low-mass diffraction
      IF ( ABS(IFLagd).EQ.1 ) THEN
         NPOint(3) = NPOint(2)
         GOTO 100
      END IF

C multiple scattering of chain ends
      IF ( (Ip.GT.1) .AND. (MKCron.NE.0) ) CALL DT_CRONIN(1)

      IF ( (It.GT.1) .AND. (MKCron.NE.0) ) CALL DT_CRONIN(2)
      nc = NPOint(2)
C get a two-chain system from DTEVT1
      DO i = 1 , Ncsy
         ifp1 = IDHkk(nc)
         ift1 = IDHkk(nc+1)
         ifp2 = IDHkk(nc+2)
         ift2 = IDHkk(nc+3)
         DO k = 1 , 4
            pp1(k) = PHKk(k,nc)
            pt1(k) = PHKk(k,nc+1)
            pp2(k) = PHKk(k,nc+2)
            pt2(k) = PHKk(k,nc+3)
         END DO
         mop1 = nc
         mot1 = nc + 1
         mop2 = nc + 2
         mot2 = nc + 3
         CALL DT_GETCSY(ifp1,pp1,mop1,ifp2,pp2,mop2,ift1,pt1,mot1,ift2,
     &                  pt2,mot2,irej1)
         IF ( irej1.GT.0 ) THEN
            IRHha = IRHha + 1

            IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 ) WRITE (LOUt,*)
     &            'rejected 1 in EVENTA'
            GOTO 200
         END IF
         nc = nc + 4
      END DO

C meson/antibaryon projectile:
C sample single-chain valence-valence systems (Reggeon contrib.)
      IF ( (Ip.EQ.1) .AND. (ISIcha.EQ.1) ) THEN
         IF ( IIBar(Id).LE.0 ) CALL DT_VV2SCH
      END IF

      IF ( (IREsco.EQ.1) .OR. (IFRag(1).EQ.1) ) THEN
C check DTEVT1 for remaining resonance mass corrections
         CALL DT_EVTRES(irej1)
         IF ( irej1.GT.0 ) THEN
            IRRes(1) = IRRes(1) + 1

            IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 ) WRITE (LOUt,*)
     &            'rejected 2 in EVENTA'
            GOTO 200
         END IF
      END IF

C assign p_t to two-"chain" systems consisting of two resonances only
C since only entries for chains will be affected, this is obsolete
C in case of JETSET-fragmetation
      CALL DT_RESPT

C combine q-aq chains to color ropes (qq-aqaq) (chain fusion)

      IF ( LCO2cr ) CALL DT_COM2CR

C fragmentation of the complete event
C*uncomment for internal phojet-fragmentation
C     CALL DT_EVTFRA(IREJ1)
 100  CALL DT_EVTFRG(2,idum,npymem,irej1)
      IF ( irej1.GT.0 ) THEN
         IRFrag = IRFrag + 1

         IF ( LPRi.GT.4 .AND. IOUlev(1).GT.0 ) WRITE (LOUt,*)
     &         'rejected 3 in EVENTA'
         GOTO 200
      END IF

C decay of possible resonances (should be obsolete)
      CALL DT_DECAY1

      RETURN

 200  IREvt = IREvt + 1
      Irej = 1
      END SUBROUTINE