      subroutine impmai(htw,pet)
c
c     + + + PURPOSE + + +
c
c     SR IMPMAI is the main driver for the impoundment element.
c     It utilizes the stage-discharge, stage-area and stage-length
c     functions defined in SR IMPINT and the incoming daily
c     rectangular input hydrograph and sediment graph.
c     It outputs daily peak outflow, peak volume, and average
c     sediment concentration.
c
c     Called from:
c     Author(s): Mark Lindley, Jim Ascough II
c     Reference in User Guide:
c
c     Version:
c     Date recoded: 3/05/94
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxelm.inc'
      include 'pmximp.inc'
      include 'pmxpln.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real htw, pet
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     htw -
c     pet -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cflags.inc'
c     read: ipdout, idflag
c
      include 'cimday.inc'
      include 'cimeos.inc'
c
      include 'cimitf.inc'
c     read: a,b,c,d,e,ha,ht,hlm,a0,a1,a2,l0,l1,l2,qinf,isize
c
      include 'cimmon.inc'
      include 'cimpnd.inc'
c
      include 'cimqot.inc'
c     read: deltat
c     modify: qo,qon,h,hn,t,tn,dttry,dtdid,dtnext
c
      include 'cimsed.inc'
c     read: d0,di,d100,sg,ndiv,vs
c     modify: ctd,cdp,hmin,hset,co,vs,cot
c
      include 'cimyrs.inc'
c
      include 'cstruct.inc'
c     read: ielmt
c        added by S.Dun  March 16,1999
        include 'cimflg.inc'
c        call the impoundment structure indicators
c
c        include 'cimcv1.inc'
c        include 'cimcv2.inc'
        include 'cimcln.inc'
c        write automatic cleaning flag for culvert 1
        include 'cimacl.inc'
c        write automatic cleaning message
        include 'cimdate.inc'
c        simulating date
c        end adding
c
c     + + + LOCAL VARIABLES + + +
c
      real ai, havg, hihr8, hti, qoqi, qoti, td, td100, vmx, qi, vol,
     1    ti, voli, l, ln, an, cont, w, rt(100), dep(100), voln,
     1    con(100), ci(100), ds, ar, pot(100), clt, sat, slt, sdt, lat,
     1    coit(100), totdep, dept, aset(100), cset(100), clset, slset,
     1    saset, sdset, laset, volset(100), volm, perc, perc1, perc2,
     1    hihr, qoaivs, qoaive, qoarvs, qoqi2, vmxvi, vold, voldep, vpi,
     1    hstart
c
      integer is, itr, icnt, n, i, ig, ip, iv, ntn
c
c     + + + LOCAL DEFINITIONS + + +
c
c     ai        - area of the impoundment at the average stage during the
c                 time of inflow, hti
c     an        - area at the stage at the end of a time step, hn
c     ar        - area at the stage at the beginning of a time step, h
c     aset(i)   - area at settling depth i
c     ci(i)     - concentration of sediment in the ith size subclass
c     clset     - lbs of clay size sediment in impoundment
c     clt       - dummy variable used in determining cl50o
c     coit(i)   - total outgoing sediment in size subclass i
c     con(i)    - outgoing sediment concentration for size subclass i
c                 at the end of a time step
c     cont      - total outgoing sediment concentration at the end of a
c                 time step
c     cset(i)   - settling concentration for particle size class i
c     dep(i)    - deposition of particle size subclass i over a time step
c     dept      - volume of sediment deposited over a time step
c     ds        - dead storage
c     havg      - variable used to determine the average stage
c     hihr      - dimensionless head variable
c     hihr8     - dimensionless head variable
c     hti       - average stage during the time of inflow
c     htw       - height above the outlet channel of the tail water
c     icnt      - particle size do-loop counter
c     ig        - hydrograph counter
c     ip        - percentage in particle class do-loop counter
c     is        - sediment graph counter
c     itr       - flow regime transition counter
c     iv        - flow volume do-loop counter
c     l         - length of the impoundment at the beginning of the time step
c     laset     - lbs of large aggregate size sediment in impoundment
c     lat       - dummy variable used in determining la50o
c     ln        - length of the impoundment at the end of the time step
c     ntn       - counter for adjusting time step
c     pot(i)    - dummy variable used in determining the outgoing d50's
c     pet       - potential evapotranspiration (pan evaporation)
c     perc      - dummy % variable used to determine ci(i)
c     perc1     - dummy % variable used to determine ci(i)
c     perc2     - dummy % variable used to determine ci(i)
c     qi        - inflow
c     qoaive    - variations on overflow rate for Ct and Cd calculations
c     qoaivs    - variations on overflow rate for Ct and Cd calculations
c     qoarvs    - variations on overflow rate for Ct and Cd calculations
c     qoqi      - dimensionless outflow/inflow ratio
c     qoqi2     - square of qoqi
c     qoti      - average outflow during the time of inflow
c     rt(i)     - ratio of the actual detention time to the detenion time
c                 required for 100% settling
c     saset     - lbs of small aggregate size sediment in impoundment
c     sat       - dummy variable used in determining sa50o
c     sdset     - lbs of sand size sediment in impoundment
c     sdt       - dummy variable used in determining sd50o
c     slset     - lbs of silt size sediment in impoundment
c     slt       - dummy variable used in determining sl50o
c     td        - actual detention time
c     td100     - detention time required for 100% settling
c     ti        - duration of inflow
c     totdep    - total sediment volume deposited over a day
c     vmx       - volume at the maximum stage
c     vmxvi     - volume ratio vmx/vi
c     vol       - volume at the beginning of the time step
c     voli      - volume that has entered the impoundment
c     vold      - deposition volume
c     voldep    - second deposition volume
c     volm      - volume of the deposited sediment (hmin)
c     voln      - volume of the new stage
c     volset(i) - volume of settling portion of impoundment for
c                 particle size class i
c     vpi       - average volume of the pond over the period of inflow
c     w         - average width of the impoundment over a time step
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     impflo
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
c     variable initialization
c
      n = 0
      voli = 0.0
      volo(ipond) = 0.0
      vol = 0.0
      volm = 0.0
c
c        added by S.Dun  March 16,1999
c        if (c1icv(ipond).ne.0.or.c2icv(ipond).ne.0) then
           atcln=0
c           if (hmin(ipond).gt.(c1h(ipond)+c1hit(ipond)/2.)) then
           if (hmin(ipond).gt.hfull(ipond)) then
                 alnum(ipond)=alnum(ipond)+1
                 if (alnum(ipond).le.100) then
                    aldate(ipond,alnum(ipond))=ddate
                        alyear(ipond,alnum(ipond))=dyear
                        alhs(ipond,alnum(ipond))=hmin(ipond)
              do 9 i = 1, 5
                alvol(ipond,alnum(ipond)) = alvol(ipond,alnum(ipond)) +
     1          ((a0(ipond)+a1(ipond)*(float(i)*hmin(ipond)/5.)**
     1      a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*hmin(ipond)/5.)
     1      **a2(ipond))) / 2.0 * (float(i)*hmin(ipond)/5.-float(i-1)*
     1      hmin(ipond)/5.)
    9                   continue
             endif
c
           hmin(ipond)=0.0
                 h(ipond)=0.01
                 qo(ipond)=0.0
                 atcln=1
             write (6,*) atcln
c             pause
           endif
c        endif
c        end adding
c
      do 10 i = 1, 5
        volm = volm + ((a0(ipond)+a1(ipond)*(float(i)*hmin(ipond)/5.)**
     1      a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*hmin(ipond)/5.)
     1      **a2(ipond))) / 2.0 * (float(i)*hmin(ipond)/5.-float(i-1)*
     1      hmin(ipond)/5.)
   10 continue
c
      do 20 i = 1, 20
        vol = vol + ((a0(ipond)+a1(ipond)*(float(i)*h(ipond)/20.)**
     1      a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*h(ipond)/20.)**
     1      a2(ipond))) / 2.0 * (float(i)*h(ipond)/20.-float(i-1)*
     1      h(ipond)/20.)
   20 continue
c
      vol = vol - volm
c
c     adjusting the inlet stage for hmin
c
c
c        deavailabed by S.Dun March 31,1999
c
c      do 30 itr = 2, nt(ipond)
c        if (hmin(ipond).gt.ha(10,itr,ipond)) then
cc
c          if (a(10,itr,ipond).gt.0.0) then
c        ht(2,ipond)=hmin(ipond)+0.0025
c            ha(10,itr,ipond) = hmin(ipond)
c            if (hmin(ipond).gt.hlm(itr,ipond)) hlm(itr,ipond) =
c     1          hmin(ipond)
c            if (hmin(ipond).gt.e(10,itr,ipond)) e(10,itr,ipond) =
c     1          hmin(ipond)
c          end if
cc
c        end if
c
c        if (hmin(ipond).gt.ha(12,itr,ipond)) then
cc
c          if (a(12,itr,ipond).gt.0.0) then
c            ha(12,itr,ipond) = hmin(ipond)
c            if (hmin(ipond).gt.hlm(itr,ipond)) hlm(itr,ipond) =
c     1          hmin(ipond)
c            if (hmin(ipond).gt.d(12,itr,ipond)) d(12,itr,ipond) =
c     1          hmin(ipond)
c          end if
cc
c        end if
c
c        if (hmin(ipond).gt.ha(13,itr,ipond)) then
c          if (a(13,itr,ipond).gt.0.0) then
c            ha(13,itr,ipond) = hmin(ipond)
c            if (hmin(ipond).gt.hlm(itr,ipond)) hlm(itr,ipond) =
c     1          hmin(ipond) + 0.0001
c            if (hmin(ipond).gt.ht(itr,ipond)) ht(itr,ipond) =
c     1          hmin(ipond) + 0.0001
c          end if
c        end if
c
c   30 continue
c        added by added by S.Dun  March 16,1999
        call impreg
c        end adding
c
c
c     entering hydrograph info
c
c     read (ipond+9,*) qiin(ipond), vi(ipond), htw, pet
c
      qiin(ipond) = qiin(ipond) * 3.281 ** 3.0
      vi(ipond) = vi(ipond) * 3.281 ** 3.0
c
      htw = htw * 3.281
      pet = pet * 3.281
c
      if (qo(ipond).le.0.00001.and.qiin(ipond).le.0.00001) then
        go to 510
      else
        ig = 0
        totco(ipond) = 0.0
        havg = h(ipond)
        hmax(ipond) = h(ipond)
        hti = h(ipond)
        qomx(ipond) = qo(ipond)
        qoti = 0.0
        ai = a0(ipond) + a1(ipond) * hti ** a2(ipond)
        vmx = 0.0
        n = 0
        ntn = 0
        t(ipond) = 0.0
        ti = 0.0
c
        if (qiin(ipond).gt.0.00001) ti = vi(ipond) / qiin(ipond) /
     1      3600.0
c
        dttry(ipond) = deltat(ipond)
        itr = 1
c
        rewind (50)
c
        write (50) t(ipond), h(ipond), qo(ipond)
c
c       write (6,1050)
c
c       starting hydraulic simulation
c
        write (6,1100) ipond
c
   40   qi = 0.0
c
        if (t(ipond).lt.ti) qi = qiin(ipond)
c
c       determine flow regime and call ouflow subroutine to
c       calculate time step, new stage, and new outflow
c
   50   if (h(ipond).ge.ht(itr,ipond).and.h(ipond).le.ht(itr+1,ipond))
     1  then
                hstart=h(ipond)
c
          call impflo(itr,qi,htw)
c
c         checking for ti and 24 hr approach and setting max values
c
          ig = ig + 1
c
          if (hn(ipond).gt.hmax(ipond)) hmax(ipond) = hn(ipond)
c
          if (t(ipond).gt.ti.and.(hn(ipond).lt.
     1                (hmin(ipond)+0.001))) then
            hn(ipond) = hmin(ipond)
            qon(ipond) = 0.0
            if(qo(ipond).lt.1.0e-06) tn(ipond) = 24.000
          end if
c
c        added by S.Dun  March 16,1999
c        if None rock-fill check dam or emergence spillway or filter
c        fence or Strawbales  or trash barrier is present. when the
c        stage highter than the stage at which the impoundment is
c        overtopped. The overtop flow should occour.
c
             if (firf(ipond).eq.0.and.fies(ipond).eq.0.and.
     1          fiff(ipond).eq.0) then
                  if(hn(ipond).gt.hot(ipond).and.tn(ipond).lt.ti) then
                                qon(ipond)=qi
                                hn(ipond)=hot(ipond)
                                write(6,55) ddate,dyear,ipond
c                                pause
 55        format(1x,'Overtopflow occurred at day',i5,' year',i3
     1        ,' in the impoundment',i3)
                        endif
                  endif
c        end adding
          if (abs(qo(ipond)-qi).lt.0.0001) then
            if (abs(qon(ipond)-qi).lt.0.0001) ntn = ntn + 1
            if (ntn.le.1.and.tn(ipond).le.ti) tn(ipond) = ti + 0.0001
          end if
c
          write (50) tn(ipond), hn(ipond), qon(ipond)
          if (qon(ipond).gt.qomx(ipond)) qomx(ipond) = qon(ipond)
c
          havg = ((hn(ipond)-h(ipond))/2.0+h(ipond)) * (tn(ipond)-
     1        t(ipond)) + havg
          volo(ipond) = volo(ipond) + (tn(ipond)-t(ipond)) * 3600. * (
     1        qon(ipond)+qo(ipond)) / 2.0
c
c        if (itr.gt.1.and.volo(ipond).lt.1.e-5) pause
c
          dttry(ipond) = dtnext(ipond)
          t(ipond) = tn(ipond)
          h(ipond) = hn(ipond)
          qo(ipond) = qon(ipond)
c
          if (itr.lt.3) itr = 1
          if (itr.ge.3) itr = itr - 2
c
          if (tn(ipond).lt.ti) then
            if ((tn(ipond)+dttry(ipond)).gt.ti) dttry(ipond) = ti -
     1          tn(ipond)
          end if
c
          if (tn(ipond).lt.24.0) then
            if ((tn(ipond)+dttry(ipond)).gt.24.0) dttry(ipond) = 24.0 -
     1          tn(ipond)
          end if
c
          if (tn(ipond).ge.ti) then
            n = n + 1
            if (n.eq.1) dttry(ipond) = deltat(ipond)
          end if
c
          if (tn(ipond).lt.(ti+0.00001)) then
            hti = havg / ti
            qoti = volo(ipond) / (ti*3600.)
            ai = a0(ipond) + a1(ipond) * hti ** a2(ipond)
          end if
c
          if (ti.lt.0.0001) then
            hti = hmax(ipond)
            qoti = qomx(ipond)
          end if
c
c
          if (tn(ipond).lt.24.0) go to 40
c
        else
c
          itr = itr + 1
c         write (6,1060) t(ipond),h(ipond),qi,qo(ipond),itr,
c         1       ht(itr+1,ipond)
c
          go to 50
        end if
c
c       calculate the time of concentration for the impoundment
c
        if (qomx(ipond).gt.0.0) then
          tcf(ipond) = ((((vi(ipond)/qomx(ipond))/2.0)/3600.0)-(ti/2.0))
     1        / 0.60
        else
          tcf(ipond) = 0.0
        end if
c
c       set tcf(ipond) to zero if less than zero - technically
c       this should never happen (ti > to) but does because of
c       instabilities in the numerical solution for low flow
c       structures (i.e., filter fences, straw bales, rock fill
c       check dams, etc.)
c
        if (tcf(ipond).lt.0.0) tcf(ipond) = 0.0
c
c       restrict tcf(ipond) to 24 hours if greater than 24 hours
c       because of 24 hour hydrograph limitation
c
        if (tcf(ipond).gt.24.0) tcf(ipond) = 24.0
c
c       write (6,1000) ielmt, vi(ipond), ipond, tcf(ipond)
c
c       sedimentation simulation
c
c       reading values and setting variables
c
c       read (ipond+9,*) ciin(ipond)
c       read (ipond+9,*) pcl(ipond), psl(ipond), psd(ipond),
c       1      psa(ipond), pla(ipond)
c       read (ipond+9,*) cl50, sl50, sd50, sa50, la50
c       read (ipond+9,*)
c
        if (ciin(ipond).gt.cpkim(ipond)) cpkim(ipond) = ciin(ipond)
        if (ciin(ipond).gt.cpkiy(ipond)) cpkiy(ipond) = ciin(ipond)
        if (ciin(ipond).gt.cpkie(ipond)) cpkie(ipond) = ciin(ipond)
c
        ciin(ipond) = ciin(ipond) * 0.00006241778465
c
        cout(ipond) = 0.0
        clout(ipond) = 0.0
        slout(ipond) = 0.0
        saout(ipond) = 0.0
        sdout(ipond) = 0.0
        laout(ipond) = 0.0
c
        clt = 0.0
        slt = 0.0
        sat = 0.0
        sdt = 0.0
        lat = 0.0
c
        ret(ipond) = 0.0
        clret(ipond) = 0.0
        slret(ipond) = 0.0
        saret(ipond) = 0.0
        sdret(ipond) = 0.0
        laret(ipond) = 0.0
c
        i = 1
c
   60   if (cl50.lt.d100(i,ipond)) then
          perc = (log10(cl50)-log10(d0(i,ipond))) / (
     1        log10(d100(i,ipond))-log10(d0(i,ipond)))
          perc1 = float(i-1) + perc
          perc2 = 2.0 * float(ndiv(ipond)) - perc1
c
          do 70 ip = 1, i - 1
            ci(ip) = ciin(ipond) * pcl(ipond) / (2.0*perc1)
   70     continue
c
          ci(i) = (perc/perc1+(1.0-perc)/perc2) * ciin(ipond) *
     1        pcl(ipond) / 2.0
c
          do 80 ip = i + 1, 2 * ndiv(ipond)
            ci(ip) = ciin(ipond) * pcl(ipond) / (2.0*perc2)
   80     continue
c
        else
          i = i + 1
          go to 60
        end if
c
        i = 2 * ndiv(ipond) + 1
c
   90   if (sl50.lt.d100(i,ipond)) then
          perc = (log10(sl50)-log10(d0(i,ipond))) / (
     1        log10(d100(i,ipond))-log10(d0(i,ipond)))
          perc1 = float(i-(2*ndiv(ipond)+1)) + perc
          perc2 = 2.0 * float(ndiv(ipond)) - perc1
c
          do 100 ip = 2 * ndiv(ipond) + 1, i - 1
            ci(ip) = ciin(ipond) * psl(ipond) / (2.0*perc1)
  100     continue
c
          ci(i) = (perc/perc1+(1.0-perc)/perc2) * ciin(ipond) *
     1        psl(ipond) / 2.0
c
          do 110 ip = i + 1, 4 * ndiv(ipond)
            ci(ip) = ciin(ipond) * psl(ipond) / (2.0*perc2)
  110     continue
c
        else
          i = i + 1
          go to 90
        end if
c
        i = 4 * ndiv(ipond) + 1
c
  120   if (sa50.lt.d100(i,ipond)) then
          perc = (log10(sa50)-log10(d0(i,ipond))) / (
     1        log10(d100(i,ipond))-log10(d0(i,ipond)))
          perc1 = float(i-(4*ndiv(ipond)+1)) + perc
          perc2 = 2.0 * float(ndiv(ipond)) - perc1
c
          do 130 ip = 4 * ndiv(ipond) + 1, i - 1
            ci(ip) = ciin(ipond) * psa(ipond) / (2.0*perc1)
  130     continue
c
          ci(i) = (perc/perc1+(1.0-perc)/perc2) * ciin(ipond) *
     1        psa(ipond) / 2.0
c
          do 140 ip = i + 1, 6 * ndiv(ipond)
            ci(ip) = ciin(ipond) * psa(ipond) / (2.0*perc2)
  140     continue
c
        else
          i = i + 1
          go to 120
        end if
c
        i = 6 * ndiv(ipond) + 1
c
  150   if (sd50.lt.d100(i,ipond)) then
          perc = (log10(sd50)-log10(d0(i,ipond))) / (
     1        log10(d100(i,ipond))-log10(d0(i,ipond)))
          perc1 = float(i-(6*ndiv(ipond)+1)) + perc
          perc2 = 2.0 * float(ndiv(ipond)) - perc1
c
          do 160 ip = 6 * ndiv(ipond) + 1, i - 1
            ci(ip) = ciin(ipond) * psd(ipond) / (2.0*perc1)
  160     continue
c
          ci(i) = (perc/perc1+(1.0-perc)/perc2) * ciin(ipond) *
     1        psd(ipond) / 2.0
c
          do 170 ip = i + 1, 8 * ndiv(ipond)
            ci(ip) = ciin(ipond) * psd(ipond) / (2.0*perc2)
  170     continue
c
        else
          i = i + 1
          go to 150
        end if
c
        i = 8 * ndiv(ipond) + 1
c
  180   if (la50.lt.d100(i,ipond)) then
          perc = (log10(la50)-log10(d0(i,ipond))) / (
     1        log10(d100(i,ipond))-log10(d0(i,ipond)))
          perc1 = float(i-(8*ndiv(ipond)+1)) + perc
          perc2 = 2. * float(ndiv(ipond)) - perc1
c
          do 190 ip = 8 * ndiv(ipond) + 1, i - 1
            ci(ip) = ciin(ipond) * pla(ipond) / (2.0*perc1)
  190     continue
c
          ci(i) = (perc/perc1+(1.0-perc)/perc2) * ciin(ipond) *
     1        pla(ipond) / 2.0
c
          do 200 ip = i + 1, 10 * ndiv(ipond)
            ci(ip) = ciin(ipond) * pla(ipond) / (2.0*perc2)
  200     continue
c
        else
          i = i + 1
          go to 180
        end if
c
        do 210 i = 1, 10 * ndiv(ipond)
          coit(i) = 0.0
  210   continue
c
c       determining Ct and Cd
c
        if (qiin(ipond).ge.0.00001) then
c
          if (isize(ipond).eq.1) then
            vpi = 0.0
            vmx = 0.0
c
            do 220 i = 1, 30
c
              vpi = vpi + ((a0(ipond)+a1(ipond)*(float(i)*hti/30.)**
     1            a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*hti/30.)**
     1            a2(ipond))) / 2. * (float(i)*hti/30.-float(i-1)*hti/
     1            30.)
c
              vmx = vmx + ((a0(ipond)+a1(ipond)*(float(i)*hmax(ipond)/
     1            30.)**a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*
     1            hmax(ipond)/30.)**a2(ipond))) / 2. * (float(i)*
     1            hmax(ipond)/30.-float(i-1)*hmax(ipond)/30.)
c
  220       continue
c
            vpi = vpi / 43560.0
            vmx = vmx / 43560.0
            hihr = (hti-ht(2,ipond))
            if(hihr.le.0.0) hihr = 0.0
            qoqi = qoti / qiin(ipond)
            qoqi2 = qoqi ** 2
            vmxvi = vmx / vi(ipond)
            qoaivs = (qoti/ai) / 0.00001124
c
            do 230 i = 1, 2 * ndiv(ipond)
              ctd(i,ipond) = 0.039954 + 0.011496 * qoaivs
              cdp(i,ipond) = 4.0665
  230       continue
c
            do 240 i = 2 * ndiv(ipond) + 1, 4 * ndiv(ipond)
              ctd(i,ipond) = 0.013980 + 0.110453 * qoqi
              cdp(i,ipond) = 0.755060 + 1.304780 * vmxvi + 0.131947 *
     1            vpi
  240       continue
c
            do 250 i = 4 * ndiv(ipond) + 1, 6 * ndiv(ipond)
              ctd(i,ipond) = 0.014586 + 0.127389 * qoqi2
              cdp(i,ipond) = 0.466084 + 2.752976 * vmxvi + 0.058282 *
     1            vmx
  250       continue
c
            qoaivs = (qoti/ai) / 0.0063578458
c
            do 260 i = 6 * ndiv(ipond) + 1, 8 * ndiv(ipond)
              ctd(i,ipond) = 0.005945 + 0.254620 * qoaivs
              cdp(i,ipond) = 0.63185 * qoaivs
  260       continue
c
            qoaivs = (qoti/ai) / 0.1637373
c
            do 270 i = 8 * ndiv(ipond) + 1, 10 * ndiv(ipond)
              ctd(i,ipond) = 0.005527 + 12.588091 * qoaivs
              cdp(i,ipond) = 41.670461 * qoaivs + 0.004962 * hihr
  270       continue
c
          else
c
            hihr8 = (hti-ht(2,ipond)) / hti
            ar = a0(ipond) + a1(ipond) * ht(2,ipond) ** a2(ipond)
            qoqi = qoti / qiin(ipond)
            vmx = 0.0
c
            do 280 i = 1, 30
              vmx = vmx + ((a0(ipond)+a1(ipond)*(float(i)*hmax(ipond)/
     1            30.)**a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*
     1            hmax(ipond)/30.)**a2(ipond))) / 2. * (float(i)*
     1            hmax(ipond)/30.-float(i-1)*hmax(ipond)/30.)
  280       continue
c
            vmxvi = vmx / vi(ipond)
c
            do 290 i = 1, 2 * ndiv(ipond)
              qoaivs = qoti / ai / 0.00001124
              ctd(i,ipond) = 0.100954 + 0.049397 * qoaivs - 0.117660 *
     1            hihr8
              if (ctd(i,ipond).lt.0.0005) ctd(i,ipond) = 0.0005
              cdp(i,ipond) = 1.0
  290       continue
c
            do 300 i = 2 * ndiv(ipond) + 1, 4 * ndiv(ipond)
              ctd(i,ipond) = 0.002119 + 0.125354 * qoqi
              cdp(i,ipond) = 0.001641 * vmx / 43560.0 + 3.830727 * hihr8
              if (ctd(i,ipond).lt.0.004) ctd(i,ipond) = 0.004
              if (cdp(i,ipond).lt.0.0005) cdp(i,ipond) = 0.0005
  300       continue
c
            do 310 i = 4 * ndiv(ipond) + 1, 6 * ndiv(ipond)
              ctd(i,ipond) = -0.040098 + 0.193138 * qoqi + 0.041245 *
     1            vmxvi
              cdp(i,ipond) = 0.004276 * vmx / 43560.0 + 3.123986 * hihr8
              if (ctd(i,ipond).lt.0.005) ctd(i,ipond) = 0.005
              if (cdp(i,ipond).lt.0.0005) cdp(i,ipond) = 0.0005
  310       continue
c
            do 320 i = 6 * ndiv(ipond) + 1, 8 * ndiv(ipond)
              qoarvs = qoti / ar / 0.063578458
              qoaive = 1.0 - exp(-qoti/ai/0.063578458)
              ctd(i,ipond) = 0.003719 + 3.104505 * qoaive - 0.004918 *
     1            hihr8
              cdp(i,ipond) = -0.074626 + 17.705171 * qoarvs + 0.000178 *
     1            vi(ipond) / 43560.0
              if (ctd(i,ipond).lt.0.002) ctd(i,ipond) = 0.002
              if (cdp(i,ipond).lt.0.0005) cdp(i,ipond) = 0.0005
  320       continue
c
            do 330 i = 8 * ndiv(ipond) + 1, 10 * ndiv(ipond)
              qoarvs = qoti / ar / 0.1637373
              qoaive = 1.0 - exp(-qoti/ai/0.1637373)
              ctd(i,ipond) = 0.008442 + 12.443736 * qoaive - 0.011869 *
     1            hihr8
              cdp(i,ipond) = -0.575718 + 0.358606 * vmxvi + 172.424594 *
     1            qoarvs
              if (ctd(i,ipond).lt.0.006) ctd(i,ipond) = 0.006
              if (cdp(i,ipond).lt.0.0005) cdp(i,ipond) = 0.0005
  330       continue
c
          end if
        end if
c
c       reading hydraulics file
c
        volo(ipond) = 0.0
c
        totco(ipond) = 0.0
        totdep = 0.0
        cpeak(ipond) = 0.0
c
        rewind (50)
        read (50) t(ipond), h(ipond), qo(ipond)
c
        cot(ipond) = cot(ipond) / 0.00006241778465
c
        if ((npond.eq.1).and.(ipdout.eq.1)) write (55,1000) t(ipond),
     1      h(ipond), qo(ipond), cot(ipond)
c
        cot(ipond) = cot(ipond) * 0.00006241778465
        ar = a0(ipond) + a1(ipond) * h(ipond) ** a2(ipond)
c        added by S.Dun July 1,1999
        if(h(ipond).le.0.0) h(ipond)=0.00001
c        end adding
        l = l0(ipond) + l1(ipond) * h(ipond) ** l2(ipond)
c
        do 380 is = 1, ig
c
          read (50) tn(ipond), hn(ipond), qon(ipond)
c
          qi = 0.0
          if (t(ipond).lt.ti) qi = qiin(ipond)
c
c         determining deposition
c
          an = a0(ipond) + a1(ipond) * hn(ipond) ** a2(ipond)
          ln = l0(ipond) + l1(ipond) * hn(ipond) ** l2(ipond)
c
          voln = 0.0
c
          do 340 i = 1, 20
            voln = voln + ((a0(ipond)+a1(ipond)*(float(i)*hn(ipond)/20.)
     1          **a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*
     1          hn(ipond)/20.)**a2(ipond))) / 2.0 * (float(i)*
     1          hn(ipond)/20.-float(i-1)*hn(ipond)/20.)
  340     continue
c
          voln = voln - volm
c
          if (voln.le.volm) voln = 0.00001
          voli = voli + (tn(ipond)-t(ipond)) * 3600. * qi
          volo(ipond) = volo(ipond) + (tn(ipond)-t(ipond)) * 3600. * (
     1        qon(ipond)+qo(ipond)) / 2.0
          w = ((ar+an)/2.0) / ((l+ln)/2.0)
c
          if ((((l+ln)/2.0)/w).ge.2.0) ds = 0.15
          if ((((l+ln)/2.0)/w).lt.2.0) ds = 0.25
c
          cont = 0.0
          dept = 0.0
c
          do 350 i = 1, 10 * ndiv(ipond)
c
            if (qo(ipond).le.0.0) then
              rt(i) = 1.0
            else
              td = ctd(i,ipond) * (1.0-ds) * ((vol+voln)/2.0) /
     1            qo(ipond)
              td100 = (1.0-ds) * ((vol+voln)/2.0) / ((ar+an)/2.0) /
     1            vs(i,ipond)
c
              if ((td/td100).ge.1.0) rt(i) = 1.0
              if ((td/td100).lt.1.0) rt(i) = td / td100
c
            end if
c
            if (qi.le.0.0) dep(i) = cdp(i,ipond) * rt(i) * co(i,ipond) *
     1          vs(i,ipond) * ((ar+an)/2.0) * (tn(ipond)-t(ipond)) *
     1          3600.0
c
c           if (qi.le.0.0) then
c           if (vs(i,ipond)*(ar+an)/2.0*(tn(ipond)-t(ipond))*3600.0
c           1            .le.(vol+voln)/2.0) then
c           dep(i) = cdp(i,ipond) * rt(i) * co(i,ipond) *
c           1       vs(i,ipond) * ((ar+an)/2.0) * (tn(ipond)-t(ipond)) *
c           1       3600.0
c           else
c           dep(i) = cdp(i,ipond) * rt(i) * co(i,ipond) *
c           1            (vol+voln)/2.0 * (tn(ipond)-t(ipond)) * 3600.0
c           endif
c           endif
c
            if (qi.gt.0.0) dep(i) = rt(i) * ci(i) * qi * (tn(ipond)-
     1          t(ipond)) * 3600.0
c
c           new overall and size class outflow concentrations
c
            con(i) = (co(i,ipond)*((1.0-ds)*(vol+voln)/2.-(tn(ipond)-
     1          t(ipond))/2.*3600.*qi)+qi*ci(i)*(tn(ipond)-t(ipond))*
     1          3600.-dep(i)) / ((tn(ipond)-t(ipond))*3600./2.*qi+(1.0-
     1          ds)*(vol+voln)/2.)
c
            if (con(i).le.0.0) then
              con(i) = 0.0
              dep(i) = co(i,ipond) * ((1.0-ds)*(vol+voln)/2.-(
     1            tn(ipond)-t(ipond))/2.*3600.*qi) + qi * ci(i) * (
     1            tn(ipond)-t(ipond)) * 3600.
            end if
c
            cont = cont + con(i)
            dept = dept + dep(i) / (sg(i,ipond)*62.4)
            coit(i) = coit(i) + 3600. * (tn(ipond)-t(ipond)) * (
     1          qon(ipond)+qo(ipond)) / 2. * (con(i)+co(i,ipond)) / 2.0
c
  350     continue
c
          totco(ipond) = ((cont+cot(ipond))/2.0) * (tn(ipond)-t(ipond))
     1        * 3600. * (qo(ipond)+qon(ipond)) / 2. + totco(ipond)
          totdep = totdep + dept
          cont = cont / 0.00006241778465
c
          if (cont.gt.cpeak(ipond)) cpeak(ipond) = cont
          if (cont.gt.cpeakm(ipond)) cpeakm(ipond) = cont
          if (cont.gt.cpeaky(ipond)) cpeaky(ipond) = cont
          if (cont.gt.cpeake(ipond)) cpeake(ipond) = cont
c
          if ((npond.eq.1).and.(ipdout.eq.1)) write (55,1000)
     1        tn(ipond), hn(ipond), qon(ipond), cont
c
          cont = cont * 0.00006241778465
          havg = ((hn(ipond)-h(ipond))/2.0+h(ipond)) * (tn(ipond)-
     1        t(ipond)) + havg
c
          do 360 i = 1, 2 * ndiv(ipond)
            clout(ipond) = clout(ipond) + 3600. * (tn(ipond)-t(ipond)) *
     1          (qon(ipond)+qo(ipond)) / 2. * (con(i)+co(i,ipond)) / 2.
            slout(ipond) = slout(ipond) + 3600. * (tn(ipond)-t(ipond)) *
     1          (qon(ipond)+qo(ipond)) / 2. * (con(i+2*ndiv(ipond))+
     1          co(i+2*ndiv(ipond),ipond)) / 2.
            saout(ipond) = saout(ipond) + 3600. * (tn(ipond)-t(ipond)) *
     1          (qon(ipond)+qo(ipond)) / 2. * (con(i+4*ndiv(ipond))+
     1          co(i+4*ndiv(ipond),ipond)) / 2.
            sdout(ipond) = sdout(ipond) + 3600. * (tn(ipond)-t(ipond)) *
     1          (qon(ipond)+qo(ipond)) / 2. * (con(i+6*ndiv(ipond))+
     1          co(i+6*ndiv(ipond),ipond)) / 2.
            laout(ipond) = laout(ipond) + 3600. * (tn(ipond)-t(ipond)) *
     1          (qon(ipond)+qo(ipond)) / 2. * (con(i+8*ndiv(ipond))+
     1          co(i+8*ndiv(ipond),ipond)) / 2.
  360     continue
c
          cot(ipond) = cont
c
          do 370 i = 1, 10 * ndiv(ipond)
            co(i,ipond) = con(i)
  370     continue
c
          ar = an
          l = ln
          vol = voln
          t(ipond) = tn(ipond)
          h(ipond) = hn(ipond)
          qo(ipond) = qon(ipond)
c
  380   continue
c
c       determining outputs, peak outflow, volume, and
c       average sediment concentration
c
        if (volo(ipond).le.0.0) ca(ipond) = 0.0
        if (volo(ipond).gt.0.0) ca(ipond) = (totco(ipond)/volo(ipond)) /
     1      0.00006241778465
c
        qomx(ipond) = qomx(ipond) / 3.281 ** 3.0
        volo(ipond) = volo(ipond) / 3.281 ** 3.0
c
        if ((npond.eq.1).and.(ipdout.eq.1)) write (54,1000)
     1      qomx(ipond), volo(ipond), ca(ipond)
c
        qomx(ipond) = qomx(ipond) * 3.281 ** 3.0
        volo(ipond) = volo(ipond) * 3.281 ** 3.0
c
        cout(ipond) = totco(ipond)
        if (cout(ipond).le.0.0) cout(ipond) = 0.00001
c
c       percent in size class
c
        clot = clout(ipond) / cout(ipond)
        slot = slout(ipond) / cout(ipond)
        saot = saout(ipond) / cout(ipond)
        sdot = sdout(ipond) / cout(ipond)
        laot = laout(ipond) / cout(ipond)
c
        if (clot.gt.1.0) then
          clot = 1.0
        else if (slot.gt.1.0) then
          slot = 1.0
        else if (saot.gt.1.0) then
          saot = 1.0
        else if (sdot.gt.1.0) then
          sdot = 1.0
        else if (laot.gt.1.0) then
          laot = 1.0
        end if
c
        if ((npond.eq.1).and.(ipdout.eq.1)) write (54,1000) clot, slot,
     1      sdot, saot, laot
c
c       determining new d50's
c
        icnt = 0
c
        do 390 i = 1, 2 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (clout(ipond).le.0.001) then
              cl50o = d0(1,ipond)
              go to 400
            else
              clt = clt + coit(i)
              pot(i) = clt / clout(ipond)
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.1) then
                  cl50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  cl50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  390   continue
c
        icnt = 0
c
  400   do 410 i = (2*ndiv(ipond)+1), 4 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (slout(ipond).le.0.001) then
              sl50o = d0(2*ndiv(ipond)+1,ipond)
              go to 420
            else
              slt = slt + coit(i)
              pot(i) = slt / slout(ipond)
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(2*ndiv(ipond)+1)) then
                  sl50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sl50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  410   continue
c
        icnt = 0
c
  420   do 430 i = (4*ndiv(ipond)+1), 6 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (saout(ipond).le.0.001) then
              sa50o = d0(4*ndiv(ipond)+1,ipond)
              go to 440
            else
              sat = sat + coit(i)
              pot(i) = sat / saout(ipond)
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(4*ndiv(ipond)+1)) then
                  sa50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sa50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  430   continue
c
        icnt = 0
c
  440   do 450 i = (6*ndiv(ipond)+1), 8 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (sdout(ipond).le.0.001) then
              sd50o = d0(6*ndiv(ipond)+1,ipond)
              go to 460
            else
              sdt = sdt + coit(i)
              pot(i) = sdt / sdout(ipond)
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(6*ndiv(ipond)+1)) then
                  sd50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sd50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  450   continue
c
        icnt = 0
c
  460   do 470 i = (8*ndiv(ipond)+1), 10 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (laout(ipond).le.0.001) then
              la50o = d0(8*ndiv(ipond)+1,ipond)
              go to 480
            else
              lat = lat + coit(i)
              pot(i) = lat / laout(ipond)
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(8*ndiv(ipond)+1)) then
                  la50o = 10.0 ** (log10(d0(1,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  la50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  470   continue
c
  480   sa50o = sa50o / (0.8/1.65) ** 0.5
        la50o = la50o / (0.6/1.65) ** 0.5
c
        if ((npond.eq.1).and.(ipdout.eq.1)) write (54,1000) cl50o,
     1      sl50o, sd50o, sa50o, la50o
c
c       adjusting stage for evaporation, infiltration, and deposition
c
        h(ipond) = h(ipond) - qinf(ipond) - 0.7 * pet
        vold = 0.0
c
  490   voldep = vold + 0.01 * ((a0(ipond)+a1(ipond)*(hmin(ipond)+0.01)
     1      **a2(ipond))+(a0(ipond)+a1(ipond)*(hmin(ipond))**a2(ipond)))
     1      / 2
c
        if (voldep.gt.totdep) then
          hmin(ipond) = hmin(ipond) + 0.01 * (totdep-vold) / (voldep-
     1        vold)
        else
          hmin(ipond) = hmin(ipond) + 0.01
          vold = voldep
          go to 490
        end if
c
c       need to put a maximum value on totdep or on hmin,
c       otherwise the variable totdep (total volume deposited) can
c       get very big which gives impossibly high values of hmin
c
        if (h(ipond).lt.hmin(ipond)) then
          h(ipond) = hmin(ipond)
          qo(ipond) = 0.0
        end if
c
      end if
c
      do 500 i = 1, 10 * ndiv(ipond)
        hset(i,ipond) = h(ipond)
  500 continue
c
c     convert outflow volume from ft^3 to m^3
c
      volo(ipond) = volo(ipond) / 3.281 ** 3
c
c     convert sediment from lbs to kg
c
      cout(ipond) = totco(ipond) * 0.4536
      clout(ipond) = clout(ipond) * 0.4536
      slout(ipond) = slout(ipond) * 0.4536
      saout(ipond) = saout(ipond) * 0.4536
      sdout(ipond) = sdout(ipond) * 0.4536
      laout(ipond) = laout(ipond) * 0.4536
c
      if (cpeak(ipond).lt.ca(ipond)) cpeak(ipond) = ca(ipond)
c
c     go to 690
      return
c
c     determining deposition during no flow conditions
c
  510 continue
c
      volo(ipond) = 0.0
      qomx(ipond) = 0.0
c
      cout(ipond) = 0.0
      clout(ipond) = 0.0
      slout(ipond) = 0.0
      saout(ipond) = 0.0
      sdout(ipond) = 0.0
      laout(ipond) = 0.0
c
      clot = 0.0
      slot = 0.0
      sdot = 0.0
      saot = 0.0
      laot = 0.0
c
      ret(ipond) = 0.0
      clret(ipond) = 0.0
      slret(ipond) = 0.0
      saret(ipond) = 0.0
      sdret(ipond) = 0.0
      laret(ipond) = 0.0
c
      ca(ipond) = 0.0
      cpeak(ipond) = 0.0
c
      cl50o = d0(1,ipond)
      sl50o = d0(2*ndiv(ipond)+1,ipond)
      sd50o = d0(6*ndiv(ipond)+1,ipond)
      sa50o = d0(4*ndiv(ipond)+1,ipond)
      la50o = d0(8*ndiv(ipond)+1,ipond)
c
      if ((npond.eq.1).and.(ipdout.eq.1)) then
        write (54,1000) qomx(ipond), volo(ipond), cout(ipond)
        write (54,1000) clot, slot, sdot, saot, laot
        write (54,1000) cl50o, sl50o, sd50o, sa50o, la50o
      end if
c
c     read (ipond+9,*) ciin(ipond)
c     read (ipond+9,*) pcl(ipond), psl(ipond), psd(ipond),
c     1    psa(ipond), pla(ipond)
c     read (ipond+9,*) cl50, sl50, sd50, sa50, la50
c     read (ipond+9,*)
c
      if (h(ipond).gt.hmin(ipond)) then
c
        totdep = 0.0
c
        clset = 0.0
        slset = 0.0
        saset = 0.0
        sdset = 0.0
        laset = 0.0
c
        clt = 0.0
        slt = 0.0
        sat = 0.0
        sdt = 0.0
        lat = 0.0
c
        volm = 0.0
c
        do 520 i = 1, 5
          volm = volm + ((a0(ipond)+a1(ipond)*(float(i)*hmin(ipond)/5.)
     1        **a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*
     1        hmin(ipond)/5.)**a2(ipond))) / 2.0 * (float(i)*
     1        hmin(ipond)/5.-float(i-1)*hmin(ipond)/5.)
  520   continue
c
        vol = 0.0
c
        do 530 i = 1, 20
          vol = vol + ((a0(ipond)+a1(ipond)*(float(i)*h(ipond)/20.)**
     1        a2(ipond))+(a0(ipond)+a1(ipond)*(float(i-1)*h(ipond)/20.)
     1        **a2(ipond))) / 2.0 * (float(i)*h(ipond)/20.-float(i-1)*
     1        h(ipond)/20.)
  530   continue
c
        vol = vol - volm
c
        do 550 i = 1, 10 * ndiv(ipond)
          hset(i,ipond) = hset(i,ipond) - vs(i,ipond) * 24.0 * 3600.0
c
          if (hset(i,ipond).lt.hmin(ipond)) then
            hset(i,ipond) = hmin(ipond)
            aset(i) = a0(ipond) + a1(ipond) * hset(i,ipond) **
     1          a2(ipond)
            volset(i) = 0.0
            cset(i) = 0.0
            dep(i) = co(i,ipond) * vol
            co(i,ipond) = 0.0
          else
            aset(i) = a0(ipond) + a1(ipond) * hset(i,ipond) **
     1          a2(ipond)
            volset(i) = 0.0
c
            do 540 iv = 1, 20
              volset(i) = volset(i) + ((a0(ipond)+a1(ipond)*(float(iv)*
     1            hset(i,ipond)/20.)**a2(ipond))+(a0(ipond)+a1(ipond)*(
     1            float(iv-1)*hset(i,ipond)/20.)**a2(ipond))) / 2.0 * (
     1            float(iv)*hset(i,ipond)/20.-float(iv-1)*
     1            hset(i,ipond)/20.)
  540       continue
c
            volset(i) = volset(i) - volm
            cset(i) = co(i,ipond) * vol / volset(i)
            dep(i) = cset(i) * vs(i,ipond) * aset(i) * 24. * 3600.
c
            if (dep(i).gt.(co(i,ipond)*vol)) then
              dep(i) = co(i,ipond) * vol
              co(i,ipond) = 0.0
            else
              co(i,ipond) = (co(i,ipond)*vol-dep(i)) / vol
            end if
c
          end if
c
          totdep = totdep + dep(i) / (sg(i,ipond)*62.4)
          ret(ipond) = ret(ipond) + dep(i) + co(i,ipond) * vol
  550   continue
c
        do 560 i = 1, 2 * ndiv(ipond)
          clset = clset + co(i,ipond) * vol
          clret(ipond) = clret(ipond) + dep(i) + co(i,ipond) * vol
          slset = slset + co(i+2*ndiv(ipond),ipond) * vol
          slret(ipond) = slret(ipond) + dep(i+2*ndiv(ipond)) +
     1        co(i+2*ndiv(ipond),ipond) * vol
          saset = saset + co(i+4*ndiv(ipond),ipond) * vol
          saret(ipond) = saret(ipond) + dep(i+4*ndiv(ipond)) +
     1        co(i+4*ndiv(ipond),ipond) * vol
          sdset = sdset + co(i+6*ndiv(ipond),ipond) * vol
          sdret(ipond) = sdret(ipond) + dep(i+6*ndiv(ipond)) +
     1        co(i+6*ndiv(ipond),ipond) * vol
          laset = laset + co(i+8*ndiv(ipond),ipond) * vol
          laret(ipond) = laret(ipond) + dep(i+8*ndiv(ipond)) +
     1        co(i+8*ndiv(ipond),ipond) * vol
  560   continue
c
c       determining new d50's
c
        icnt = 0
c
        do 570 i = 1, 2 * ndiv(ipond)
          if (icnt.lt.1) then
c
            if (clset.le.0.001) then
              cl50o = d0(1,ipond)
              go to 580
            else
              clt = clt + co(i,ipond) * vol
              pot(i) = clt / clset
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.1) then
                  cl50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  cl50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  570   continue
c
        icnt = 0
c
  580   do 590 i = (2*ndiv(ipond)+1), 4 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (slset.le.0.001) then
              sl50o = d0(2*ndiv(ipond)+1,ipond)
              go to 600
            else
              slt = slt + co(i,ipond) * vol
              pot(i) = slt / slset
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(2*ndiv(ipond)+1)) then
                  sl50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sl50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  590   continue
c
        icnt = 0
c
  600   do 610 i = (4*ndiv(ipond)+1), 6 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (saset.le.0.001) then
              sa50o = d0(4*ndiv(ipond)+1,ipond)
              go to 620
            else
              sat = sat + co(i,ipond) * vol
              pot(i) = sat / saset
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(4*ndiv(ipond)+1)) then
                  sa50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sa50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  610   continue
c
        icnt = 0
c
  620   do 630 i = (6*ndiv(ipond)+1), 8 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (sdset.le.0.001) then
              sd50o = d0(6*ndiv(ipond)+1,ipond)
              go to 640
            else
              sdt = sdt + co(i,ipond) * vol
              pot(i) = sdt / sdset
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(6*ndiv(ipond)+1)) then
                  sd50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(i,ipond))))
                else
                  sd50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  630   continue
c
        icnt = 0
c
  640   do 650 i = (8*ndiv(ipond)+1), 10 * ndiv(ipond)
c
          if (icnt.lt.1) then
c
            if (laset.le.0.001) then
              la50o = d0(8*ndiv(ipond)+1,ipond)
              go to 660
            else
              lat = lat + co(i,ipond) * vol
              pot(i) = lat / laset
c
              if (pot(i).ge.0.5) then
                icnt = icnt + 1
c
                if (i.gt.(8*ndiv(ipond)+1)) then
                  la50o = 10.0 ** (log10(d0(i,ipond))+(0.5-pot(i-1))/(
     1                pot(i)-pot(i-1))*(log10(d100(i,ipond))-
     1                log10(d0(1,ipond))))
                else
                  la50o = 10.0 ** (log10(d0(i,ipond))+0.5/pot(i)*(
     1                log10(d100(i,ipond))-log10(d0(i,ipond))))
                end if
c
              end if
            end if
          end if
  650   continue
c
  660   sa50o = sa50o / (0.8/1.65) ** 0.5
        la50o = la50o / (0.6/1.65) ** 0.5
c
c       adjusting stage for evaporation, infiltration, and deposition
c
        hmax(ipond) = h(ipond)
        h(ipond) = h(ipond) - qinf(ipond) - 0.7 * pet
        vold = 0.0
c
  670   voldep = vold + 0.01 * ((a0(ipond)+a1(ipond)*(hmin(ipond)+0.01)
     1      **a2(ipond))+(a0(ipond)+a1(ipond)*(hmin(ipond))**a2(ipond)))
     1      / 2
c
        if (voldep.gt.totdep) then
          hmin(ipond) = hmin(ipond) + 0.01 * (totdep-vold) / (voldep-
     1        vold)
        else
          hmin(ipond) = hmin(ipond) + 0.01
          vold = voldep
          go to 670
        end if
c
        if (h(ipond).lt.hmin(ipond)) h(ipond) = hmin(ipond)
c
        do 680 i = 1, 10 * ndiv(ipond)
          if (hset(i,ipond).ge.h(ipond)) hset(i,ipond) = h(ipond)
  680   continue
c
      else
c
        h(ipond) = hmin(ipond)
        hmax(ipond) = hmin(ipond)
      end if
c
      return
c
c1000 format ('ELEMENT = ',i3,' RUNOFF = ',f10.4,' IPOND = ',i3,
c     1    ' TOC = ',f10.4)
 1000 format (5(f12.6,','))
 1100 format (6x,'ROUTING runoff through impoundment ',i2)
      end


Block Data pydata
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Save /pysubs/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Save /pyint2/
  Common /pyint3/xsfx(2, -40:40), isig(1000, 3), sigh(1000)
  Save /pyint3/
  Common /pyint4/widp(21:40, 0:40), wide(21:40, 0:40), wids(21:40, 3)
  Save /pyint4/
  Common /pyint5/ngen(0:200, 3), xsec(0:200, 3)
  Save /pyint5/
  Common /pyint6/proc(0:200)
  Character proc*28
  Save /pyint6/
  Data msel/1/
  Data msub/200*0/
  Data ((kfin(i,j),j=-40,40), i=1, 2)/40*1, 0, 80*1, 0, 40*1/
  Data ckin/2.0, -1.0, 0.0, -1.0, 1.0, 1.0, -10., 10., -10., 10., -10., 10., -10., 10., -10., 10., -1.0, 1.0, -1.0, 1.0, 0.0, 1.0, 0.0, 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 2.0, -1.0, 0., 0., 0., 0., 0., 0., 0., 0., 160*0./
  Data (mstp(i), i=1, 100)/3, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 0, 0, 0, 2, 0, 0, 0, 0, 1, 0, 3, 7, 1, 0, 0, 0, 0, 0, 1, 1, 20, 6, 0, 0, 0, 0, 0, 0, 1, 2, 2, 2, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 100, 0, 0, 0, 0, 0, 0, 0, 1, 4, 0, 0, 0, 0, 0, 0, 0, 0/
  Data (mstp(i), i=101, 200)/1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 1, 1, 20, 0, 0, 0, 0, 0, 4, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 3, 1989, 11, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
  Data (parp(i), i=1, 100)/0.25, 10., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 1.5, 2.0, 0.075, 0., 0.2, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 1.0, 2.26, 1.E4, 1.E-4, 0., 0., 0., 0., 0., 0., 0.25, 1.0, 0.25, 1.0, 2.0, 1.E-3, 4.0, 0., 0., 0., 4.0, 0., 0., 0., 0., 0., 0., 0., 0., 0., 1.6, 1.85, 0.5, 0.2, 0.33, 0.66, 0.7, 0.5, 0., 0., 0.44, 0.44, 2.0, 1.0, 0., 3.0, 1.0, 0.75, 0., 0./
  Data (parp(i), i=101, 200)/ -0.02, 0., 0., 0., 0., 0., 0., 0., 0., 0., 2.0, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.4, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.01, 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./
  Data msti/200*0/
  Data pari/200*0./
  Data mint/400*0/
  Data vint/400*0./
  Data (iset(i), i=1, 100)/1, 1, 1, -1, 3, -1, -1, 3, -2, -2, 2, 2, 2, 2, 2, 2, -1, 2, 2, 2, -1, 2, 2, 2, 2, 2, -1, 2, 2, 2, 2, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2, -1, -1, 4, 4, 4, -1, -1, 4, 4, -1, -1, -2, 2, 2, -2, -2, -2, -2, -2, -2, -2, -2, 0, 0, 0, -1, 0, 5, -2, -2, -2, -2/
  Data (iset(i), i=101, 200)/ -1, 1, -2, -2, -2, -2, -2, -2, -2, -2, 2, 2, 2, 2, -1, -1, -1, -2, -2, -2, -1, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, 1, 1, 1, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, 2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
  Data ((kfpr(i,j),j=1,2), i=1, 50)/23, 0, 24, 0, 25, 0, 24, 0, 25, 0, 24, 0, 23, 0, 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 22, 21, 23, 21, 24, 21, 25, 22, 22, 22, 23, 22, 24, 22, 25, 23, 23, 23, 24, 23, 25, 24, 24, 24, 25, 25, 25, 0, 21, 0, 22, 0, 23, 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
  Data ((kfpr(i,j),j=1,2), i=51, 100)/0, 24, 0, 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 24, 24, 22, 24, 23, 23, 24, 24, 23, 24, 23, 25, 22, 22, 23, 23, 24, 24, 24, 25, 25, 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
  Data ((kfpr(i,j),j=1,2), i=101, 150)/23, 0, 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 25, 0, 25, 21, 25, 22, 22, 22, 23, 23, 23, 24, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, 37, 0, 40, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
  Data ((kfpr(i,j),j=1,2), i=151, 200)/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 37, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
  Data coef/4000*0./
  Data (((icol(i,j,k),k=1,2),j=1,4), i=1, 40)/4, 0, 3, 0, 2, 0, 1, 0, 3, 0, 4, 0, 1, 0, 2, 0, 2, 0, 0, 1, 4, 0, 0, 3, 3, 0, 0, 4, 1, 0, 0, 2, 3, 0, 0, 4, 1, 4, 3, 2, 4, 0, 0, 3, 4, 2, 1, 3, 2, 0, 4, 1, 4, 0, 2, 3, 4, 0, 3, 4, 2, 0, 1, 2, 3, 2, 1, 0, 1, 4, 3, 0, 4, 3, 3, 0, 2, 1, 1, 0, 3, 2, 1, 4, 1, 0, 0, 2, 2, 4, 3, 1, 2, 0, 0, 1, 3, 2, 1, 4, 1, 4, 3, 2, 4, 2, 1, 3, 4, 2, 1, 3, 3, 4, 4, 3, 1, 2, 2, 1, 2, 0, 3, 1, 2, 0, 0, 0, 4, 2, 1, 0, 0, 0, 1, 0, 3, 0, 0, 3, 1, 2, 0, 0, 4, 0, 0, 4, 0, 0, 1, 2, 2, 0, 0, 1, 4, 4, 3, 3, 2, 2, 1, 1, 4, 4, 3, 3, 3, 3, 4, 4, 1, 1, 2, 2, 3, 2, 1, 3, 1, 2, 0, 0, 4, 2, 1, 4, 0, 0, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
  Data proc(0)/'All included subprocesses   '/
  Data (proc(i), i=1, 20)/'f + fb -> gamma*/Z0         ', 'f + fb'' -> W+/-             ', 'f + fb -> H0                ', 'gamma + W+/- -> W+/-        ', 'Z0 + Z0 -> H0               ', 'Z0 + W+/- -> W+/-           ', '                            ', 'W+ + W- -> H0               ', '                            ', '                            ', 'f + f'' -> f + f''            ', 'f + fb -> f'' + fb''          ', 'f + fb -> g + g             ', 'f + fb -> g + gamma         ', 'f + fb -> g + Z0            ', 'f + fb'' -> g + W+/-         ', 'f + fb -> g + H0            ', 'f + fb -> gamma + gamma     ', 'f + fb -> gamma + Z0        ', 'f + fb'' -> gamma + W+/-     '/
  Data (proc(i), i=21, 40)/'f + fb -> gamma + H0        ', 'f + fb -> Z0 + Z0           ', 'f + fb'' -> Z0 + W+/-        ', 'f + fb -> Z0 + H0           ', 'f + fb -> W+ + W-           ', 'f + fb'' -> W+/- + H0        ', 'f + fb -> H0 + H0           ', 'f + g -> f + g              ', 'f + g -> f + gamma          ', 'f + g -> f + Z0             ', 'f + g -> f'' + W+/-          ', 'f + g -> f + H0             ', 'f + gamma -> f + g          ', 'f + gamma -> f + gamma      ', 'f + gamma -> f + Z0         ', 'f + gamma -> f'' + W+/-      ', 'f + gamma -> f + H0         ', 'f + Z0 -> f + g             ', 'f + Z0 -> f + gamma         ', 'f + Z0 -> f + Z0            '/
  Data (proc(i), i=41, 60)/'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + H0            ', 'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ', 'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ', 'f + W+/- -> f'' + H0         ', 'f + H0 -> f + g             ', 'f + H0 -> f + gamma         ', 'f + H0 -> f + Z0            ', 'f + H0 -> f'' + W+/-         ', 'f + H0 -> f + H0            ', 'g + g -> f + fb             ', 'g + gamma -> f + fb         ', 'g + Z0 -> f + fb            ', 'g + W+/- -> f + fb''         ', 'g + H0 -> f + fb            ', 'gamma + gamma -> f + fb     ', 'gamma + Z0 -> f + fb        ', 'gamma + W+/- -> f + fb''     '/
  Data (proc(i), i=61, 80)/'gamma + H0 -> f + fb        ', 'Z0 + Z0 -> f + fb           ', 'Z0 + W+/- -> f + fb''        ', 'Z0 + H0 -> f + fb           ', 'W+ + W- -> f + fb           ', 'W+/- + H0 -> f + fb''        ', 'H0 + H0 -> f + fb           ', 'g + g -> g + g              ', 'gamma + gamma -> W+ + W-    ', 'gamma + W+/- -> gamma + W+/-', 'Z0 + Z0 -> Z0 + Z0          ', 'Z0 + Z0 -> W+ + W-          ', 'Z0 + W+/- -> Z0 + W+/-      ', 'Z0 + Z0 -> Z0 + H0          ', 'W+ + W- -> gamma + gamma    ', 'W+ + W- -> Z0 + Z0          ', 'W+/- + W+/- -> W+/- + W+/-  ', 'W+/- + H0 -> W+/- + H0      ', 'H0 + H0 -> H0 + H0          ', '                            '/
  Data (proc(i), i=81, 100)/'q + qb -> Q + QB, massive   ', 'g + g -> Q + QB, massive    ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', 'Elastic scattering          ', 'Single diffractive          ', 'Double diffractive          ', 'Central diffractive         ', 'Low-pT scattering           ', 'Semihard QCD 2 -> 2         ', '                            ', '                            ', '                            ', '                            '/
  Data (proc(i), i=101, 120)/'g + g -> gamma*/Z0          ', 'g + g -> H0                 ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', 'f + fb -> g + H0            ', 'q + g -> q + H0             ', 'g + g -> g + H0             ', 'g + g -> gamma + gamma      ', 'g + g -> gamma + Z0         ', 'g + g -> Z0 + Z0            ', 'g + g -> W+ + W-            ', '                            ', '                            ', '                            '/
  Data (proc(i), i=121, 140)/'g + g -> f + fb + H0        ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            '/
  Data (proc(i), i=141, 160)/'f + fb -> gamma*/Z0/Z''0     ', 'f + fb'' -> H+/-             ', 'f + fb -> R                 ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            '/
  Data (proc(i), i=161, 180)/'f + g -> f'' + H+/-          ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            ', '                            '/
  Data (proc(i), i=181, 200)/20*'                            '/
End Block Data pydata


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine sumcar

      implicit none
      include 'plot1.inc'
      include 'plot2.inc'
      include 'plot3.inc'

c ... Sum unlabeled and labeled carbon to get totals.

      strucc(1)=strcis(1,1)+strcis(1,2)
      strucc(2)=strcis(2,1)+strcis(2,2)
      metabc(1)=metcis(1,1)+metcis(1,2)
      metabc(2)=metcis(2,1)+metcis(2,2)

c ... Sum som1 surface and soil isotopes separately.  vek 08-91
      som1c(1)=som1ci(1,1)+som1ci(1,2)
      som1c(2)=som1ci(2,1)+som1ci(2,2)
      som2c(1)=som2ci(1,1)+som2ci(1,2)
      som2c(2)=som2ci(2,1)+som2ci(2,2)
      som3c=som3ci(1)+som3ci(2)

      wood1c = wd1cis(1) + wd1cis(2)
      wood2c = wd2cis(1) + wd2cis(2)
      wood3c = wd3cis(1) + wd3cis(2)

      somtc=som1c(2) + som2c(2) + som3c + strucc(2) + metabc(2)
      aglivc=aglcis(1)+aglcis(2)
      stdedc=stdcis(1)+stdcis(2)
      bglivcj=bglcisj(1)+bglcisj(2)
      bglivcm=bglcism(1)+bglcism(2)
      agcacc=agcisa(1)+agcisa(2)
      bgcjacc=bgcisja(1)+bgcisja(2)
      bgcmacc=bgcisma(1)+bgcisma(2)

      rleavc = rlvcis(1) + rlvcis(2)
      frootcj = frtcisj(1) + frtcisj(2)
      frootcm = frtcism(1) + frtcism(2)
      fbrchc = fbrcis(1) + fbrcis(2)
      rlwodc = rlwcis(1) + rlwcis(2)
      crootc = crtcis(1) + crtcis(2)

      rlvacc = alvcis(1) + alvcis(2)
      frtjacc = afrcisj(1) + afrcisj(2)
      frtmacc = afrcism(1) + afrcism(2)
      fbracc = afbcis(1) + afbcis(2)
      rlwacc = alwcis(1) + alwcis(2)
      crtacc = acrcis(1) + acrcis(2)
      fcacc  = rlvacc + frtjacc + frtmacc + fbracc + rlwacc + crtacc

      return
      end


!***********************************************************************
!                                                                      *
      SUBROUTINE SCFmpi(EOL, RWFFILE2)
!                                                                      *
!   This  subroutine  performs  the SCF iterations. The procedure is   *
!   essentially algorithm 5.1 of C Froese Fischer, Comput Phys Rep 3   *
!   (1986) 290.                                                        *
!                                                                      *
!   Call(s) to: [LIB92]: ALLOC, DALLOC.                                *
!               [RSCF92]: improvmpi, matrixmpi, MAXARR, newcompi,      *
!                         ORBOUT, ORTHSC, setlagMpi.                   *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 22 Dec 1992   *
!   MPI version by Xinghong He            Last revision: 05 Aug 1998   *
!   ifort -i8 version by Alexander Kramida (AK) Last rev. 22 Mar 2016  *
!   Midified by G. Gaigalas                              05 Feb 2017   *
!      It was deleted the arrays:  JQSA(3*NNNWP*NCF),                  *
!                                  JCUPA(NNNWP*NCF)                    *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:16:00   1/ 5/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE memory_man
      USE blkidx_C
      USE default_C
      USE def_C
      USE debug_C
      USE eigv_C
      USE fixd_C
      USE hblock_C
      USE iounit_C
      USE lagr_C
      USE MCPA_C
      USE mpi_C
      USE pos_c
      USE peav_C
      USE ORB_C
      USE orba_C
      USE SCF_C
      USE SYMA_C
      USE STAT_C
      USE ORTHCT_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE matrixmpi_I
      USE newcompi_I
      USE setlagmpi_I
      USE improvmpi_I
      USE maxarr_I
      USE prwf_I
      USE orthsc_I
      USE orbout_I
      USE endsum_I
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      LOGICAL  :: EOL
      CHARACTER  :: RWFFILE2*(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J, I, NIT, JSEQ, KOUNT, K, L_MPI
      REAL(DOUBLE) :: WTAEV, WTAEV0, DAMPMX
      LOGICAL :: CONVG, LSORT, dvdfirst
!-----------------------------------------------
!CFF   .. set the logical variable dvdfirst
      dvdfirst = .true.
!-----------------------------------------------------------------------
!AK Handling the -i8 option of ifort and -fdefault-integer-8 option of gfortran
!      ISIZE = sizeof(NCF)
      L_MPI = MPI_LOGICAL
!      if (ISIZE.EQ.8) L_MPI = MPI_LOGICAL8

      NCFTOT = NCF
      !IF (myid .EQ. 0) PRINT *, '===SCF==='

!=======================================================================
!   Determine Orthonomalization order --- lsort
!=======================================================================

      IF (NDEF == 0) THEN
         LSORT = .FALSE.
      ELSE
         IF (myid .EQ. 0) THEN
  123       CONTINUE
            WRITE (ISTDE, *) 'Orthonomalization order? '
            WRITE (ISTDE, *) '     1 -- Update order'
            WRITE (ISTDE, *) '     2 -- Self consistency connected'
            READ (ISTDI, *) J
            IF (J == 1) THEN
               LSORT = .FALSE.
            ELSE IF (J == 2) THEN
               LSORT = .TRUE.
            ELSE
               WRITE (ISTDE, *) 'Input is wrong, redo...'
               GO TO 123
            ENDIF
         ENDIF
         CALL MPI_Bcast (lsort, 1, L_MPI, 0, MPI_COMM_WORLD, ierr)
      ENDIF

!=======================================================================
!   Deallocate storage that will no longer be used
!=======================================================================

!GG      CALL DALLOC (JQSA, 'JQSA', 'SCFmpi')

!=======================================================================
!   Allocate and fill in auxiliary arrays
!=======================================================================

      CALL ALLOC (NCFPAST, NBLOCK, 'NCFPAST', 'SCFmpi')
      CALL ALLOC (NCMINPAST, NBLOCK, 'NCMINPAST', 'SCFmpi')
      CALL ALLOC (NEVECPAST, NBLOCK, 'NEVECPAST', 'SCFmpi')
      CALL ALLOC (EAVBLK, NBLOCK, 'EAVBLK', 'SCFmpi')

      NCFPAST(1) = 0
      NCMINPAST(1) = 0
      NEVECPAST(1) = 0
      DO I = 2, NBLOCK
         NCFPAST(I) = NCFPAST(I-1) + NCFBLK(I - 1)
         NCMINPAST(I) = NCMINPAST(I-1) + NEVBLK(I - 1)
         NEVECPAST(I) = NEVECPAST(I-1) + NEVBLK(I - 1)*NCFBLK(I - 1)
      END DO

      !*** Size of the eigenvector array for all blocks
      NVECSIZ = NEVECPAST(NBLOCK) + NEVBLK(NBLOCK)*NCFBLK(NBLOCK)

      IF (EOL) THEN
         CALL ALLOC (EVAL, NCMIN, 'EVAL', 'SCFmpi')
         CALL ALLOC (EVEC, NVECSIZ, 'EVEC', 'SCFmpi')
         CALL ALLOC (IATJPO, NCMIN, 'IATJPO', 'SCFmpi')
         CALL ALLOC (IASPAR, NCMIN, 'IASPAR', 'SCFmpi')
      ENDIF

!=======================================================================
!
!=======================================================================
      NDDIM = 64
      NXDIM = 64
      NYDIM = 64
!      NDDIM = 0
!      NYDIM = 0
!      NYDIM = 0
!AK    Must initialize DA,XA,YA,... here since MPI routines rely on their existence in all processes
      CALL ALLOC (NDA, NDDIM, 'NDA','SCFmpi')
      CALL ALLOC (DA, NDDIM, 'DA','SCFmpi')
      CALL ALLOC (NXA, NXDIM, 'NXA','SCFmpi')
      CALL ALLOC (XA, NXDIM, 'XA','SCFmpi')
      CALL ALLOC (NYA, NYDIM, 'NYA','SCFmpi')
      CALL ALLOC (YA, NYDIM, 'YA','SCFmpi')

!     This call should only be made AFTER the call to newco
!     CALL setlag (EOL)

!   For (E)OL calculations, determine the level energies and
!   mixing coefficients

!CFF   .. set the logical variable dvdfirst
      IF (EOL) THEN
         CALL MATRIXmpi (dvdfirst)
         CALL NEWCOmpi (WTAEV)
      ENDIF
      WTAEV0 = 0.0
      dvdfirst = .false.
      DO NIT = 1, NSCF
         IF (MYID == 0) WRITE (*, 301) NIT

!   For all pairs constrained through a Lagrange multiplier, compute
!   the Lagrange multiplier

         CALL SETLAGmpi (EOL)

!   Improve all orbitals in turn

         DAMPMX = 0.0
         IF (MYID == 0) WRITE (*, 302)
         DO J = 1, NW
            JSEQ = IORDER(J)
            IF (LFIX(JSEQ)) CYCLE
            CALL IMPROVmpi (EOL, JSEQ, LSORT, DAMPMX)
         END DO
!
!   For KOUNT = 1 to NSIC: find the least self-consistent orbital;
!   improve it
!
!         write(istde,*) 'nsic=',nsic
         DO KOUNT = 1, NSIC
            CALL MAXARR (K)
            IF (K == 0) THEN
               CONVG = .TRUE.
               GO TO 3
            ELSE
               IF (SCNSTY(K) <= ACCY) THEN
                  CONVG = .TRUE.
                  GO TO 3
               ENDIF
            ENDIF
            CALL IMPROVmpi (EOL, K, LSORT, DAMPMX)
         END DO

         CALL MAXARR (K)

         IF (K == 0) THEN
            CONVG = .TRUE.
         ELSE
            IF (SCNSTY(K) <= ACCY) THEN
               CONVG = .TRUE.
            ELSE
               CONVG = .FALSE.
            ENDIF
         ENDIF

    3    CONTINUE
         IF (LDBPR(24) .AND. MYID==0) CALL PRWF (0)

!   Perform Gram-Schmidt process
!   For OL calculation, orthst is true and orbitals are orthonormalized
!   in subroutine improv. For AL calculation, orthst is false.
         IF (.NOT.ORTHST) CALL ORTHSC

!   Write the subshell radial wavefunctions to the .rwf file

         IF (MYID == 0) CALL ORBOUT (RWFFILE2)

         IF (EOL) THEN
            CALL MATRIXmpi(dvdfirst)
            CALL NEWCOmpi (WTAEV)
         ENDIF
!        Make this a relative convergence test
!        IF(ABS(WTAEV-WTAEV0).LT.1.0D-9.and.
!    &   DAMPMX.LT.1.0D-4) CONVG=.true.
!        PRINT *, 'WTAEV, WTAEV0', WTAEV, WTAEV0,
!    &             ABS((WTAEV-WTAEV0)/WTAEV)
!GG         IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE.
!cjb unified convergence criteria in RMCDHF and RMCDHF_MPI
!cjb     IF(DABS(WTAEV-WTAEV0).LT.1.0D-8.and.              &
!cjb                   DAMPMX.LT.1.0D-2) CONVG=.true.
         IF (ABS((WTAEV - WTAEV0)/WTAEV) < 0.001*ACCY) CONVG = .TRUE.
         WTAEV0 = WTAEV
         IF (.NOT.CONVG) CYCLE
         IF (LDBPR(25) .AND. .NOT.LDBPR(24) .AND. MYID==0) CALL PRWF (0)
            !IF (EOL) CALL matrixmpi (dvdfirst)
         GO TO 5

      END DO

      IF (MYID==0) WRITE (ISTDE,*)' Maximum iterations in SCF Exceeded.'

    5 CONTINUE
      DO I = 31, 32 + KMAXF
         CLOSE(I)                                ! The MCP coefficient files
      END DO

      IF (MYID == 0) THEN
         !CLOSE (23)     ! The .rwf file
         CLOSE(25)                               ! The .mix file
      ENDIF
!
!   Complete the summary - moved from rscf92 for easier alloc/dalloc
!
      IF (myid .EQ. 0) CALL ENDSUM
!
!   Deallocate storage
!
      CALL DALLOC (WT, 'WT', 'SCFmpi')                       !Either getold or getald

      IF (NEC > 0) THEN
         CALL DALLOC (IECC, 'IECC', 'SCFmpi')
         CALL DALLOC (ECV, 'ECV', 'SCFmpi')
         CALL DALLOC (IQA, 'IQA', 'SCFmpi')
      ENDIF

      IF (NDDIM > 0) THEN
         CALL DALLOC (DA, 'DA', 'SCFmpi')
         CALL DALLOC (NDA, 'NDA', 'SCFmpi')
         NDDIM = 0
      ENDIF

      IF (NXDIM > 0) THEN
         CALL DALLOC (XA, 'XA', 'SCFmpi')
         CALL DALLOC (NXA, 'NXA', 'SCFmpi')
         NXDIM = 0
      ENDIF

      IF (NYDIM > 0) THEN
         CALL DALLOC (YA, 'YA', 'SCFmpi')
         CALL DALLOC (NYA, 'NYA', 'SCFmpi')
         NYDIM = 0
      ENDIF

      IF (EOL) THEN
         CALL DALLOC (EVAL, 'EVAL', 'SCFmpi')
         CALL DALLOC (EVEC, 'EvEC', 'SCFmpi')
         CALL DALLOC (IATJPO, 'IATJPO', 'SCFmpi')
         CALL DALLOC (IASPAR, 'IASPAR', 'SCFmpi')
         CALL DALLOC (NCMAXBLK, 'NCMAXBLK', 'SCFmpi') ! getold.f
         CALL DALLOC (EAVBLK, 'EAVBLK', 'SCFmpi')     ! getold.f
         CALL DALLOC (IDXBLK, 'IDXBLK', 'SCFmpi')     ! Allocated in getold.f
         CALL DALLOC (ICCMIN, 'ICCMIN', 'SCFmpi')       ! Allocated in items.f<-getold.f
      ENDIF
!
      CALL DALLOC (NCFPAST, 'NCFPAST', 'SCFmpi')
      CALL DALLOC (NCMINPAST, 'NCMINPAST', 'SCFmpi')
      CALL DALLOC (NEVECPAST, 'NEVECPAST', 'SCFmpi')

  301 FORMAT(/,' Iteration number ',1I3,/,' --------------------')
  302 FORMAT(41X,'Self-            Damping'/,&
         'Subshell    Energy    Method   P0    ',&
         'consistency  Norm-1  factor  JP',' MTP INV NNP'/)

      RETURN
      END SUBROUTINE SCFmpi


        SUBROUTINE  MA_TESA  ( marrpt, iend, ipt, iret )
C************************************************************************
C* MA_TESA                                                              *
C*                                                                      *
C* This subroutine decodes the groups zzzz, TTTT, and SSSS following    *
C* the 8887k group in section 3 of the drifting buoy report.  These     *
C* groups contain temperature (TTTT) and salinity (SSSS) data at        *
C* selected or significant depths (zzzz).  The method of salinity/depth *
C* measurement is given by the k value in the 8887k group.              *
C*                                                                      *
C* MA_TESA ( MARRPT, IEND, IPT, IRET )                                  *
C*                                                                      *
C* Input parameters:                                                    *
C*      MARRPT 		CHAR*    	Report array                    *
C*      IEND            INTEGER         Points to the position in       *
C*                                      marrpt of the last section 3    *
C*                                      character                       *
C*					                                *
C* Input and Output parameters:                                         *
C*      IPT             INTEGER         On input, points to the         *
C*					position in marrpt of k in the  *
C*					group 8887k; on output, points  *
C*					to the position in marrpt of the*
C*                                      last section 3 character or the *
C*                                      position in marrpt of the second*
C*                                      6 in the group 66k(6)9k(3)      *
C*                                                                      *
C* Output parameters:                                                   *
C*	RIVALS(IRMSDM)	REAL		Method of measurement           *
C*	RIVALS(IRNDTS)	REAL		Number of levels of data        *
C*	RIVALS(IRDBSS)	REAL		Depth in meters                 *
C*	RIVALS(IRSTMP)	REAL		Temperature, hundredths degr C  *
C*	RIVALS(IRSALN)	REAL		Salinity, 1/100ths ppt          *
C*      IRET            INTEGER         Return code                     *
C*                                        0 = No problems               *
C*                                        1 = Problems                  *
C*                                                                      *
C**								        *
C* Log:							                *
C* R. Hollern/NCEP      8/96                                            *
C* R. Hollern/NCEP     11/96    Added call to PR_TMCK                   *
C* R. Hollern/NCEP     12/96    Replaced ST_C2R with ST_INTG            *
C* D. Kidwell/NCEP  	4/97	Removed interface calls, reorganized    *
C*				header and comments                     *
C* D. Kidwell/NCEP     10/97	Changed interface, removed PR_TMCK      *
C* D. Kidwell/NCEP      3/02	Corrected prologue                      *
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
        INCLUDE  	'macmn.cmn'
C*
        CHARACTER*(*)  	 marrpt
C*
        CHARACTER     	 fld4*4, fld1*1
C------------------------------------------------------------------------
        iret = 0
        iptsav = 0
C
C*      Get the method of salinity/depth measurement
C*      (WMO Code Table 2263).
C
        IF ( marrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = marrpt ( ipt:ipt )
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) rivals ( irmsdm ) = FLOAT ( ival )
        END IF
C
        lvl = 0
C
        DO WHILE ( ipt .lt. iend )
C
            ipt = ipt + 1
C
            IF ( marrpt ( ipt:ipt+1 ) .eq. ' 2' ) THEN
C
                lvl = lvl + 1
		IF ( lvl .gt. MXDLYR ) lvl = MXDLYR
C
C*              Get selected and/or significant depths, in meters,
C*              starting with the surface.
C
                ipt = ipt + 2
                fld4 = marrpt ( ipt:ipt+3 )
                CALL  ST_INTG ( fld4, ival, ier )
                IF ( ier .eq. 0 )
     +               rivals ( irdbss ( lvl ) ) = FLOAT ( ival )
                ipt = ipt + 3
              ELSE IF ( marrpt ( ipt:ipt+1 ) .eq. ' 3' ) THEN
C
C*              Get temperatures, in hundredths of a degree Celsius.
C
                ipt = ipt + 2
                fld4 = marrpt ( ipt:ipt+3 )
                CALL  ST_INTG ( fld4, ival, ier )
                IF ( ier .eq. 0 ) THEN
                    rval = FLOAT ( ival )
C
C*                  Check for negative temperature.
C
                    IF ( rval .gt. 4999. ) rval = 5000. - rval
                    rivals ( irstmp ( lvl ) ) = .01 * rval
                END IF
                ipt = ipt + 3
              ELSE IF ( marrpt ( ipt:ipt+1 ) .eq. ' 4' ) THEN
C
C*              Get salinity, in hundredths of a part per thousand (%).
C
                ipt = ipt + 2
                fld4 = marrpt ( ipt:ipt+3 )
                CALL  ST_INTG ( fld4, ival, ier )
                IF ( ier .eq. 0 )
     +               rivals ( irsaln ( lvl ) ) = .01 * FLOAT ( ival )
                ipt = ipt + 3
              ELSE IF ( marrpt ( ipt:ipt+2 ) .eq. ' 66' ) THEN
                iptsav = ipt - 1
                ipt = iend
            END IF
        END DO
C
        IF ( iptsav .ne. 0 ) ipt = iptsav
	IF ( lvl .gt. 0 ) rivals ( irndts ) = FLOAT ( lvl )
C*
        RETURN
        END


!==============================================================================!
  subroutine Initialize_Variables(grid)
!------------------------------------------------------------------------------!
!   Initialize dependent variables.                                            !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use par_mod
  use rans_mod
  use Grid_Mod
  use Bulk_Mod
  use Parameters_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!----------------------------------[Calling]-----------------------------------!
  real    :: Stot
!-----------------------------------[Locals]-----------------------------------!
  integer :: c, c1, c2, m, s, n
  integer :: n_wall, n_inflow, n_outflow, n_symmetry, n_heated_wall, n_convect
!==============================================================================!

  Area  = 0.0
  write(*,*) 'grid % n_materials: ', grid % n_materials
  do n = 1, grid % n_materials
    do c = 1, grid % n_cells
      U % n(c)    = U % init(material(c))
      U % o(c)    = U % init(material(c))
      U % oo(c)   = U % init(material(c))
      V % n(c)    = V % init(material(c))
      V % o(c)    = V % init(material(c))
      V % oo(c)   = V % init(material(c))
      W % n(c)    = W % init(material(c))
      W % o(c)    = W % init(material(c))
      W % oo(c)   = W % init(material(c))
      if(HOT==YES) then
        T % n(c)  = T % init(material(c))
        T % o(c)  = T % init(material(c))
        T % oo(c) = T % init(material(c))
      end if
      if(SIMULA==EBM.or.SIMULA==HJ) then
        uu % n(c)  = uu % init(material(c))
        vv % n(c)  = vv % init(material(c))
        ww % n(c)  = ww % init(material(c))
        uv % n(c)  = uv % init(material(c))
        uw % n(c)  = uw % init(material(c))
        vw % n(c)  = vw % init(material(c))
        Eps % n(c) = Eps % init(material(c))
        if(SIMULA==EBM) f22 % n(c) = f22 % init(material(c))
      end if
      if(SIMULA==K_EPS.or.SIMULA==HYB_PITM) then
        Kin % n(c)  = Kin % init(material(c))
        Kin % o(c)  = Kin % init(material(c))
        Kin % oo(c) = Kin % init(material(c))
        Eps % n(c)  = Eps % init(material(c))
        Eps % o(c)  = Eps % init(material(c))
        Eps % oo(c) = Eps % init(material(c))
        Uf(c)       = 0.047
        Ynd(c)      = 30.0
      end if
      if(SIMULA==K_EPS_VV.or.SIMULA==ZETA.or.SIMULA==HYB_ZETA) then
        Kin % n(c)  = Kin % init(material(c))
        Kin % o(c)  = Kin % init(material(c))
        Kin % oo(c) = Kin % init(material(c))
        Eps % n(c)  = Eps % init(material(c))
        Eps % o(c)  = Eps % init(material(c))
        Eps % oo(c) = Eps % init(material(c))
        f22 % n(c)  = f22 % init(material(c))
        f22 % o(c)  = f22 % init(material(c))
        f22 % oo(c) = f22 % init(material(c))
        v_2 % n(c)  = v_2 % init(material(c))
        v_2 % o(c)  = v_2 % init(material(c))
        v_2 % oo(c) = v_2 % init(material(c))
        Uf(c)       = 0.047
        Ynd(c)      = 30.0
      end if
      if(SIMULA == SPA_ALL .or. SIMULA==DES_SPA) then
        VIS % n(c)  = VIS % init(material(c))
        VIS % o(c)  = VIS % init(material(c))
        VIS % oo(c) = VIS % init(material(c))
      end if
      if(SIMULA==HYB_ZETA.or.SIMULA==DES_SPA.or.&
      SIMULA==DNS.or.SIMULA==HYB_PITM.or.URANS==YES) then
        U % mean(c) = 0.0
        V % mean(c) = 0.0
        W % mean(c) = 0.0
      end if
    end do
  end do   !end do n=1,grid % n_materials

  if(TGV == YES) then
    do c = 1, grid % n_cells
      U % n(c)  = -sin(grid % xc(c))*cos(grid % yc(c))
      U % o(c)  = -sin(grid % xc(c))*cos(grid % yc(c))
      U % oo(c) = -sin(grid % xc(c))*cos(grid % yc(c))
      V % n(c)  =  cos(grid % xc(c))*sin(grid % yc(c))
      V % o(c)  =  cos(grid % xc(c))*sin(grid % yc(c))
      V % oo(c) =  cos(grid % xc(c))*sin(grid % yc(c))
      W % n(c)  = 0.0
      W % o(c)  = 0.0
      W % oo(c) = 0.0
      P % n(c)  = 0.25*(cos(2*grid % xc(c)) + cos(2*grid % yc(c)))
    end do
  end if

  !---------------------------------!
  !      Calculate the inflow       !
  !   and initializes the Flux(s)   !
  !   at both inflow and outflow    !
  !---------------------------------!
  n_wall        = 0
  n_inflow      = 0
  n_outflow     = 0
  n_symmetry    = 0
  n_heated_wall = 0
  n_convect     = 0
  do m = 1, grid % n_materials
    bulk(m) % mass_in = 0.0
    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      if(c2  < 0) then
        Flux(s) = DEnc(material(c1))*( U % n(c2) * grid % sx(s) + &
                                       V % n(c2) * grid % sy(s) + &
                                       W % n(c2) * grid % sz(s) )

        if(TypeBC(c2)  ==  InFLOW) then
          if(material(c1) == m) bulk(m) % mass_in = bulk(m) % mass_in - Flux(s)
          Stot  = sqrt(  grid % sx(s)**2  &
                       + grid % sy(s)**2  &
                       + grid % sz(s)**2)
          Area  = Area  + Stot
        endif
        if(TypeBC(c2)  ==  WALL)     n_wall        = n_wall        + 1
        if(TypeBC(c2)  ==  INFLOW)   n_inflow      = n_inflow      + 1
        if(TypeBC(c2)  ==  OUTFLOW)  n_outflow     = n_outflow     + 1
        if(TypeBC(c2)  ==  SYMMETRY) n_symmetry    = n_symmetry    + 1
        if(TypeBC(c2)  ==  WALLFL)   n_heated_wall = n_heated_wall + 1
        if(TypeBC(c2)  ==  CONVECT)  n_convect     = n_convect     + 1
      else
        Flux(s) = 0.0
      end if
    end do
    call iglsum(n_wall)
    call iglsum(n_inflow)
    call iglsum(n_outflow)
    call iglsum(n_symmetry)
    call iglsum(n_heated_wall)
    call iglsum(n_convect)
    call glosum(bulk(m) % mass_in)
    call glosum(Area)
  end do

  !----------------------!
  !   Initializes time   !
  !----------------------!
  Time   = 0.0
  if(this_proc  < 2) then
    write(*,*) '# MassIn=', bulk(1) % mass_in
    write(*,*) '# Average inflow velocity =', bulk(1) % mass_in / Area
    write(*,*) '# number of faces on the wall        : ', n_wall
    write(*,*) '# number of inflow faces             : ', n_inflow
    write(*,*) '# number of outflow faces            : ', n_outflow
    write(*,*) '# number of symetry faces            : ', n_symmetry
    write(*,*) '# number of faces on the heated wall : ', n_heated_wall
    write(*,*) '# number of convective outflow faces : ', n_convect
    write(*,*) '# Variables initialized !'
  end if

  end subroutine


module defaults_mod

! ==============================================================================
!
! This module file was created by CMJ, XCP-3 (8/17) with the intent to allow
! developers of GSM to more easily update GSM, to
! control what statements are printed to terminal (verbosity), and to aid in the
! management of several variables used within multiple source code files.  Such
! things include counting statistics in the CEM fashion or LAQGSM fashion,
! tallying the projectile information, using the CEM/LAQGSM RNG, etc.
!
!
! Created by CMJ, 8-25-17, XCP-3
! Modified by CMJ, 09-XX-17, XCP-3
! Modified by CMJ, 10-XX-17, XCP-3
!
! ==============================================================================

! Ensure all variables are private and declared unless otherwise noted
  use, intrinsic:: iso_fortran_env, only: int32
  implicit none
  private

! ------------------------------------------------------------------------------
! General Numbers (private)
! ------------------------------------------------------------------------------
  integer(int32), private, parameter :: zro  = 0.d0
  integer(int32), private, parameter :: one  = 1.d0
  integer(int32), private, parameter :: two  = 2.d0
  integer(int32), private, parameter :: three= 3.d0
  integer(int32), private, parameter :: four = 4.d0
  integer(int32), private, parameter :: five = 5.d0
  integer(int32), private, parameter :: six  = 6.d0
  integer(int32), private, parameter :: svn  = 7.d0
  integer(int32), private, parameter :: eight= 8.d0
  integer(int32), private, parameter :: nine = 9.d0
  integer(int32), private, parameter :: ten  = 10.d0
! ------------------------------------------------------------------------------

! ------------------------------------------------------------------------------
! For use with verbose output - when messages are printed to terminal
!      NOTE: I/O time is EXPENSIVE (computationally) - use sparingly
! =0 : NO printouts (when controlled by verbosity) except for errors
! =1 : MINIMAL print out; ONLY "NC=..."
! =2 : Prints the (1) items, and Error protection statements (when transferred)
! =3 : Prints the (2) items, and also prompts variable changes, calc. comments, and error increments
! =4 : Prints the (3) items, and also ALL WARNING/ERROR statements when re-calculating and input vars
! =5 : Prints the (4) items, and also EVERY time recalculating due to Z=0 of residuals and when parz,
!      spt exceeded in LAQhelp file
! =6 : Prints the (5) items, and EVERY error checking attempt - NOT RECOMMENDED!
!      Recommended Value: =2 (as standalone), =0 or 1 (in MCNP), =2 or 3 (when develpoing)
! ------------------------------------------------------------------------------
  integer(int32), public, parameter :: verbose = two

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

! ------------------------------------------------------------------------------
! Used with the Dubna IntraNuclear Cascade Model (DCM) from LAQGSM
! ------------------------------------------------------------------------------

! ----------
! Combination of cem_statistics and casc=1 (easier for GSM to determine CEM statistic use w/ DCM)
!      Recommended Value: DOES NOT MATTER - variable changed in "gsm.f90" file
  logical, public, protected :: use_DCM = .FALSE.
! ----------

! ----------
! Used to FORCE testing of the DCM.
!      Recommend Value: .FALSE.   [Only to be used when testing DCM!]
! ----------
  logical, public, parameter :: test_DCM = .FALSE.
  logical, public, parameter :: test_CEM = .FALSE.
! ----------

! ----------
! Tallies cascade particles in "upacow" (if true), in "cascaw" otherwise
!      Recommended Value: TRUE
  logical, public, parameter :: upacowTally = .TRUE.
! ----------

! ----------
! Variable controls when the spt, parz, and sptg arrays are reset
!   i.e. when there are close to 150 particle types stored, reset prior to
!        reaching this point (saftey net)
!      Recommended Value: 140
! ----------
  integer(int32), public, parameter :: resetIndx = 145;
! ----------

! ----------
! Variable is the limit of the spt, parz, and sptg arrays.  Cannot access
! anything beyond this value
!      Recommended Value: 150 (unless spt, parz, and sptg expanded)
! ----------
  integer(int32), public, parameter :: arrayLim = 150;
! ----------

! ----------
! Variable determines if unphysical/bad residuals can be used in the calculation
!      Recommended Value: FALSE
! ----------
  logical, public, parameter :: allowBadResidual = .FALSE.
! ----------

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

! ==============================================================================
! ------------------------------------------------------------------------------
! Declaring public subroutines
! ------------------------------------------------------------------------------
  public :: set_DCM
! ------------------------------------------------------------------------------

contains

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

  subroutine set_DCM( newValue )

! ------------------------------------------------------------------------------
! This subroutine is used to set the value of use_DCM.  Routine is meant to be
! extremely simple, more of an organizational tool for the code.
! ------------------------------------------------------------------------------

    implicit none
    logical, intent(in) :: newValue

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

    use_DCM = newValue

    ! Printing to user if print desired
    if ( verbose >= 3 ) then
       if ( use_DCM ) then
          write(*,1200) "DCM will be used."
       else
          write(*,1200) "DCM will NOT be used."
       endif
    endif

    return

! --------------------------------------
1200 format (3x, "Comment: ", A)
! --------------------------------------

  end subroutine set_DCM

! ==============================================================================
end module defaults_mod


        SUBROUTINE ZXCCR2(CCR2,DET,ID,YDEF,ROWS,NFOUND,ISTAT)
*
*  Module number:
*
*  Module name: ZXCCR2
*
*  Keyphrase:
*  ----------
*       Index table CCR2 (GHRS sample mapping function coefficients)
*
*  Description:
*  ------------
*       This routine reads table CCR2 and extracts the y-deflections
*       and there row numbers for the specified detector.
*       A sorted list of y-deflections and row index is returned.
*  FORTRAN name: ZXCCR2.FOR
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       CCR2                    I       Sample mapping function coef.
*
*  Subroutines Called:
*  -------------------
*  SDAS:
*       ZMSPUT, uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       APR 89  D. Lindler      Designed and coded
*	1.1	Sep 91	S. Hulbert	Implemented dymanic memory allocation
*					for storing table
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       CCR2 - table name (character*64)
*       det - detector number (integer)
*       YDEF - pointer to vector of y-deflections (sorted)
*       ROWS - pointer to row numbers for each y-deflection
*
* Output parameters
*
*       NFOUND - number of y-deflections found
*       istat - ERROR status (integer)
*
**************************************************************************
        CHARACTER*64 CCR2
        INTEGER ISTAT,DET,NFOUND,ROWS,ID,YDEF
C------------------------------------------------------------------------------
C Get IRAF MEM common into main program.
C
      LOGICAL          MEMB(1)
      INTEGER*2        MEMS(1)
      INTEGER*4        MEMI(1)
      INTEGER*4        MEML(1)
      REAL             MEMR(1)
      DOUBLE PRECISION MEMD(1)
      COMPLEX          MEMX(1)
      EQUIVALENCE (MEMB, MEMS, MEMI, MEML, MEMR, MEMD, MEMX)
      COMMON /MEM/ MEMD
C------------------------------------------------------------------------------
      INTEGER TYINT
      PARAMETER (TYINT=4)
      INTEGER TYREAL
      PARAMETER (TYREAL=6)
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O.
C
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C     END IRAF77.INC
C
C LOCAL VARIABLES -------------------------------------------
C
        INTEGER NROWS,COLIDS(2),ROW,IDET,N
	INTEGER ISTATS(2)
        CHARACTER*80 CONTXT
        CHARACTER*15 COLNAM(2)
        LOGICAL NULL
        DATA COLNAM/'DETECTOR','YDEF'/
C
C--------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(CCR2,RDONLY,ID,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening CCR2 table '//CCR2
                GO TO 999
        ENDIF
C
C get number of rows
C
        CALL UTPGTI(ID,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading CCR2 table '//CCR2
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(ID,COLNAM,2,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in CCR2 table '//
     *                  CCR2
                GO TO 999
        ENDIF
C
C Locate rows with correct detector number
C Loop through twice, the first time is just to count the number of rows
C the second is to fill the newly allocated buffers
C
        NFOUND=0
        DO 20 ROW=1,NROWS
                CALL UTRGTI(ID,COLIDS(1),1,ROW,IDET,NULL,ISTAT)
                IF(ISTAT.NE.0)THEN
                        CONTXT='ERROR reading CCR2 table '//CCR2
                        GO TO 999
                ENDIF
                IF(DET.EQ.IDET)NFOUND=NFOUND+1
20      CONTINUE
C
C Need at least 1 row of coefficients
C
        IF(NFOUND.EQ.0)THEN
                WRITE(CONTXT,199)DET
199             FORMAT('ERROR - No rows found in CCR2 for det. ',I2)
                GO TO 999
        ENDIF
C
C allocate memory
C
        CALL UDMGET (NFOUND, TYINT, ROWS, ISTATS(1))
        CALL UDMGET (NFOUND, TYREAL, YDEF, ISTATS(2))
        IF (ISTATS(1).NE.0.OR.ISTATS(2).NE.0) THEN
            CONTXT='ERROR allocating memory'
            GO TO 999
        ENDIF
C
C fill the buffers
C
        N=0
        DO 10 ROW=1,NROWS
                CALL UTRGTI(ID,COLIDS(1),1,ROW,IDET,NULL,ISTAT)
                IF(ISTAT.NE.0)THEN
                        CONTXT='ERROR reading CCR2 table '//CCR2
                        GO TO 999
                ENDIF
                IF(DET.EQ.IDET)THEN
			N=N+1
                        MEMI(ROWS+N-1)=ROW
                        CALL UTRGTR(ID,COLIDS(2),1,ROW,
     $				MEMR(YDEF+N-1),NULL,ISTAT)
                        IF(ISTAT.NE.0)THEN
                            CONTXT='ERROR: reading CCR2 table '//CCR2
                            GO TO 999
                        ENDIF
                ENDIF
10      CONTINUE
C
C sort into ascending order
C
        CALL ZSORTR(NFOUND,MEMR(YDEF),MEMI(ROWS))
        ISTAT=0
        GO TO 1000
999     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END