C    %W% %G%
      subroutine cntrl
c
c     This subroutine serves as the control module for the solution
c     portion of the program.  It determines the time step, checks
c     to see if a network modification is needed, calls the needed
c     subroutines for a time step solution, and checks tolerances to
c     to see if a successful solution has been reached.

C     It is called by SWINGM.  It calls : ANGSOL, BRAKE, CNTRLA,
C     DERIV, ENDSUM, FREQC, MAXMIN, RELAY, SHDSOL, SVSSOL, VTCHK,
c     VYSOL,WRTHIS.
c
      include 'tspinc/params.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/toler.inc'
      include 'tspinc/param.inc'
      include 'tspinc/contrl.inc'
      include 'tspinc/search.inc'
      include 'tspinc/lnk12.inc'
      include 'tspinc/lnk1a.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/ecsind.inc'
      include 'tspinc/bname.inc'
      include 'tspinc/buskv.inc'
      include 'tspinc/brake1.inc'
      include 'tspinc/ecstbb.inc'
      include 'tspinc/ecstbc.inc'
      include 'tspinc/ecstbd.inc'
      include 'tspinc/ecstbh.inc'
      include 'tspinc/ecstbj.inc'
      include 'tspinc/machd1.inc'
      include 'tspinc/machd2.inc'
      include 'tspinc/outaux.inc'
      include 'tspinc/igentn.inc'
      include 'tspinc/gentbla.inc'
      include 'tspinc/gentblb.inc'
      include 'tspinc/gentblc.inc'
      include 'tspinc/dateq.inc'
      include 'tspinc/lshed1.inc'
      include 'tspinc/busdta.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/relays.inc'
      include 'tspinc/amorts.inc'
      include 'tspinc/prate.inc'
      include 'tspinc/vtchkc.inc'
      include 'tspinc/busvolt.inc'
      common/vregl/em,vmqt,vmdt
C
C     The following common block is due to split between CNTRL and CNTRLA
C
      include 'tspinc/comvar.inc'
      include 'tspinc/znox.inc'
      include 'tspinc/spare1.inc'

      common /ckpnt/ dnxmin,d13
      equivalence (creg(9), dr), (creg(21), rcex), (creg(23),
     1    xcex), (creg(3), vref), (creg(27), vco), (creg(7), cckp,
     2    ckpr), (creg(28), theta, ckpi), (creg(20), xl), (creg(10),
     3    ckc), (creg(11), v1max), (creg(13), va), (creg(30), vi),
     4    (creg(15), hcb), (creg(16), ckj), (creg(17), db),
     5    (creg(18), dc), (creg(19), vgmax), (creg(1), vrmax),
     6    (creg(2), vrmin), (creg(22), vr), (creg(8), cka), (creg(24),
     7    ckg), (creg(25), da), (creg(26), hba), (creg(4), efdmax),
     8    (creg(5), cki), (creg(29), efd), (creg(6), hbr),
     9    (creg(12), v1min), (creg(14),vfldo)

      include 'tspinc/deltfq.inc'

c *** csw 9/93 added this common block to hold govmin/govmax terms
      common /govminmax/ govmn(MAXGEN), govmx(MAXGEN)
c *** csw end addition

      dimension difpwr(MAXGEN)
      equivalence (aeps,ar), (aes,brs,af1), (bes,bf1), (ba1s,br),
     1            (baps,a1), (bfs,a2), (ae, vfdo), (aep, bfx),
     2            (be, ba1x), (bf1, bapx)
      dimension istem(MAXLS)

      equivalence (istem,isorti)
      equivalence(csupp(26),x5o)

      dimension itempn(4,5), ktemp1(9), temp1(9), tempn(2,13),
     1          ecsn2(2), iecsn(6)
      equivalence (ktemp1,temp1), (pgo,pgor), (sat,rt), (sater,dtc),
     1            (isg2,istp), (csupp(27),ivcsw)
      character*1 idm, id, id1
      character*8 name, name1, name2
c
      logical debug, dbghere, finished, flag                            !dem
      character gname*16                                                !dem

      data twopi  / 6.2831853 /
      data degrad /0.0174533/
      data pi     /3.1415927 /
C     begin     begin     begin     begin     begin     begin

      debug = dbghere ('CNTRL   ')                                      !dem
      if (debug) then                                                   !dem
        call dbgeko ('CNTRL - At start')                                !dem
        call dbgwrf ('  TO /time/ = ',to)                               !dem
        call dbgwri ('  IDSW /discont stat/ = ',idsw)                   !dem
        call dbgwri ('  IDISW /discont sw/  = ',idisw)                  !dem
        call dbgwri ('  LPPWR /iteratn cnt/ = ',lppwr)                  !dem
      endif                                                             !dem
      mts = 39
      igv = 19
      iex = 35
      isup = 33
      isup1 = isup
c
c     If change in time step, resolve machine differential equations
c
      if (al.eq.1.) go to 3520
      irstrt = 0

c     Resolve the network

  100 call xtime(-3)
      call deriv
      call xtime(3)
c
c     LINK > 10 flags fatal error return from DERIV
c
      if (link .gt. 10) then
         link = link - 10
         jexit=1
         go to 2200
      endif

      idsw7=1
      asum=0.0
      i7=1
      i8=1
c
c     Calculate accelerating power
c
      do i = 1, isg
         mgen=igndta(1,i)
c
c        If machine is an induction motor, calculate accelerating power
c        only
C
         if (mgen .eq. 2) then
            difpwr(i)=govpwr(i)-genp(i)
            go to 2440
         endif
c
C        Bypass adjustments for fst valving/flt damping except for
c        first pass
c
         if (lppwr.ne.0) go to 2432
         if (idsw.eq.7) go to 2432
c
C        Check for fast valving
c
         if (i8.gt.i8max) go to 2432
         do jj=1,i8max
            if (i .eq. ifvl(jj)) then
               if (abs(dfvl(jj)) .gt. 0.001) then
                  govpwr(i) = govpwr(i) + dfvl(jj) * edt / frqbse
               endif
               i8=i8+1
               go to 2432
            endif
         enddo
 2432    if (mfdep .eq. 5) then
            rcmfac = 2.0*pi/(2.0*pi + angp2(i))
            difpwr(i) = govpwr(i) * rcmfac - genp(i)
         else
            difpwr(i) = govpwr(i) - genp(i)
         endif
c
C        Check for DC offset damping
c
         if (i7 .gt. i7max) go to 2440
         do kk=1,i7max
            if (i .eq. iflt(kk)) then
               i7=i7+1
               if (abs(dflt(kk)) .ge. 0.001) then
                  difpwr(i)=difpwr(i)-dflt(kk)*govpwr(i)
               endif
               go to 2440
            endif
         enddo
 2440    asum=asum+abs(difpwr(i))

c        call genname (i,gname)                                         !dem
c        if (gname .eq. 'GEN TD1   20.0 L') then
c           sparpt(8) = difpwr(i)
c        else if (gname .eq. 'GEN TD1   20.0 H') then
c           sparpt(10) = difpwr(i)
c        endif

      enddo
C
C     VREG + SPGOV DEBUG
C
      if (keybrd(16) .ne. 0) then
         i = 900
         write (outbuf, 2460) i, idsw, lppwr, tc1, tc2, tc3, edt,
     1                        ddt1, ddt2, dnx, tnx, asum
 2460    format(' CX ', 3i5, 9e12.5)
         call prtout (1)
         do jjj = 1, isg, 4
            kkk = min0 (jjj+3, isg)
            write (outbuf, 2461)
     1            (k, genp(k), difpwr(k), k = jjj,kkk)
 2461       format(1x, 4(i5, 2e13.5))
            call prtout (1)
         enddo
      endif

      if (asum .gt. asumt) then

C        SETUP NEG SEQ SW

         if (iesc.ne.1.and.gfr.ne.0.0.or.bfr.ne.0.0) then
            negseq=2
            eyrmx = eyr(nmx)
            eyimx = eyi(nmx)
            fltcr=eyrmx*gfr-eyimx*bfr
            fltci=eyrmx*bfr+eyimx*gfr
         else
            negseq=1
         endif

         if (igtmax .ge. 3) then
            do ispf = 1, isg
               iecs=igentn(2,ispf)
               igbn=igentn(1,ispf)
               call redecs (datat(7),iecs+6,1)
               disf2 = 0.0
               if (dmpfac .ne. 0.0 .and. disf2 .ne. 0.0) then

C                 Test for NEG SEQ braking (Note: Code is disabled!)

                  if (negseq .eq. 2) then

C                    Obtain NEGSEQ DMP PWR

                     cr=fltcr*disf2
                     ci=fltci*disf2

c                    Send error msg since RNEG & RPOS have no values
c                    up to now

                     write (errbuf(1),'(2a)')
     &          'CNTRL - undefined variables in neg seq braking calcs.'
                     call prterr ('E',1)                                                  !dem
                     dampn=(cr*cr+ci*ci)*(rneg-rpos)
                     difpwr(ispf)=difpwr(ispf)-dampn
                     if (keybrd(3) .ne. 0) then
                        i=1295
                        write (outbuf,3500) i,dampn
 3500                   format (' 1c', i5, 'dampn', e15.7)
                        call prtout (1)
                     endif
                  endif
               endif
            enddo
         endif
      else
         dampn=0.0
      endif

      if (idsw.ne.7) go to 2560

c     -  Last chance to change any states at a discont before they're
c        stored in the history file.
C     call ssstep
C     I140=0 Denotes coming out of discontinuity

      i140 = 0
      to = tsim
      iskkt = 0
c
c     Call WRTHIS to write solution data to history file FOR008
c     -  Save the plus side of a discontinuity.  We also save at
c        t = 0+, even if no switching event then.

      if (debug) then                                                   !dem
        call dbgeko ('CNTRL - saving history file at 2nd WRTHIS call')  !dem
      endif                                                             !dem
      call wrthis
      do i=1, isg
        paccex(i) = difpwr(i)
      enddo
c     -  Change progress status from processing discont point to proces-
c        sing regular interval with a discont at its start.
      idsw=3
      idisw=2
      idsw7=1

C     Initialize load mod. sw. + first bus

  120 ivpc=1
      if (dnxrly .le. to+0.0001) dnxrly = endt
      lfrst=nmx+1
c
c     Call RELAY for relay solution logic
c
      call relay
c
c     Call BRKSOL for resistive brake logic
c
      if (nbrake .ne. 0) call brksol
c
c     Call SHDSOL for load shedding logic
c
      if (ls .ne. 0) call shdsol
c
c     Call FREQC to update bus frequency tables
c
      call freqc
      if (idisw.eq.1) go to 2660
      idiskt=idiskt+1
      if (ivpc.eq.1) then
         idiskt=0
         idisw=1
         itrace = 3
         go to 3240
      endif
      idsw=7
      matsw=2
      link=2
      istat = 4
      return
c
c     Normal iteration (no discontunity)
c
 2560 itol=1
      itrace = 1
      itoldc = 1
      if (lppwr .eq. 0 ) lpdc = 1
      if (lpdc .eq. 2) go to 3600
      idsw7 = 0
      dcrepm = 0.0
      angdim = 0.0
      acperr = 0.0
      do i = 1, isg
         dcrep = abs(difpwr(i) - paccex(i))
         acperr = acperr + dcrep
C
C        Bypass blocked ind mtr--see S 3045-1
C
         if (paccex(i) .ne. -4000.0) then
            paccex(i) = difpwr(i)
            if (dcrepm .le. dcrep) then
               dcrepm = dcrep
               imx = i
            endif
         endif
      enddo

C     Conditionally print solution residuals at each iteration

      if (toli .ge. dcrepm .and. toli .ge. cmax) then
         if (keybrd(15) .gt. 0) then
            iresid = 1
            call prtresid (imx, acperr, dcrepm)
         endif
      else
         itol=2
         if (keybrd(15) .gt. 0) then
            call prtresid (imx, acperr, dcrepm)
         endif
      endif

C     tally loop cnt

      lppwr=lppwr+1
      go to 3520

C     Init pwr tol loop cntr

 2660 lppwr=0
      itrace = 2
      tc1=tc2
      tc2=tc3
      tc3 = tsim + edt
      ddt1=ddt2
      ddt2=edt
      d13=ddt1+ddt2
      tsim = tc3
      tnx = tsim + dt

      go to (2820,2920,2780,2800,2920,2920), idsw
 2780 idsw=4
      go to 2820
 2800 idsw=1
 2820 if (ivpc.eq.1) go to 2840
      matsw=2
      idsw=7
      link=2
      istat = 4
      return
 2840 go to (3240,2860,3180,3240,2880,2900), idsw
 2860 idsw=1
      go to 3240
 2880 idsw=6
      go to 3240
 2900 idsw=2
      go to 3240
 2920 if (dnx.ne.dnxmin) then
         if (ivpc.eq.1) go to 2840
         matsw=2
         idsw=7
         link=2
         istat = 4
         return
      endif
      ist=0
      if (keybrd(3) .ne. 0) then
         i=1081
         write (outbuf,2940) i,idsw
         call prtout (1)
 2940    format (' 1c', 2i5)
      endif
 2960 if (iswt.gt.ifcd) go to 3100
      if (dnx.ne.cyc(iswt)) go to 3120
      if (dnx .gt. tsim + 0.001) then
         if (ivpc.eq.1) go to 2840
         matsw=2
         idsw=7
         link=2
         istat = 4
         return
      endif
      icntl2=2
      ist=ist+1
      istem(ist)=iswt
      iswt=iswt+1
      go to 2960

 3100 dnx=endt+4.0*dt
      go to 3160

 3120 dnx=cyc(iswt)

 3160 go to (3180,3220,3180,3180,3220,3220), idsw
 3180 write (errbuf(1),3200) idsw, ivpc
 3200 format( '0CNTRL ... error in switching code .. idsw=', i2,
     1 '  ivpc=', i2)
      call prterr ('E',1)
      jexit=1
      go to 2200
 3220 idsw=7
      matsw=3
      link=2
      istat = 4
      return
c
c     Begin time step loop
c
 3240 dnxmin=amin1(dnx,dnxrly)
      finished = .false.
      flag = .true.              ! Flag set for bus freq calc.
      do while (.not. finished)
         if (dnxmin .le. tnx+0.0001) then
            edt = dnxmin - tsim
            isg3 = 0
            if (idsw .eq. 1) then
               idsw=2
            else if (idsw .eq. 2 .or. idsw .eq. 6) then
               finished = .true.
            else if (idsw .eq. 3) then
               idsw=5
               finished = .true.
            else if (idsw .eq. 4) then
               idsw=5
               finished = .true.
            else
               write (errbuf(1),3200) idsw, ivpc
               call prterr ('E',1)
               jexit=1
               go to 2200
            endif
         else
            isg3 = isg3 + 1
            if (isg3 .lt . istp) then
               if (edt .eq. dt) flag = .false.
               edt=dt
               finished = .true.
            else
               dt=dtc
               edt=dt
               finished = .true.
            endif
         endif
      enddo
c
c     Calculate time factor for bus frequency filter
c
      if (flag) then
         if (tbusf .ne. 0.0) then
            abus = 1.0 + 2.0*tbusf/edt
            abusr = 1.0/abus
         endif
         if (edt .ne. ddt2) then
            write (outbuf, 3360) to, ddt2, edt
 3360       format ('0',5x,'Change in time step at ',f7.2,
     1              ' cycles.  Old time step was ',f4.2,
     1              ' new time step is ',f4.2)
            call prtout (1)
            al=1.
            tfac=ddt2/edt
         endif
      endif

 3520 itsl = 0
c
c     Begin machine equation solution loop.
c
c     If any variable admittance elements exist, call VYSOL to
C     solve their differential equations
c
      if (iznmax .gt. 0) call vysol
c
c     A "do while" statement is used because "ispf" is adjusted to
c     solve HP/LP governors in LP/HP order.
c
      ispf = 1
      do while (ispf .le. isg)
         ispm = ispf-1
         igbn=igentn(1,ispf)
         iecs=igentn(2,ispf)
         idm = igentc(ispf)
         call redecs (datat,iecs, mts)
         mgen=igndta(1,ispf)
         lvref=igndta(2,ispf)

         if (mgen .eq. 9) then
c
c           MGEN = 9 IS A STATIC VAR SOURCE NOT A MACHINE SO CALL SVSSOL
c
            call svssol

         else if (consm .eq. 999999.) then
c
c           CONSM = 999999. implies an infinite bus and is not processed
C           as a normal machine
c
         else if (consm .eq. 0.) then
c
c           CONSM = 0. implies a machine who's power has been reduced to
C           zero by generator dropping. it is not processed.

            angl(ispf)=-40000.
         else

            dampp = dmpfac
            if (mgen .ne.5 .and. mgen .ne. 8)  mex = 0
            if (mgen .eq. 2) dampp=0.
c
c           Solve swing equation using trapezoidal rule.
c
            call angsol
c
c           Calculate field curr for 2 axis mach
c
            if (mgen .ge. 6) then
               cfd = epqo + (epqo - edpqo) * (xd - xdp) / (xdp - xdpp)
               cfd = cfd * (1.0 + satd)                                 !wlp
               vfldtn(2,ispf) = cfd
            endif

c           solve gov equations
            call govsol(ispf, edt, ddt2, wnew, wnow, lppwr, tsim)

            if (mgen .eq. 5 .or. mgen .eq. 8) then
C
C              Solve exciter and PSS equations
C
               call cntrla(itrnfr)
               if (itrnfr .eq. 2) go to 3540

            endif
            if (mgen .eq. 1) then
               igr=7
            else if (mgen.eq.2) then
               igr = 26
               vfldtn(1,ispf)=1000.
               vfldtn(2,ispf)=0.0
               call ritecs(datat, iecs, 26)
            else
               igr=mts
               if (mgen.lt.6)igr=27
               call ritecs (datat(17),iecs+16,11)
            endif
            if (mgen .eq. 5 .or. mgen .eq. 8) then
               call ritecs (creg(6),mexecs+5,iex-5)
               igr=igr+iex
               if (msupp .gt. 0) then
                  call ritecs (csupp(4),msupec+3,isup1-3)
                  igr=igr+isup1
c
c                 Check for PSS notch filter
c
                  if (dnf .gt. 0.0) then
                     call ritecs(csupp(35),msupec+isup1+1,8)
                     igr = igr + 9
                  endif
               endif
            endif
c
c           Update
c
c
            if (mgov .eq. 0) then
            else if (mgov .eq. 3 .and. idm .eq. 'H') then
c
c              Store the hp gov indices. Compute after lp gov
c              solved.
c
               igrh = igr
               mgvech = mgvecs
               spdslh = spdslp
               ispfh = ispf
               iecsh = iecs

            else

c              call ritecs (cgov(2),mgvecs+1,igv-1)
               igr=igr+igv
               if (keybrd(18) .ne. 0) then
                  name = bname(igbn)
                  call redecs (datat,iecs,igr)
                  write (outbuf,6360) name, mgen, mgov, mex,
     1                                msupp, lvref
 6360             format('0',a8,5i5,' mgen,mgov,mex,msupp,lvref')
                  call prtout (1)
                  do jjj = 5,igr,8
                     kkk = min0 (jjj+7,igr)
                     write (outbuf,6361) (i,datat(i),i=jjj,kkk)
 6361                format(2x,8(i3,e13.6))
                     call prtout (1)
                  enddo
               endif

            endif

            if (mgov .eq. 3 .and. igovc .eq. 1) then
c
c              If lp gov processed, go back an process hp gov
C              Pick up indexes and variables for HP M/C  ***
c
               ispf = ispfh
               mgvecs = mgvech
               spdslp = spdslh
               iecs = iecsh
               igr = igrh
               igovc = -1
c
c              call ritecs (cgov(2),mgvecs+1,igv-1)
               igr=igr+igv
               if (keybrd(18) .ne. 0) then
                  name = bname(igbn)
                  call redecs (datat,iecs,igr)
                  write (outbuf,6360) name, mgen, mgov, mex,
     1                                msupp, lvref
                  call prtout (1)
                  do jjj = 5,igr,8
                     kkk = min0 (jjj+7,igr)
                     write (outbuf,6361) (i,datat(i),i=jjj,kkk)
                     call prtout (1)
                  enddo
               endif
c
C              Retrieve current index  ***
c
               ispf=ispfl
               igovc=0

            endif
 3540    continue
         endif
         ispf = ispf + 1
      enddo
      ispm = isg

      al=0.0
 3600 continue
c
c     End of machine solution loop.
C     If first iteration, resolve network

      if (lppwr .eq. 0) go to 100
      if (itol .eq. 2) go to 3660

 3640 if (lppwr .eq. 1) go to 3660
      if (itoldc .eq. 2) go to 3660

C     Store past values of E,F

      to = tsim + edt
      idisw=1
      dnxmin=amin1(dnx,dnxrly)
c
c     Update saturation factors
c
      do i=1,isg
         iecs=igentn(2,i)
         call redecs(datat,iecs,27)
         mgen=igndta(1,i)
         if (mgen .gt. 3 .and. mgen .ne. 9) then
            if (mgen .gt. 5) call redecs(datat,iecs,39)
            if (esat .gt. 0.0) then
               i1= igentn(1,i)
               ed = eyri(i)
               eq = eyii(i)
               vpd = ed + ra*oid-xp*oiq
               vpq = eq + ra*oiq+xp*oid
               vpm = sqrt(vpd**2 + vpq**2)
               if (vpm.gt.esat) then
                  satd = (csat*(vpm-esat)*(vpm-esat))/vpm
                  satq= (xq/xd)*satd
               else
                  satd=0.0
                  satq=0.0
               endif
               call ritecs (satd,iecs+25,2)
               if (keybrd(26) .ne .0) then
                  write (outbuf,3657)i,vpm,satd,satq
 3657             format(' Ith GEN,VPOTIER,SATD,SATQ ', i5, 3e15.6)
                  call prtout (1)
               endif
            endif
         endif
      enddo

      i140 = 1
      do i=1, isg
         anglt(i)=angl(i)*57.2957795
      enddo
c
c     Calculate maximum angle difference
c
      call maxmin
c
c     After 30 cycles check for low voltage condition.
c     (Call only for nonshort circuit condition (IESC =1))
c
      if (lovtex .eq. 0 .and. to .gt. 30. .and. iesc .lt. 2) then
         call vtchk
      endif
      kexit=0
c
c     Jexit = 3 Is the last time step in the study
c
      if (to.ge.endt) jexit=3
c
c     The following logic will write data to the .SOL file (l8) every
C     ITSKP time steps.  Discontinuities, manual exits, and the last
C     time step in the study are always written to the .SOL file.
c
 2200 if (idsw .eq. 2 .or. idsw .gt. 4) go to 2201
      if (jexit .eq. 1 .or. jexit .eq. 3) go to 2201
      if (itskp .ne. 0) then
         iskkt = iskkt +1
         if (iskkt .ne. itskp) go to 2280
      endif
 2201 iskkt = 0
c
c     Call WRTHIS to write solution data to history file for008
c     -  Save the solution for a normal step.  Here we also save the
c        minus side of a discontinuity.

      if (debug) then                                                   !dem
        call dbgeko ('CNTRL - saving history file at 1st WRTHIS call')  !dem
      endif                                                             !dem
      call wrthis
c
c        JEXIT = 1 MEANS A MANUAL EXIT
c
 2280 if (jexit .eq. 1) then
         write (errbuf(1), 2320)
 2320    format ('0Manual exit')
         call prterr ('W',1)
c
c        Call ENDSUM to write underfrequency load shedding summary
c
         call endsum

c        -  Add e-o-f marker to history file

         call puthisi (-1,1)
         call filhis
         ntry=2
         link=3
         return
c
c        JEXIT = 2 IS AN NORMAL TIME STEP
c
      else if (jexit .eq. 2) then
         idsw7=0
         go to 120
c
c        JEXIT = 3 IS THE LAST TIME STEP IN THE STUDY OR LOW VOLTAGE
c
      else if (jexit .eq. 3) then
         if (lovlt .eq. 1) then
           write(errbuf(1),2350)
 2350      format('0 PROGRAM MANUALLY STOPPED DUE TO LOW VOLTAGE ',
     1            'CONDITION')
           call prterr('W',1)
         else
             write (outbuf, 2360)
 2360        format ('0 Scheduled time limit reached')
             call prtout (1)
         endif
c
c        Call ENDSUM to write underfrequency load shedding summary
c
         call endsum

c        -  Add e-o-f marker to history file

         call puthisi (-1,1)
         call filhis
         ntry=2
         link=3
         return
      endif

c     -  Go back & solve network unless maxed out on iterations

 3660 if (lppwr .lt. lpqit) go to 100
      write (outbuf,3680)
 3680 format (' Power exterpolation loop limit reached')
      call prtout (1)
c
c     Check if interface iter limit termination
c
      if (lsolqt.eq.1) then
        jexit=1
        go to 2200
      else
         iresid=2
         call prtresid (imx, acperr, dcrepm)
         go to 3640
      endif
      end


C Driver, to be modified by the user (keeping the read statements).
C Should be backward compatible with v3.1 and v3.2 (thanks to B. Kersevan)
      PROGRAM HWIGPR
      INCLUDE 'HERWIG65.INC'
      INCLUDE 'JIMMY.INC'
      INTEGER N,NSTEP,I,JPR0,JPR,NUMDM,II,NBODIES(100),JJ,IMATCH
      INTEGER IMOTH(100),IDAUGHT(100,5),NMOTH,ARRMOTH(100),III,KK
      DOUBLE PRECISION BR(100),BRR(100,100),SUMBR(100,100)
      INTEGER IMIN(100),IMAX(100),MEDEC(100)
      CHARACTER *1 TMPCH
C QQIN IS THE EVENT FILE
      CHARACTER*50 QQIN
      COMMON/VVJIN/QQIN
      CHARACTER *7 NORM_EVENT
      INTEGER MQQ
      COMMON/cMQQ/MQQ
      REAL*8 TMPLAM,GAMT0,ERR_FR
      INTEGER IPDF
      CHARACTER * 70 LHAPDF
      LOGICAL LHACRTL,OLDFORM,PI_STABLE,WP_STABLE,WM_STABLE,Z_STABLE,
     &TAUP_STABLE,TAUM_STABLE,MUP_STABLE,MUM_STABLE,H_STABLE
      PARAMETER (LHACRTL=.TRUE.)
      LOGICAL ENDOFRUN,IS_ST,IS_BB,ABORT
      COMMON/CENDOFRUN/ENDOFRUN
      INTEGER MAXEVV
      COMMON/CMAXEVV/MAXEVV
      DOUBLE PRECISION EXPONT,PTJIM0,PRRAD
C
      ENDOFRUN=.FALSE.
      OLDFORM=.FALSE.
      WRITE(*,*)'Enter filename for events'
      READ(*,*)QQIN
      WRITE(*,*)'Enter maximum number of events to generate'
      WRITE(*,*)'MUST coincide with the number of events on tape'
      READ(*,*)MAXEV
      MAXEVV=MAXEV
      MQQ=MAXEV
      WRITE(*,*)'Enter 0 to use Herwig default PDFs'
      WRITE(*,*)'      1 to use PDFs from library'
      READ(*,*)IPDF
C OUTPUT THE RESULTS AFTER ANY NSTEP EVENTS
      NSTEP=20000
C---BEAM PARTICLES
      WRITE(*,*)'Enter colliding particles (PART1, PART2)'
      READ(*,*)PART1,PART2
C---BEAM MOMENTA
      WRITE(*,*)'Enter beam momenta (PBEAM1, PBEAM2)'
      READ(*,*)PBEAM1,PBEAM2
C---PROCESS
      IPROC=-18000
C---INITIALISE OTHER COMMON BLOCKS
      CALL HWIGIN
C     JIMMY initialization
      CALL JIMMIN
C---USER CAN RESET PARAMETERS AT
C   THIS POINT, OTHERWISE DEFAULT
C   VALUES IN HWIGIN WILL BE USED.
C
C PTVETO MUST BE TRUE IN ORDER FOR SCALUP TO BE USED ALSO
C IN CASE OF RADIATION OFF RESONANCES
      PTVETO=.TRUE.
C************************************************************************
C---UNCOMMENT THE ASSIGNMENT PRESPL=.FALSE. WHEN USING HERWIG VERSION 6.52
C---OR HIGHER (SEE MC@NLO MANUAL, APPENDIX A.8, PAGE 25)
      PRESPL=.FALSE.
C************************************************************************
C UNDERLYING EVENT
      WRITE(*,*)'Enter .TRUE. for underlying event, .FALSE. otherwise'
      READ(*,*)LHSOFT
      WRITE(*,*)
      IF(LHSOFT)WRITE(*,*)'Underlying event WILL be generated'
      IF(.NOT.LHSOFT)WRITE(*,*)'Underlying event WILL NOT be generated'
      WRITE(*,*)
C
      IF(LHSOFT.AND.IPDF.NE.1)THEN
         WRITE(*,*)' '
         WRITE(*,*)'Underlying event requires external PDF sets'
         WRITE(*,*)'Please set PDFCODE != 0 in shower_card.dat'
         STOP
      ENDIF
      IF(IPDF.EQ.1.OR.LHSOFT)THEN
         IF(IPDF.EQ.1)THEN
            DO I=1,2
               WRITE(*,*)'   Incoming particle # ',I
               WRITE(*,*)'Enter PDF group name (AUTPDF)'
               READ(*,*)AUTPDF(I)
               WRITE(*,*)'Enter PDF set number (MODPDF)'
               READ(*,*)MODPDF(I)
            ENDDO
         ENDIF
         IF(LHSOFT)THEN
C---JIMMY UNDERLYING EVENT OVERRIDES PDF ASSIGNMENTS: MUST USE LO**
            WRITE(*,*)' '
            WRITE(*,*)'JIMMY underlying event requires PDFs=LO**'
            DO I=1,2
               IF(AUTPDF(I).NE.'LHAPDF'.AND.AUTPDF(I).NE.'LHAEXT')THEN
                  WRITE(*,*)'PDF error 1 in MG5_aMC@NLO'
                  STOP
               ENDIF
               IF(MODPDF(I).NE.20651)THEN
                  WRITE(*,*)'Forcing PDFs to be 20651'
                  MODPDF(I)=20651
               ENDIF
            ENDDO
         ENDIF
         WRITE(*,*)' '

C---SET LHACRTL TO FALSE IF LHAPDF DEFAULTS FOR 16, 18, AND 19 ARE OK
         IF(LHACRTL.AND.
     #      (AUTPDF(1).EQ.'LHAPDF'.OR.AUTPDF(1).EQ.'LHAEXT'))THEN
            LHAPDF='FREEZE'
            IF(AUTPDF(1).EQ.'LHAEXT')LHAPDF='EXTRAPOLATE'
            CALL SETLHACBLK(LHAPDF)
C---MODERN VERSIONS OF LHAPDF REQUIRE THE FOLLOWING SETTING
            DO I=1,2
               AUTPDF(I)='HWLHAPDF'
            ENDDO
         ENDIF
      ENDIF

      WRITE(*,*)'Enter Lambda_QCD, <0 for Herwig default'
      READ(*,*)TMPLAM
C
      WRITE(*,*)'Enter Z mass, width'
      READ(*,*)RMASS(200),GAMZ
      WRITE(*,*)'Enter W mass, width'
      READ(*,*)RMASS(198),GAMW
      RMASS(199)=RMASS(198)
      WRITE(*,*)'Enter top mass, width'
      READ(*,*)RMASS(6),GAMT0
      WRITE(*,*)'Enter Higgs (SM) boson mass, width'
      READ(*,*)RMASS(201),GAMH
      WRITE(*,*)'Enter quark (d,u,s,c,b) and gluon masses'
      READ(*,*)RMASS(1),RMASS(2),RMASS(3),RMASS(4),RMASS(5),RMASS(13)
      WRITE(*,*)'Enter lepton (e,mu,tau) masses'
      READ(*,*)RMASS(121),RMASS(123),RMASS(125)
      DO I=1,5
         RMASS(I+6)  =RMASS(I)
         RMASS(I+126)=RMASS(I+120)
      ENDDO

C NO SOFT AND HARD ME CORRECTIONS (ALREADY INCLUDED IN MC@NLO)
      SOFTME=.FALSE.
      HARDME=.FALSE.
      ZMXISR=0 ! No photon radiation from ISR
      NOWGT=.FALSE.
C NEGATIVE WEIGHTS ALLOWED
      NEGWTS=.TRUE.
      WRITE(*,*)'Enter number of events to print'
      READ(*,*)MAXPR
      if(MAXPR.gt.MAXEV)MAXPR=MAXEV
      WRITE(*,*)'Enter accepted error fraction'
      READ(*,*)ERR_FR
      if(err_fr.lt.0d0.or.err_fr.gt.1d0)then
         write(*,*)'ERR_FR should be between 0 and 1 !'
         stop
      endif
      MAXER=INT(MAXEV*ERR_FR)
      is_bb=.false.
      is_st=.false.
      WRITE(*,*)'Is it single-top (.TRUE. or .FALSE)?'
      READ(*,*)is_st
      WRITE(*,*)'Is it b-bbar (.TRUE. or .FALSE)?'
      READ(*,*)is_bb
      if(is_st.and.is_bb)then
         write(*,*)'It cannot be single top and b bbar at the same time'
         stop
      endif
      LRSUD=0
      LWSUD=77
C IN THE CASE HERWIG PDFS ARE USED, ADOPT MRST
      NSTRU=8
      PRVTX=.FALSE.
      PTMIN=0.5
      WRITE(*,*)'Enter the two random seeds (0 0 for default)'
      READ(*,*)NRN(1),NRN(2)
      if(NRN(1).eq.0)NRN(1)=1973774260
      if(NRN(2).eq.0)NRN(2)=1099242306
C THE FOLLOWING SHOULD BE USED ONLY IN WEIGHTED MODE
      IF(.NOT.NOWGT)THEN
        WGTMAX=1.000001D0
        AVABW=1.000001D0
      ENDIF
C FOR TOP PRODUCTION (HARMLESS ELSEWHERE)
      RLTIM(6)=1.D-23
      RLTIM(12)=1.D-23
C---B FRAGMENTATION PARAMETERS (FOR B PRODUCTION ONLY)
      IF(is_bb)PSPLT(2)=0.5
C---COMPUTE PARAMETER-DEPENDENT CONSTANTS
      CALL HWUINC
C---SET LAMBDA_QCD ACCORDING TO LHAPDF OR TO THE INPUT FILE
      IF(IPDF.EQ.1)CALL GETLAMLHA(QCDLAM,-1D0)
      IF(TMPLAM.GE.0.D0)QCDLAM=TMPLAM
C---CALL HWUSTA TO MAKE ANY PARTICLE STABLE
      pi_stable=.false.
      WRITE(*,*)'Do you want a stable Pi0 (.TRUE. or .FALSE)?'
      READ(*,*)PI_STABLE
      WRITE(*,*)'Do you want a stable W+ (.TRUE. or .FALSE)?'
      READ(*,*)WP_STABLE
      WRITE(*,*)'Do you want a stable W- (.TRUE. or .FALSE)?'
      READ(*,*)WM_STABLE
      WRITE(*,*)'Do you want a stable Z0 (.TRUE. or .FALSE)?'
      READ(*,*)Z_STABLE
      WRITE(*,*)'Do you want a stable Tau+ (.TRUE. or .FALSE)?'
      READ(*,*)TAUP_STABLE
      WRITE(*,*)'Do you want a stable Tau- (.TRUE. or .FALSE)?'
      READ(*,*)TAUM_STABLE
      WRITE(*,*)'Do you want a stable Mu+ (.TRUE. or .FALSE)?'
      READ(*,*)MUP_STABLE
      WRITE(*,*)'Do you want a stable Mu- (.TRUE. or .FALSE)?'
      READ(*,*)MUM_STABLE
      WRITE(*,*)'Do you want a stable Higgs (.TRUE. or .FALSE)?'
      READ(*,*)H_STABLE

      if(PI_STABLE)  CALL HWUSTA('PI0     ')
      if(WP_STABLE)  CALL HWUSTA('W+      ')
      if(WM_STABLE)  CALL HWUSTA('W-      ')
      if(Z_STABLE)   CALL HWUSTA('Z0/GAMA*')
      if(TAUP_STABLE)CALL HWUSTA('TAU+    ')
      if(TAUM_STABLE)CALL HWUSTA('TAU-    ')
      if(MUP_STABLE) CALL HWUSTA('MU+     ')
      if(MUM_STABLE) CALL HWUSTA('MU-     ')
      if(H_STABLE)   CALL HWUSTA('HIGGS   ')
C---USE THE FOLLOWING FOR SINGLE TOP -- AVOIDS TROUBLES WITH ISR
      IF(is_st)THEN
        CALL HWUSTA('B+      ')
        CALL HWUSTA('B-      ')
        CALL HWUSTA('B_D0    ')
        CALL HWUSTA('B_DBAR0 ')
        CALL HWUSTA('B_S0    ')
        CALL HWUSTA('B_SBAR0 ')
        CALL HWUSTA('SIGMA_B+')
        CALL HWUSTA('LMBDA_B0')
        CALL HWUSTA('SIGMA_B-')
        CALL HWUSTA('XI_B0   ')
        CALL HWUSTA('XI_B-   ')
        CALL HWUSTA('OMEGA_B-')
        CALL HWUSTA('B_C-    ')
        CALL HWUSTA('ETA_B   ')
        CALL HWUSTA('UPSLON1S')
        CALL HWUSTA('SGM_BBR-')
        CALL HWUSTA('LMD_BBR0')
        CALL HWUSTA('SGM_BBR+')
        CALL HWUSTA('XI_BBAR0')
        CALL HWUSTA('XI_B+   ')
        CALL HWUSTA('OMG_BBR+')
        CALL HWUSTA('B_C+    ')
      ENDIF

      WRITE(*,*)'How many decay modes do you want to set?'
      READ(*,*)NUMDM

      IF(NUMDM.NE.0)THEN
         NMOTH=1
         DO II=1,NUMDM
            IMIN(II)=100000
            IMAX(II)=-100000
            ARRMOTH(II)=0
            DO JJ=1,5
               IDAUGHT(II,JJ)=0
            ENDDO
            DO JJ=1,NUMDM
               BRR(II,JJ)=0D0
               SUMBR(II,JJ)=0D0
            ENDDO
            IMOTH(II)=0
            NBODIES(II)=0
            BR(II)=0D0

            WRITE(*,*)'Enter number of bodies for decay mode ',II
            READ(*,*)NBODIES(II)
            WRITE(*,*)'Enter decay mode A --> B C ... with the syntax'
            WRITE(*,*)'DM_NUM = PDG(A) > PDG(B) PDG(C) ... @ BR @ ME'
            WRITE(*,*)'where 1 <= NUM <= 99'
            READ(*,*)IMOTH(II),TMPCH,(IDAUGHT(II,JJ),JJ=1,NBODIES(II)),
     &               TMPCH,BR(II),TMPCH,MEDEC(II)

            IMATCH=0
            DO III=1,NMOTH
               IF(IMOTH(II).EQ.ARRMOTH(III))THEN
                  IMATCH=1
               ENDIF
            ENDDO
            IF(IMATCH.EQ.0)THEN
               ARRMOTH(NMOTH)=IMOTH(II)
               NMOTH=NMOTH+1
            ENDIF
         ENDDO
         NMOTH=NMOTH-1

         DO JJ=1,NMOTH
            DO II=1,NUMDM
               IF(IMOTH(II).EQ.ARRMOTH(JJ))THEN
                  BRR(JJ,II)=BR(II)
                  IF(II.LT.IMIN(JJ))IMIN(JJ)=II
                  IF(II.GT.IMAX(JJ))IMAX(JJ)=II
               ENDIF
            ENDDO
         ENDDO

         SYSPIN=.TRUE.
         DO JJ=1,NMOTH
            DO II=1,NUMDM
               DO KK=II+1,NUMDM
                  SUMBR(JJ,II)=SUMBR(JJ,II)+BRR(JJ,KK)
               ENDDO
               IF(NBODIES(II).EQ.3)THREEB=.TRUE.
               IF(NBODIES(II).EQ.4)FOURB=.TRUE.
               IF(MEDEC(II).EQ.0)SYSPIN=.FALSE.
               IF(ARRMOTH(JJ).EQ.IMOTH(II))THEN
                  IF(II.EQ.IMAX(JJ).OR.II.EQ.IMIN(JJ))THEN
                     CONTINUE
                  ELSE
                     BRR(JJ,II)=BRR(JJ,II)/(1-SUMBR(JJ,II))
                  ENDIF
                  CALL HWMODK(IMOTH(II),BRR(JJ,II),MEDEC(II),
     &                    IDAUGHT(II,1),IDAUGHT(II,2),IDAUGHT(II,3),
     &                    IDAUGHT(II,4),IDAUGHT(II,5))
               ENDIF
            ENDDO
         ENDDO
      ENDIF
C---EVENTS ARE NORMALIZED TO SUM OR AVERAGE TO THE TOTAL CROSS SECTION
      WRITE(*,*)'How are the events normalized ("average" or "sum")?'
      READ(*,*)NORM_EVENT
      if (NORM_EVENT.eq.'average')MQQ=1

      MSFLAG=0
      IF (LHSOFT) THEN
C---ATLAS JIMMY tune AUET2 (ATL-PHYS-PUB-2011-008, table 13)
         PRRAD=2.339D0
         PTJIM0=3.696D0
         EXPONT=0.219D0
C---AUET2 fixed parameters
         ISPAC=2
         PTRMS=1.2d0
         QSPAC=2.5d0
C---Beam 1/radii (assumed proton or antiproton)
         JMU2=PRRAD
         JMV2=PRRAD
C---Minimum PT of secondary scatters
         PTJIM=PTJIM0*(PBEAM1*PBEAM2/8.1D5)**(EXPONT/2)
C---Turn MI on(1) or off(0)
         MSFLAG=1
         CALL JMINIT
      ENDIF

C---INITIALISE ELEMENTARY PROCESS
      CALL HWEINI
C---USER'S INITIAL CALCULATIONS
      CALL HWABEG
C---LOOP OVER EVENTS
      DO 100 N=1,MAXEV
C---INITIALISE EVENT
         CALL HWUINE
C---GENERATE HARD SUBPROCESS
         CALL HWEPRO
C---GENERATE PARTON CASCADES
         CALL HWBGEN
C---  GENERATE MULTIPARTON INTERACTIONS
         IF (MSFLAG.EQ.1) THEN
            CALL HWMSCT(ABORT)
            IF (ABORT) GOTO 50
         ENDIF
C---DO HEAVY OBJECT DECAYS
         CALL HWDHOB
c         CALL HWUDPR
C---DO CLUSTER FORMATION
         CALL HWCFOR
C---DO CLUSTER DECAYS
         CALL HWCDEC
C---DO UNSTABLE PARTICLE DECAYS
         CALL HWDHAD
C---DO HEAVY FLAVOUR HADRON DECAYS
         CALL HWDHVY
C---ADD SOFT UNDERLYING EVENT IF NEEDED
         CALL HWMEVT
C---FINISH EVENT
         CALL HWUFNE
C---USER'S EVENT ANALYSIS
         CALL HWANAL
         IF(MOD(NEVHEP,NSTEP).EQ.0) THEN
            WRITE(*,*)'# of events processed=',NEVHEP
c            CALL HWAEND
         ENDIF
 50      CONTINUE
  100 CONTINUE
C---TERMINATE ELEMENTARY PROCESS
      CALL HWEFIN
C     Finish off JIMMY
      IF (LHSOFT) CALL JMEFIN
C---USER'S TERMINAL CALCULATIONS
      WRITE(*,*)'# of events processed=',NEVHEP
      ENDOFRUN=.TRUE.
      CALL HWAEND
C---CLEAN EXIT IF USING ROOT; DUMMY OTHERWISE
      CALL RCLOS()
 999  STOP
      END


      program exec_lineform
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! LS MPA 2010
! main to call the lineform.f subroutine. Not conceived for "manual"
! use but to be called by line_form.pl perl script.

! units called
! fort.10 all the input quantities (see description below) - produced by ngcl.pl
! fort.14 output

! variables
! abudev(natom), real, varied abundances as passed to
! abvar, varied abundance read from fort.10
! abvele, integer, atmic number of varied abundance, read from fort.10
! flux_out, real(NWMAX), flux output
! glog, real, stellar gravity
! head_*, character, variuos variables storing header values.
! LF_CTRL, integer, input control bitmask. Is read from fort.10, already in decimal integer form.
! lf_status_out, integer, output lineform bitmask.
! linefile, character*12, parameter set at "linedata.dat" is the local name for the line file. Linking to the
!                         actual file is handled by launching script.
! masw, misw, real, minimum,maximum stepwidth
! ewidth - equivalent width (NOT YET IN MAIN SIU)
! met, real, stellar logarythmic metallicity
! micro, real, stellar microturbulent velocity
! nhead_f, integer parameter, size of head_f_out
! nhead_i, integer parameter, size of head_i_out
! nwmax, integer, max number of wavelength/flux points in output
! nabvar, integer, number of abundance variations to be read from fort.10
! sw_crit, real, stepwidth criterium, read from unit 10
! teff, real, stellar effective temperature
! wlam_cnt_out, integer, number of pixels in output spectrum
! wlam_out, double (NWMAX), wavelengths for output
! wmax,wmin, real:
!                - start/end wavelength for computation (after call to lineform.f)
!                - central wavelength plus ion ID (e.g. 26.01)(before call to lineform.f)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!20100922 written
!20101001 Maria changed to fixed format
!20120802 many more changes
!
      implicit none
      real(kind=4) :: teff,glog,met,micro,wmin,wmax,abvar, wcenter
      real(kind=4) :: abudev,misw,masw,sw_crit,head_f_out
      real(kind=4) :: ewidth, cos_theta,wstep
      real(kind=4) :: wminnew, wmaxnew, excpot
      real(kind=8) :: wlam_out, flux_out, nunknown
      integer      :: nabvar,i,j,abvele,natom,lf_ctrl,lf_status_out
      integer      :: nhead_i,nhead_f,head_i_out,numwint

      integer(kind=8) :: wlam_cnt_out,NWMAX

      character(len=20)  :: head_atmuser,head_linuser
      character(len=30)  :: head_atmdate,head_lindate
      character(len=100) :: head_atmcmt,head_lincmt
      character(len=255) :: head_linref,head_atmref
      character(len=70)  :: linefile,ewout
      parameter(natom=92,linefile="linedata.dat",nhead_i=9)
!      parameter(NWMAX=1000000,numwint=1000)
      parameter(NWMAX=1000000,numwint=1)
!
!     parameter(natom=92,NWMAX=70000,nhead_i=9)
      parameter(nhead_f=194)
      dimension abudev(natom),head_i_out(nhead_i),head_f_out(nhead_f)
      dimension flux_out(NWMAX),wlam_out(NWMAX)
      dimension wminnew(NUMWINT),wmaxnew(NUMWINT)
      external lineform

! formats
  111 format("# teff, log g, met, micro")
  112 format("# ",f6.1,2x,f5.2,2x,f5.2,2x,f5.2)
  113 format("# wmin, wmax, min_sw, max_sw, sw_crit")
  114 format("# ",f15.4,2x,f10.4,2x,f6.4,2x,f6.4,2x,f5.2)
  115 format("# HEADER:")
  116 format("# ",A20)
  117 format("# ",A30)
  118 format("# ",A100)
  119 format("# ",A255)
  221 format("########################################################")
  222 format("# wave, flux")
  223 format(f15.4,4x,f9.6)                !for absolute fluxes -- e format
!  223 format(f15.4,4x,e12.4)
  224 format(A6,4x,f9.5)
  225 format(f9.2,A7,f6.2,A6,4x,i2,4x,f5.2,4x,f15.5)

!read in
      !linefile = '/afs/mpa/home/mbergema/siu/linedata/master_line.dat'
      !ewout ='/afs/mpa/home/mbergema/siu/ewgrid/results/nlte_ews.log'
      cos_theta = 1.0
      abudev=abudev*0.
      open(10,status='old')
      read(10,*)teff
      read(10,*)glog
      read(10,*)met
      read(10,*)micro
      read(10,*)wmin,wmax
      read(10,*)misw,masw
      read(10,*)lf_ctrl
      read(10,*)sw_crit
!from here on we read the abundance variations
      read(10,*)nabvar
      do i=1,nabvar
        read(10,*)abvele,abudev(abvele)
      enddo
      close(10)

      wcenter = wmin

      write(*,*) 'split wrange into ', numwint, ' sub-intervals'
      wstep = (wmax-wmin)/numwint
      wminnew(1) = wmin
      wmaxnew(1) = wmin+wstep
      do i=2,numwint
       wminnew(i) = wmaxnew(i-1)+0.001
       wmaxnew(i) = wmaxnew(i-1)+wstep
      enddo
      write(*,*) wmin, wmaxnew(numwint)

      open(14,status='unknown')
      write(14,111)
      write(14,112)teff,glog,met,micro
      write(14,113)
      write(14,114)wmin,wmax,misw,masw,sw_crit
      write(14,115)
!     write(14,116)head_atmuser   ! binary stuff
!      write(14,116)head_linuser
!     write(14,117)head_atmdate   ! binary stuff
!      write(14,117)head_lindate
!     write(14,118)head_atmcmt    ! binary
!      write(14,118)head_lincmt
!      write(14,119)head_atmref
!      write(14,119)head_linref
      write(14,221)
      write(14,222)

      call lineform(wmin,wmax,teff,glog,met,micro,cos_theta,abudev,
     &  lf_ctrl,sw_crit,misw,masw,linefile,lf_status_out,wlam_cnt_out,
     &  wlam_out,flux_out,ewidth,head_i_out,head_f_out, head_atmdate,
     &  head_atmuser,
     &  head_atmref,head_atmcmt,head_lindate,head_linuser,head_linref,
     &  head_lincmt, excpot)
       do i=1,wlam_cnt_out
        write(14,223)wlam_out(i),flux_out(i)
       enddo
      close(14)

!!!      do i=1,numwint
!!!        call lineform(wminnew(i),wmaxnew(i),teff,glog,met,micro,
!!!     &    cos_theta,abudev,
!!!     &    lf_ctrl,sw_crit,misw,masw,linefile,lf_status_out,wlam_cnt_out,
!!!     &    wlam_out,flux_out,ewidth,head_i_out,head_f_out, head_atmdate,
!!!     &    head_atmuser,head_atmref,head_atmcmt,
!!!     &    head_lindate,head_linuser,head_linref,head_lincmt)
!!!
!!!!        write(14,*) i, wminnew(i),wmaxnew(i)
!!!        write(14,223)wlam_out(1),flux_out(1)
!!!        do j=2,wlam_cnt_out
!!!         if (wlam_out(j).gt.wlam_out(j-1)) then
!!!          write(14,223)wlam_out(j),flux_out(j)
!!!         endif
!!!        enddo
!!!      enddo

       if (lf_ctrl.EQ.26247215.OR.lf_ctrl.EQ.30441519.OR.
     &     lf_ctrl.EQ.30507055.OR.lf_ctrl.EQ.30441517.OR.
     &     lf_ctrl.EQ.12615695.OR.lf_ctrl.EQ.17858607) then
         open(15,status='unknown')
         write(15,225) wcenter, ' Elow: ',
     &    excpot, ' NLTE: ', abvele,abudev(abvele),ewidth
         close(15)
       else
         open(16,status='unknown')
         write(16,225) wcenter, ' Elow: ',
     &    excpot, '  LTE: ', abvele,abudev(abvele),ewidth
         close(16)
       endif

      stop
      end
!TBD
!- irradiance is not handled right now, only flux.


      SUBROUTINE DIPIND (DIPVEC)
C...............................................................
C  MODIFICATION OF DIPOLE SUBROUTINE FOR USE IN THE CALUCLATION
C  OF THE INDUCED DIPOLES FOR POLARIZABILITIES.
C...............................................................
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON /CORE  / CORE(107)
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /KEYWRD/ KEYWRD
      COMMON /ISTOPE/ AMS(107)
      COMMON /MULTIP/ DD(107), QQ(107), AM(107), AD(107), AQ(107)
      DIMENSION Q(MAXORB),Q2(MAXORB),DIPVEC(3),CENTER(3),
     1          COORD(3,NUMATM)
      CHARACTER*80 KEYWRD
C
C***********************************************************************
C     DIPOLE CALCULATES DIPOLE MOMENTS
C
C  ON INPUT P     = DENSITY MATRIX
C           Q     = TOTAL ATOMIC CHARGES, (NUCLEAR + ELECTRONIC)
C           NUMAT = NUMBER OF ATOMS IN MOLECULE
C           NAT   = ATOMIC NUMBERS OF ATOMS
C           NFIRST= START OF ATOM ORBITAL COUNTERS
C           COORD = COORDINATES OF ATOMS
C
C  OUTPUT  DIPOLE = DIPOLE MOMENT
C***********************************************************************
C
C     IN THE ZDO APPROXIMATION, ONLY TWO TERMS ARE RETAINED IN THE
C     CALCULATION OF DIPOLE MOMENTS.
C     1. THE POINT CHARGE TERM (INDEPENDENT OF PARAMETERIZATION).
C     2. THE ONE-CENTER HYBRIDIZATION TERM, WHICH ARISES FROM MATRIX
C     ELEMENTS OF THE FORM <NS/R/NP>. THIS TERM IS A FUNCTION OF
C     THE SLATER EXPONENTS (ZS,ZP) AND IS THUS DEPENDENT ON PARAMETER-
C     IZATION. THE HYBRIDIZATION FACTORS (HYF(I)) USED IN THIS SUB-
C     ROUTINE ARE CALCULATED FROM THE FOLLOWING FORMULAE.
C     FOR SECOND ROW ELEMENTS <2S/R/2P>
C     HYF(I)= 469.56193322*(SQRT(((ZS(I)**5)*(ZP(I)**5)))/
C           ((ZS(I) + ZP(I))**6))
C     FOR THIRD ROW ELEMENTS <3S/R/3P>
C     HYF(I)=2629.107682607*(SQRT(((ZS(I)**7)*(ZP(I)**7)))/
C           ((ZS(I) + ZP(I))**8))
C     FOR FOURTH ROW ELEMENTS AND UP :
C     HYF(I)=2*(2.10716)*DD(I)
C     WHERE DD(I) IS THE CHARGE SEPARATION IN ATOMIC UNITS
C
C
C     REFERENCES:
C     J.A.POPLE & D.L.BEVERIDGE: APPROXIMATE M.O. THEORY
C     S.P.MCGLYNN, ET AL: APPLIED QUANTUM CHEMISTRY
C
      DIMENSION DIP(4,3)
      DIMENSION HYF(107,2)
      LOGICAL FIRST, FORCE, CHARGD
      DATA HYF(1,1)     / 0.0D00           /
      DATA   HYF(1,2) /0.0D0     /
      DATA   HYF(5,2) /6.520587D0/
      DATA   HYF(6,2) /4.253676D0/
      DATA   HYF(7,2) /2.947501D0/
      DATA   HYF(8,2) /2.139793D0/
      DATA   HYF(9,2) /2.2210719D0/
      DATA   HYF(14,2)/6.663059D0/
      DATA   HYF(15,2)/5.657623D0/
      DATA   HYF(16,2)/6.345552D0/
      DATA   HYF(17,2)/2.522964D0/
      DATA FIRST /.TRUE./
C
C  SETUP FOR DIPOLE CALCULATION
C
      CALL CHRGE (P,Q2)
      DO 10 I = 1,NUMAT
         L = NAT(I)
         Q(I) = CORE(L) - Q2(I)
   10 CONTINUE
      CALL GMETRY (GEO,COORD)
C
      IF (FIRST) THEN
         DO 20 I=2,107
   20    HYF(I,1)= 5.0832*DD(I)
         WTMOL=0.D0
         SUM=0.D0
         DO 30 I=1,NUMAT
            WTMOL=WTMOL+AMS(NAT(I))
   30    SUM=SUM+Q(I)
         CHARGD=(ABS(SUM).GT.0.5D0)
         FIRST=.FALSE.
         FORCE=(INDEX(KEYWRD,'FORCE') +INDEX(KEYWRD,'IRC').NE. 0)
         ITYPE=1
         IF(INDEX(KEYWRD,'MINDO') .NE. 0)ITYPE=2
      ENDIF
      IF(CHARGD)THEN
C
C   NEED TO RESET ION'S POSITION SO THAT THE CENTER OF MASS IS AT THE
C   ORIGIN.
C
         DO 40 I=1,3
   40    CENTER(I)=0.D0
         DO 50 I=1,3
            DO 50 J=1,NUMAT
   50    CENTER(I)=CENTER(I)+AMS(NAT(J))*COORD(I,J)
         DO 60 I=1,3
   60    CENTER(I)=CENTER(I)/WTMOL
         DO 70 I=1,3
            DO 70 J=1,NUMAT
   70    COORD(I,J)=COORD(I,J)-CENTER(I)
      ENDIF
      DO 80 I=1,4
         DO 80 J=1,3
   80 DIP(I,J)=0.0D00
      DO 100 I=1,NUMAT
         NI=NAT(I)
         IA=NFIRST(I)
         L=NLAST(I)-IA
         DO 90 J=1,L
            K=((IA+J)*(IA+J-1))/2+IA
   90    DIP(J,2)=DIP(J,2)-HYF(NI,ITYPE)*P(K)
         DO 100 J=1,3
  100 DIP(J,1)=DIP(J,1)+4.803D00*Q(I)*COORD(J,I)
      DO 110 J=1,3
  110 DIP(J,3)=DIP(J,2)+DIP(J,1)
      DO 120 J=1,3
  120 DIP(4,J)=SQRT(DIP(1,J)**2+DIP(2,J)**2+DIP(3,J)**2)
      DIPVEC(1)= -DIP(1,3)
      DIPVEC(2)= -DIP(2,3)
      DIPVEC(3)= -DIP(3,3)
      DIPCOM = DIP(4,3)
C      WRITE (6,60) ((DIP(I,J),I=1,4),J=1,3)
C   60 FORMAT (3(4F10.3))
      RETURN
C
      END


      subroutine coneq1_gdpm(ndummy, matnum, spec_num)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To compute the Jacobian and residual terms of the concentration
CD1 equation, except for multiply defined node connections.
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 05-17-93     G. Zyvoloski   00022   Initial implementation.
CD2
CD2 $Log:   /pvcs.config/fehm90/src/coneq1.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:44   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:07:50   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:48   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:58:46   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:08 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.17   Wed May 29 14:31:34 1996   hend
CD2 Added variable diffusion with water content
CD2
CD2    Rev 1.16   Fri May 24 09:52:12 1996   hend
CD2 Updated trac for mdnodes
CD2
CD2    Rev 1.15   Fri May 03 14:19:20 1996   hend
CD2 Updated for GAZ mdnodes changes
CD2 Vel and Disp. set to 0 for parent connections
CD2
CD2    Rev 1.14   Mon Apr 29 10:19:14 1996   hend
CD2 Updated to reflect GAZ changes -- all 3 sx components used
CD2
CD2    Rev 1.13   Thu Apr 25 13:32:20 1996   hend
CD2 Updated for use in long/trans dispersion option
CD2
CD2    Rev 1.12   Mon Mar 25 11:01:36 1996   hend
CD2 Fixed Indexing for Vapor Phase Velocities
CD2
CD2    Rev 1.11   Thu Mar 21 13:17:42 1996   hend
CD2 Fixed to use indexing independent of istrw
CD2
CD2    Rev 1.10   Mon Mar 04 16:06:28 1996   hend
CD2 Removed uneccessary calculations from coneq1 and added trac input option
CD2
CD2    Rev 1.9   Mon Jan 29 13:55:40 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.8   12/13/95 10:27:32   robinson
CD2 Streamlined calculation of dispersion and advection terms
CD2
CD2    Rev 1.7   09/29/95 16:12:16   llt
CD2 added small number on dividing -- was dividing by zero
CD2
CD2    Rev 1.6   09/11/95 17:29:22   awolf
CD2 Dispersion elipsoid for 3-d calculations added
CD2
CD2    Rev 1.6   08/29/95 08:41:08   awolf
CD2 Added elipsoidal representation of dispersivity for 3-D problems
CD2
CD2    Rev 1.5   08/16/95 16:23:24   robinson
CD2 Corrected dispersion calculation for 0 saturation case
CD2
CD2    Rev 1.4   08/14/95 16:15:42   awolf
CD2 Dispersion now allows (and requires) x,y,z components of alpha
CD2
CD2    Rev 1.3   08/07/95 10:59:18   awolf
CD2 Dispersion now calculated with internode velocities.
CD2 Uses same algorithm as in flxo based on a_axy terms
CD2
CD2    Rev 1.2   01/28/95 14:20:02   llt
CD2 modified for the revised reactive transport module
CD2
CD2    Rev 1.1   03/18/94 16:15:26   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:22:26   pvcs
CD2 original version in process of being certified
CD2
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 Name      Type        Description
CD3
CD3 i          I          Node number of the current concentration
CD3                       unknown being worked on
c changed 8/5/94  to incorporate coupling
CD3 matnum       int         The current submatrix number
CD3 spec_num     int         The current coupled species number
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 None
CD3
C**********************************************************************
CD4 Global Subprograms
CD4
CD4 Name            Type     Description
CD4 ss_trans         N/A     calculate source/sink for tracer
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 Identifier  Type     Description
CD4
CD4 Global Types
CD4
CD4 None
CD4
CD4 Global Variables
CD4
CD4                      COMMON
CD4 Identifier   Type    Block   Description
CD4
CD4 npn, sx1, pnx, pny, pnz, phi, pcp, s, displx, disply, displz,
CD4 dispvx, dispvy, dispvz, anl, anv, danl, danv, idualp, neq, nelm,
CD4 nelmdg, it8, it9, it10, it11, icnl, perml, permv, sx, igrav, grav,
CD4 t1, t2, t3, t4, t5, t5v, t6, t7, t8, t9, cord, dnwgta, upwgta, bp,
CD4 nrhs_sol, a, nmat_sol, awc, ayc, denci, dencj, rc, akc, drc, ps,
CD4 istrw,rolf, rovf
CD4
CD4 Global Subprograms
CD4
CD4 Name    Type     Description
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 Identifier   Type        Description
CD5
CD5 Local Types
CD5
CD5 None
CD5
CD5 Local Variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 itr          int         Solute unknown number
CD5 sx1d         real*8      Volume associated with the current node
CD5 dili         real*8      Liquid density
CD5 divi         real*8      Vapor density
CD5 anli         real*8      Liquid concentration
CD5 anlkb        real*8      Liquid concentration, connected node
CD5 anvi         real*8      Vapor concentration
CD5 anvkb        real*8      Vapor concentration
CD5 danli        real*8      Derivative of liquid concentration
CD5 danlkb       real*8      Derivative of liquid concentration
CD5 danvi        real*8      Derivative of vapor concentration
CD5 danvkb       real*8      Derivative of vapor concentration
CD5 anlri        real*8      Density times liquid concentration
CD5 anvri        real*8      Density times vapor concentration
CD5 danlri       real*8      Density times derivative of liquid
CD5                          concentration
CD5 danvri       real*8      Density times derivative of vapor
CD5                          concentration
CD5 icd          int         Integer index parameter
CD5 ii1          int         Integer index parameter
CD5 ii2          int         Integer index parameter
CD5 idg          int         Integer index parameter
CD5 iq           int         Integer index parameter
CD5 jmi          int         Integer index parameter
CD5 jml          int         Integer index parameter
CD5 jmia         int         Integer index parameter
CD5 jm           int         Do-loop index parameter
CD5 neqp1        int         Number of equations plus 1
CD5 ij           int         Do-loop index parameter
CD5 ij1          int         Integer index parameter
CD5 ij2          int         Integer index parameter
CD5 iz           int         Integer index parameter
CD5 kb           int         Integer index parameter
CD5 neighc       int         Integer index parameter
CD5 iw           int         Integer index parameter
CD5 sx2c         real*8      Real parameter used in calculation
CD5 sx3c         real*8      Real parameter used in calculation
CD5 sx4d         real*8      Real parameter used in calculation
CD5 sx4h         real*8      Real parameter used in calculation
CD5 sxzc         real*8      Real parameter used in calculation
CD5 radi         real*8      Parameter used in calculation
CD5 radkb        real*8      Parameter used in calculation
CD5 fid          real*8      Parameter used in calculation
CD5 fid1         real*8      Parameter used in calculation
CD5 axyd         real*8      Parameter used in calculation
CD5 axy          real*8      Parameter used in calculation
CD5 axyf         real*8      Parameter used in calculation
CD5 vxy          real*8      Parameter used in calculation
CD5 vxyf         real*8      Parameter used in calculation
CD5 dlaei        real*8      Derivative term used in calculation
CD5 dlaekb       real*8      Derivative term used in calculation
CD5 dvaei        real*8      Derivative term used in calculation
CD5 dvaekb       real*8      Derivative term used in calculation
CD5 heatc        real*8      Derivative term used in calculation
CD5 vxyd         real*8      Derivative term used in calculation
CD5 storage_term real*8      Derivative term used in calculation
CD5 iau          int         Integer index parameter
CD5 ial          int         Integer index parameter
CD5 kz           int         Integer index parameter
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
CD6 The following functions are carried out in this routine:
CD6
CD6   Compute parameters needed later in the routine;
CD6
CD6   In a loop over each node connected to the current node, the code
CD6   computes node numbers needed later in the calculation.
CD6
CD6   The code next decides whether the calculation is two-dimensional
CD6   or three-dimensional, and carries out advection term
CD6   calculations accordingly, looping over each node connected to
CD6   the current node.
CD6
CD6   The code next decides whether the solute is liquid or
CD6   vapor phase, and formulates the Jacobian terms and residual
CD6   terms by looping through each node connected to the current one,
CD6   and successively adding the corresponding advective or
CD6   dispersive term.
CD6
CD6   Next, the code adds the storage and source/sink (or chemical
CD6   reaction) terms to the Jacobian and residuals.
CD6
CD6   Finally, the code catches the special case of porosity of 0, and
CD6   sets terms accordingly before returning to the calling routine.
CD6
C**********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 None
CD7
C**********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8  Requirements from SDN: 10086-RD-2.20-00
CD8    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD8    FEHM Application Version 2.20
CD8
C**********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 2.3.4 Solute-transport equations
CD9
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See FEHMN SRS, MMS, and SDD
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN coneq1
CPS
CPS Compute terms used later in the calculation
CPS
CPS IF this node is a matrix node
CPS   Set parameter used later to indicate matrix node
CPS ELSE
CPS   Set parameter used later to indicate primary node
CPS ENDIF
CPS
CPS FOR each node connected to the current node
CPS
CPS   Compute node numbers used later
CPS
CPS   FOR each node connected to this node
CPS     IF this node is the current node
CPS       Set parameter accordingly
CPS     ENDIF
CPS
CPS   ENDFOR
CPS
CPS ENDFOR
CPS
CPS IF this is a 3-D simulation
CPS
CPS   FOR each node connected to the current node
CPS     Compute average permeability and dispersion coefficient
CPS   ENDFOR
CPS
CPS ELSE this is a 2-D simulation
CPS
CPS   FOR each node connected to the current node
CPS     Compute average permeability and dispersion coefficient
CPS   ENDFOR
CPS
CPS ENDIF
CPS
CPS IF this is a liquid phase or Henry's Law solute
CPS
CPS   FOR each node connected to the current node
CPS     Compute liquid advection term
CPS   ENDFOR
CPS
CPS
CPS   FOR each node connected to the current node
CPS     Compute upwinding term
CPS   ENDFOR
CPS
CPS
CPS   FOR each node connected to the current node
CPS     Formulate Jacobian and residual terms of the current equation
CPS   ENDFOR
CPS
CPS   FOR each node connected to the current node
CPS     Compute dispersion term, add contribution to Jacobian and...
CPS     ... residual for liquid
CPS   ENDFOR
CPS ENDIF
CPS IF this is a vapor phase or Henry's law solute
CPS
CPS   FOR each node connected to the current node
CPS     Compute vopor advection term
CPS   ENDFOR
CPS
CPS
CPS   FOR each node connected to the current node
CPS     Compute upwinding term
CPS   ENDFOR
CPS
CPS
CPS   FOR each node connected to the current node
CPS     Formulate Jacobian and residual terms of the current equation
CPS   ENDFOR
CPS
CPS   FOR each node connected to the current node
CPS     Compute dispersion term, add contribution to Jacobian and...
CPS     ... residual for vapor
CPS   ENDFOR
CPS
CPS ENDIF
c changed 8/4/94 to allow for automatic adjustment of the rate
c constants  (move to new routine react_add.f
CPS IF the porosity of this node is 0
CPS   Set Jacobian term to keep equation set well-behaved
CPS ENDIF
CPS
CPS
CPS END coneq1
CPS
C**********************************************************************
c generate tracer equations
c
      use comflow
      use comcouple
      use comrxni
      use davidi
      use comji
      use comfi
      use comgi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      use comxi
      implicit none

      integer i,itr,icd,ii1,ii2,idg,iq,jmi,jml,jmia,jm,neqp1,ij
      integer ij1,ij2,iz,kb,neighc,iau,ial,kz, insp, kbnsp
      integer matnum,spec_num,ndummy,nmatavw,nmat2avw, nmatadd
      integer open_file, iwvfile
      real*8 sx1d,dili,divi,anli,anlkb,anvi,danli,danlkb,danvi
      real*8 sx3c,sxzc,anlri,anvri,danlri,danvri,sx2c,radi
      real*8 radkb,fid,fid1,axyd,axy,axyf,storage_term,dlaei
      real*8 dlaekb,heatc,vxyd,vxy,vxyf,anvkb,danvkb,dvaei
      real*8 t7wv(5000), t8wv(5000), t9wv(5000)
      real*8 dvaekb,toldil
      real*8 dvafi, dvafkb, anvi_wv, anvkb_wv, danvi_wv, danvkb_wv
      parameter(toldil = 1.d-20)
      real*8 slx2tt,svx2tt,tempx,tempy,tempz,templength,dispxavw
      real*8 dispzavw,alphaavw,axyflow,vxyflow,dilfkb,divfkb
      real*8 dilfi,divfi,dispyavw
      real*8 vmag,thetav,cord1x,cord1y,cord2x,cord2y,cord2xp,cord2yp
      real*8 cord1z,cord2z,newx,newy,newz,newdiff,concadiff,satr,satrkb
      real*8 rc_ss,drc_ss, pnxdum, pnydum, pnzdum

      real*8 newdiffkb, dumi, dumkb, dum_bar

      integer strindex,endindex,sehindexl,sehindexv
      integer pntr
      character*120 fname, root
      character*7 fsuffix
      integer iroot
      logical found_name, null1

      save t7wv, t8wv, t9wv, fname, found_name

c     Now called from ss_trans
c      call userc(1)
      if (ndummy.eq.0) then
         nmat_sol(1)=0
         nrhs_sol(1)=0
         strindex=1
         endindex=neq
         sehindexl=1
         sehindexv=1
      else if (ndummy.eq.neq) then
c         nmat_sol(1)=nmatb(4)
c         nrhs_sol(1)=nrhs(2)
         strindex=neq+1
         endindex=n0
         sehindexl=(sehsize/2)+1
         sehindexv=(sehsize/2)+1
      endif

      call dvacalc

      do i=strindex,endindex
         if (dispsame .eq. 0) then
            insp = i + (nsp - 1) * neq
         else
            insp = i
         end if
         itr=i+npn
         sx1d=sx1(i)
         dili=dil(i)
         anli=anl(itr)
         danli=danl(itr)
         anlri=anli*rolf(i)
         danlri=danli*rolf(i)
         if (irdof .ne. 13) then
            divi=div(i)
            anvi=anv(itr)
            danvi=danv(itr)
            anvri=anvi*rovf(i)
            danvri=danvi*rovf(i)
         else
            divi=0.
            anvi=0.
            danvi=0.
            anvri=0.
            danvri=0.
         end if
         if (irdof .ne. 13 .or. ifree .ne. 0) then
            satr = s(i)
         else
            satr = 1.d0
         end if

         neqp1=neq+1
         nmatavw = nelm(neqp1)-neqp1
         nmat2avw = 2*nmatavw
         if(i.gt.neq.and.idualp.eq.0) then
            icd=neq
            nmatadd = nmatavw
         else
            icd=0
            nmatadd = 0
         endif
         iz=i-icd

         ii1=nelm(iz)+1
         ii2=nelm(iz+1)
         idg=nelmdg(iz)-ii1+1
         iq=0
         jmi=nelmdg(iz)
         jmia=jmi-neqp1
         do jm=jmi+1,ii2
            iq=iq+1
            it10(iq)=istrw(jm-neqp1)
            if (sx(it10(iq),isox)+sx(it10(iq),isoy)+sx(it10(iq),isoz)
     &           .eq.0.) then
               iq=iq-1
            else
               it8(iq)=nelm(jm)+icd
               it9(iq)=jm-ii1+1
               it11(iq)=jm-neqp1
               ij1=nelm(nelm(jm))+1
               ij2=nelmdg(nelm(jm))-1
               do ij=ij1,ij2
                  if(nelm(ij).eq.iz) it12(iq)=ij-neqp1
               enddo
            endif
         enddo

         if(icns(nsp).eq.1.or.abs(icns(nsp)).eq.2) then

c-------------------------------------- PHS 9/2/2004
c   moving call for node i and calc of dumi to top of loop
c----------------------------------------------------
            if (dispsame .eq. 0) then
               newdiff = concadiff(1,mflagl(nsp,itrc(insp)),
     &              diffmfl(nsp,itrc(insp)),ps(i),satr,phi(i),t(i))
            else
               newdiff = concadiff(1,mflagl(1,itrcdsp(insp)),
     &              sehdiff(itrcdsp(insp)),ps(i),satr,phi(i),t(i))
            endif
            dumi  = satr*newdiff*ps(i)

c
c     liquid phase calculations
c
c     Find mass flux, upwind direction, compute term used later (liquid)
c
            do jm = 1, iq
               kb = it8(jm)
               iau=it11(jm)
               neighc=it9(jm)
               if(filter_flag(spec_num).eq.0) then
                 t8(neighc) = a_axy(iau+nmatadd)
               else
                 t8(neighc) = ftn_factor(istrw_cold(iau))*
     2                       a_axy(iau+nmatadd)
               endif
               fid = 0.5
               if(t8(neighc).lt.0.0) then
                  fid=dnwgta
                  fid1 = 1.-fid
                  t7(neighc) = fid*dil(kb)
                  t9(neighc) = fid1*dili
               elseif(t8(neighc).gt.0.) then
                  fid=upwgta
                  fid1 = 1.-fid
                  t7(neighc) = fid*dil(kb)
                  t9(neighc) = fid1*dili
               else
                  t7(neighc) = toldil
                  t9(neighc) = toldil
               end if
            enddo

c
c     Add advection terms (liquid) to residual and Jacobian
c
c     dir$ ivdep
            do jm=1,iq
               kb=it8(jm)
               kbnsp = kb + (nsp - 1) * neq
               kz=kb-icd
               neighc=it9(jm)
               iau=it11(jm)
               ial=it12(jm)
               jml=nelmdg(kz)-neqp1
               dilfi=t9(neighc)
               dilfkb=t7(neighc)
               anlkb=anl(kb+npn)
               danlkb=danl(kb+npn)
               axyflow = t8(neighc)
               axyd = axyflow/(dilfkb+dilfi)
               axyf=(dilfkb*anlkb+dilfi*anli)
               axy=axyd*axyf
               dlaei=axyd*dilfi*danli
               dlaekb=axyd*dilfkb*danlkb
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))+axy
               bp(kz+nrhs_sol(spec_num))=bp(kz+nrhs_sol(spec_num))-axy
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+dlaei
               a(ial+nmat_sol(matnum))=a(ial+nmat_sol(matnum))-dlaei
               a(iau+nmat_sol(matnum))=a(iau+nmat_sol(matnum))+dlaekb
               a(jml+nmat_sol(matnum))=a(jml+nmat_sol(matnum))-dlaekb
            enddo

c
c     Formulate dispersion term (liquid) - different models for
c     2 and 3 d (3D is icnl=0)
c
            if (dispsame.eq.0) then
               if(icnl.eq.0) then
                  vmag=sqrt(pnx(n+i)*pnx(n+i)+
     +                 pny(n+i)*pny(n+i)+pnz(n+i)*pnz(n+i))
                  if (vmag.eq.0.) then
                     vmag=1e-30
                     pnxdum = 1e-30
                     pnydum = 0.
                     pnzdum = 0.
                  else
                     pnxdum = pnx(n+i)
                     pnydum = pny(n+i)
                     pnzdum = pnz(n+i)
                  end if
                  do jm=1,iq
                     kb=it8(jm)
                     kbnsp = kb + (nsp - 1) * neq
                     if (irdof .ne. 13) then
                        satrkb = s(kb)
                     else
                        satrkb = 1.0
                     end if
c------- PHS ---------- 9/3/2004 -----------------------------
                     newdiffkb = concadiff(1,mflagl(nsp,itrc(kbnsp)),
     &                    diffmfl(nsp,itrc(kbnsp)),ps(kb),satrkb,
     &                    phi(kb),t(kb))

                     dumkb = satrkb*newdiffkb*ps(kb)
                     dum_bar = 2*dumi*dumkb/(dumi+dumkb)
           if (i.le.neq_primary.and.kb.gt.neq_primary) then
	       dum_bar = dumkb
	     else if (i.gt.neq_primary.and.kb.le.neq_primary) then
	       dum_bar = dumi
           endif
c------- PHS ---------- 9/3/2004 -----------------------------

                     kz=kb-icd
                     neighc=it9(jm)
                     iw=it10(jm)
                     sx2c=sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
c                    sx3c=sx(iw,2)
c                    sxzc=sx(iw,3)
                     if (ldsp.eq.0) then
                        cord1x=cord(iz,1)
                        cord1y=cord(iz,2)
                        cord1z=cord(iz,3)
                        cord2x=cord(kz,1)
                        cord2y=cord(kz,2)
                        cord2z=cord(kz,3)
                        dispxavw = tclx(nsp,itrc(insp))
                        dispyavw = tcly(nsp,itrc(insp))
                        dispzavw = tclz(nsp,itrc(insp))
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        tempz = (cord1z-cord2z)**2
                        templength=tempx+tempy+tempz
                        alphaavw=sqrt((dispxavw*dispyavw*dispzavw*
     +                       templength)/
     2                       (dispyavw*dispzavw*tempx +
     3                       dispxavw*dispzavw*tempy +
     4                       dispxavw*dispyavw*tempz) )
c------- PHS ---------- 9/3/2004 -----------------------------

                        slx2tt = sx2c*(sehvell(sehindexl)*alphaavw +
     &                       dum_bar)
c--------------------------------------------------------------------
                        sehindexl=sehindexl+1
                     else
                        call rotate(cord(iz,1),cord(iz,2),cord(iz,3),
     +                       pnxdum,pnydum,
     +                       pnzdum,
     +                       cord(kz,1),cord(kz,2),cord(kz,3)
     +                       ,newx,newy,newz)
                        cord1x=0.
                        cord1y=0.
                        cord1z=0.
                        cord2x=newx
                        cord2y=newy
                        cord2z=newz
                        dispxavw=tcly(nsp,itrc(insp))
                        dispyavw=tcly(nsp,itrc(insp))
                        dispzavw=tclx(nsp,itrc(insp))
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        tempz = (cord1z-cord2z)**2
                        templength=tempx+tempy+tempz
                        alphaavw = sqrt((dispxavw*dispyavw*dispzavw*
     +                       templength)/
     2                       (dispyavw*dispzavw*tempx +
     3                       dispxavw*dispzavw*tempy +
     4                       dispxavw*dispyavw*tempz) )
c------- PHS ---------- 9/3/2004 -----------------------------
                        slx2tt = sx2c*((vmag*alphaavw)+dum_bar)
c--------------------------------------------------------------------
                     endif
                     t5(neighc)=slx2tt
                  enddo
               else
                  radi=cord(iz,3)
                  vmag=sqrt(pnx(n+i)*pnx(n+i)+pny(n+i)*pny(n+i))
                  if (vmag.eq.0.) vmag=1e-30
                  thetav=acos(pnx(n+i)/vmag)
                  do jm=1,iq
                     kb=it8(jm)
                     kbnsp = kb + (nsp - 1) * neq
                     if (irdof .ne. 13) then
                        satrkb = s(kb)
                     else
                        satrkb = 1.0
                     end if
c------- PHS ---------- 9/3/2004 -----------------------------
                     newdiffkb = concadiff(1,mflagl(nsp,itrc(kbnsp)),
     &                    diffmfl(nsp,itrc(kbnsp)),ps(kb),satrkb,
     &                    phi(kb),t(kb))
                     dumkb = satrkb*newdiffkb*ps(kb)
                     dum_bar = 2*dumi*dumkb/(dumi+dumkb)
           if (i.le.neq_primary.and.kb.gt.neq_primary) then
	       dum_bar = dumkb
	     else if (i.gt.neq_primary.and.kb.le.neq_primary) then
	       dum_bar = dumi
           endif
c------- PHS ---------- 9/3/2004 -----------------------------
                     kz=kb-icd
                     neighc=it9(jm)
                     iw=it10(jm)
                     radkb=0.5*(radi+cord(kz,3))
                     sx2c=radkb*(sx(iw,isox)+sx(iw,isoy))
c                    sx3c=radkb*sx(iw,2)
                     if (ldsp.eq.0) then
                        cord1x=cord(iz,1)
                        cord1y=cord(iz,2)
                        cord2x=cord(kz,1)
                        cord2y=cord(kz,2)
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        dispxavw = tclx(nsp,itrc(insp))
                        dispyavw = tcly(nsp,itrc(insp))
                        alphaavw = sqrt((dispxavw*dispyavw *
     +                       (tempx+tempy))/
     &                       (dispxavw*tempy + dispyavw*tempx ))
c----------------- PHS ------- 9/3/2004 -----------------------------
                        slx2tt = sx2c*(sehvell(sehindexl)*alphaavw +
     &                       dum_bar)
c--------------------------------------------------------------------
                        sehindexl=sehindexl+1
                     else
                        cord1x=0.
                        cord1y=0.
                        cord2xp=cord(kz,1)-cord(iz,1)
                        cord2yp=cord(kz,2)-cord(iz,2)
                        cord2x=
     +                       cos(thetav)*cord2xp-sin(thetav)*cord2yp
                        cord2y=
     +                       sin(thetav)*cord2xp+cos(thetav)*cord2yp
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        dispxavw = tclx(nsp,itrc(insp))
                        dispyavw = tcly(nsp,itrc(insp))
                        alphaavw = sqrt((dispxavw*dispyavw *
     +                       (tempx+tempy))/
     &                       (dispxavw*tempy + dispyavw*tempx ))
c----------------------------- 9/3/2004 -----------------------------
                        slx2tt = sx2c*(vmag*alphaavw+dum_bar)
c--------------------------------------------------------------------
                     endif
                     t5(neighc)=slx2tt
                  enddo
               end if
            endif

c
c     add dispersion term for liquid - 2 and 3d are the same
c     at this point
c
c     dir$ ivdep
            do jm=1,iq
               kb=it8(jm)
               kbnsp = kb + (nsp - 1) * neq
               kz=kb-icd
               neighc=it9(jm)
               iau=it11(jm)
               ial=it12(jm)
               jml=nelmdg(kz)-neqp1
               iw=it10(jm)
               if (dispsame.eq.1) then
                 if(filter_flag(spec_num).eq.0) then
                  heatc=sehvell(sehindexl)
                 else
                  heatc=ftn_factor(istrw_cold(iau))*sehvell(sehindexl)
                 endif
                  sehindexl=sehindexl+1
               else
                 if(filter_flag(spec_num).eq.0) then
                  heatc=t5(neighc)
                 else
                  heatc=ftn_factor(istrw_cold(iau))*t5(neighc)
                 endif
               endif
               axy=heatc*(anl(kb+npn)*rolf(kb)-anlri)
               dlaei=-heatc*danlri
               dlaekb=heatc*rolf(kb)*danl(kb+npn)
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))+axy
               bp(kz+nrhs_sol(spec_num))=bp(kz+nrhs_sol(spec_num))-axy
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+dlaei
               a(ial+nmat_sol(matnum))=a(ial+nmat_sol(matnum))-dlaei
               a(iau+nmat_sol(matnum))=a(iau+nmat_sol(matnum))+dlaekb
               a(jml+nmat_sol(matnum))=a(jml+nmat_sol(matnum))-dlaekb
            enddo
         endif

**** Henry law addition ****
         if (icns(nsp).eq.-1.or.abs(icns(nsp)).eq.2) then

c----------------- PHS ------- 9/3/2004 -----------------------------
            if (dispsame .eq. 0) then
               newdiff = concadiff(2,mflagv(nsp,itrc(insp)),
     &              diffmfv(nsp,itrc(insp)),ps(i),satr,phi(i),t(i))
            else
               newdiff = concadiff(2,mflagv(1,itrcdsp(insp)),
     &              sehdiffv(itrcdsp(insp)),ps(i),satr,phi(i),t(i))
            endif
            dumi  = (1-satr) *newdiff*ps(i)
c-----------------------------------------------------------------

c
c     vapor phase calculations
c
c     Find mass flux, upwind direction, compute term used later (vapor)
c
            do jm = 1, iq
               kb = it8(jm)
               iau=it11(jm)
               neighc=it9(jm)
               t8(neighc) = a_vxy(iau+nmatadd)
               fid = 0.5
               if(t8(neighc).lt.0.0) then
                  fid=dnwgta
                  fid1 = 1.-fid
                  t7(neighc) = fid*div(kb)
                  t9(neighc) = fid1*divi
               elseif(t8(neighc).gt.0.) then
                  fid=upwgta
                  fid1 = 1.-fid
                  t7(neighc) = fid*div(kb)
                  t9(neighc) = fid1*divi
               else
                  t7(neighc) = toldil
                  t9(neighc) = toldil
               end if
            enddo
c
c     Add advection terms (vapor) to residual and Jacobian
c
c     dir$ ivdep
            do jm=1,iq
               kb=it8(jm)
               kbnsp = kb + (nsp - 1) * neq
               kz=kb-icd
               neighc=it9(jm)
               iau=it11(jm)
               ial=it12(jm)
               jml=nelmdg(kz)-neqp1
               divfi=t9(neighc)
               divfkb=t7(neighc)
               anvkb=anv(kb+npn)
               danvkb=danv(kb+npn)
               vxyflow = t8(neighc)
               vxyd = vxyflow/(divfkb+divfi)
               vxyf=(divfkb*anvkb+divfi*anvi)
               vxy=vxyd*vxyf
               dvaei=vxyd*divfi*danvi
               dvaekb=vxyd*divfkb*danvkb
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))+vxy
               bp(kz+nrhs_sol(spec_num))=bp(kz+nrhs_sol(spec_num))-vxy
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+dvaei
               a(ial+nmat_sol(matnum))=a(ial+nmat_sol(matnum))-dvaei
               a(iau+nmat_sol(matnum))=a(iau+nmat_sol(matnum))+dvaekb
               a(jml+nmat_sol(matnum))=a(jml+nmat_sol(matnum))-dvaekb
            enddo
c
c     Formulate dispersion term (vapor) - different models for
c     2 and 3 d (3D is icnl=0)
c
            if (dispsame.eq.0) then
               if(icnl.eq.0) then
                  vmag=sqrt(pnx(n*2+i)*pnx(n*2+i)+
     +                 pny(n*2+i)*pny(n*2+i)+pnz(n*2+i)*pnz(n*2+i))
                  if (vmag.eq.0.) then
                     vmag=1e-30
                     pnxdum = 1e-30
                     pnydum = 0.
                     pnzdum = 0.
                  else
                     pnxdum = pnx(n*2+i)
                     pnydum = pny(n*2+i)
                     pnzdum = pnz(n*2+i)
                  end if
                  do jm=1,iq
                     kb=it8(jm)
                     kbnsp = kb + (nsp - 1) * neq
                     satrkb = s(kb)
c----------------- PHS ------- 9/3/2004 -----------------------------
                     newdiffkb = concadiff(2,mflagv(nsp,itrc(kbnsp)),
     &                    diffmfv(nsp,itrc(kbnsp)),ps(kb),satrkb,
     &                    phi(kb),t(kb))
                     dumkb = (1-satrkb)*newdiffkb*ps(kb)
                     dum_bar = 2*dumi*dumkb/(dumi+dumkb)
	     if (i.le.neq_primary.and.kb.gt.neq_primary) then
	       dum_bar = dumkb
	     else if (i.gt.neq_primary.and.kb.le.neq_primary) then
	       dum_bar = dumi
           endif
c-----------------------------------------------------------------
                     kz=kb-icd
                     neighc=it9(jm)
                     iw=it10(jm)
                     sx2c=sx(iw,isox) + sx(iw,isoy) + sx(iw,isoz)
c                    sx3c=sx(iw,2)
c                    sxzc=sx(iw,3)
                     if (ldsp.eq.0) then
                        cord1x=cord(iz,1)
                        cord1y=cord(iz,2)
                        cord1z=cord(iz,3)
                        cord2x=cord(kz,1)
                        cord2y=cord(kz,2)
                        cord2z=cord(kz,3)
                        dispxavw = tcvx(nsp,itrc(insp))
                        dispyavw = tcvy(nsp,itrc(insp))
                        dispzavw = tcvz(nsp,itrc(insp))
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        tempz = (cord1z-cord2z)**2
                        templength=tempx+tempy+tempz
                        alphaavw = sqrt((dispxavw*dispyavw*dispzavw*
     +                       templength)/
     2                       (dispyavw*dispzavw*tempx +
     3                       dispxavw*dispzavw*tempy +
     4                       dispxavw*dispyavw*tempz) )
c----------------- PHS ------- 9/3/2004 -----------------------------
                        svx2tt = sx2c*(sehvelv(sehindexv)*alphaavw+
     &                        dum_bar)
c--------------------------------------------------------------------
                     else
                        call rotate(cord(iz,1),cord(iz,2),cord(iz,3),
     +                       pnxdum,pnydum,
     +                       pnzdum,
     +                       cord(kz,1),cord(kz,2),cord(kz,3)
     +                       ,newx,newy,newz)
                        cord1x=0.
                        cord1y=0.
                        cord1z=0.
                        cord2x=newx
                        cord2y=newy
                        cord2z=newz
                        dispxavw=tcvy(nsp,itrc(insp))
                        dispyavw=tcvy(nsp,itrc(insp))
                        dispzavw=tcvx(nsp,itrc(insp))
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        tempz = (cord1z-cord2z)**2
                        templength=tempx+tempy+tempz
                        alphaavw = sqrt((dispxavw*dispyavw*dispzavw*
     +                       templength)/
     2                       (dispyavw*dispzavw*tempx +
     3                       dispxavw*dispzavw*tempy +
     4                       dispxavw*dispyavw*tempz) )
c----------------- PHS ------- 9/3/2004 -----------------------------
                        svx2tt = sx2c * (vmag*alphaavw+dum_bar)
c--------------------------------------------------------------------
                     endif
                     t5v(neighc)=svx2tt
                  enddo
               else
                  radi=cord(iz,3)
                  vmag=sqrt(pnx(n*2+i)*pnx(n*2+i)+
     +                 pny(n*2+i)*pny(n*2+i))
                  if (vmag.eq.0.) vmag=1e-30
                  thetav=acos(pnx(n*2+i)/vmag)
                  do jm=1,iq
                     kb=it8(jm)
                     kbnsp = kb + (nsp - 1) * neq
                     satrkb = s(kb)
c----------------- PHS ------- 9/3/2004 -----------------------------
                     newdiffkb = concadiff(2,mflagv(nsp,itrc(kbnsp)),
     &                    diffmfv(nsp,itrc(kbnsp)),ps(kb),satrkb,
     &                    phi(kb),t(kb))
                     dumkb = (1-satrkb)*newdiffkb*ps(kb)
                     dum_bar = 2*dumi*dumkb/(dumi+dumkb)
           if (i.le.neq_primary.and.kb.gt.neq_primary) then
	       dum_bar = dumkb
	     else if (i.gt.neq_primary.and.kb.le.neq_primary) then
	       dum_bar = dumi
           endif
c-----------------------------------------------------------------
                     kz=kb-icd
                     neighc=it9(jm)
                     iw=it10(jm)
                     radkb=0.5*(radi+cord(kz,3))
                     sx2c=radkb*(sx(iw,isox)+sx(iw,isoy))
c                    sx3c=radkb*sx(iw,2)
                     if (ldsp.eq.0) then
                        cord1x=cord(iz,1)
                        cord1y=cord(iz,2)
                        cord2x=cord(kz,1)
                        cord2y=cord(kz,2)
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        dispxavw = tcvx(nsp,itrc(insp))
                        dispyavw = tcvy(nsp,itrc(insp))
                        alphaavw =sqrt((dispxavw*dispyavw *
     +                       (tempx+tempy))/
     &                       (dispxavw*tempy + dispyavw*tempx ))
c----------------- PHS ------- 9/3/2004 -----------------------------
                        svx2tt = sx2c*(sehvelv(sehindexv)*alphaavw+
     &                        dum_bar)
c--------------------------------------------------------------------
                        sehindexv=sehindexv+1
                     else
                        cord1x=0.
                        cord1y=0.
                        cord2xp=cord(kz,1)-cord(iz,1)
                        cord2yp=cord(kz,2)-cord(iz,2)
                        cord2x=
     +                       cos(thetav)*cord2xp-sin(thetav)*cord2yp
                        cord2y=
     +                       sin(thetav)*cord2xp+cos(thetav)*cord2yp
                        tempx = (cord1x-cord2x)**2
                        tempy = (cord1y-cord2y)**2
                        dispxavw = tcvx(nsp,itrc(insp))
                        dispyavw = tcvy(nsp,itrc(insp))
                        alphaavw =sqrt((dispxavw*dispyavw *
     +                       (tempx+tempy))/
     &                       (dispxavw*tempy + dispyavw*tempx ))
c----------------- PHS ------- 9/3/2004 -----------------------------
                        svx2tt = sx2c * (vmag*alphaavw+dum_bar)
c--------------------------------------------------------------------
                     endif
                     t5v(neighc)=svx2tt
                  enddo
               end if
            endif
c
c     add dispersion term for vapor - 2 and 3D are the same
c     at this point
c
c     dir$ ivdep
            do jm=1,iq
               kb=it8(jm)
               kbnsp = kb + (nsp - 1) * neq
               kz=kb-icd
               neighc=it9(jm)
               iau=it11(jm)
               ial=it12(jm)
               jml=nelmdg(kz)-neqp1
               iw=it10(jm)
               if (dispsame.eq.0) then
                  heatc=t5v(neighc)
               else
                  heatc=sehvelv(sehindexv)
                  sehindexv=sehindexv+1
               endif
               vxy=heatc*(anv(kb+npn)*rovf(kb)-anvri)
               dvaei=-heatc*danvri
               dvaekb=heatc*rovf(kb)*danv(kb+npn)
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))+vxy
               bp(kz+nrhs_sol(spec_num))=bp(kz+nrhs_sol(spec_num))-vxy
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+dvaei
               a(ial+nmat_sol(matnum))=a(ial+nmat_sol(matnum))-dvaei
               a(iau+nmat_sol(matnum))=a(iau+nmat_sol(matnum))+dvaekb
               a(jml+nmat_sol(matnum))=a(jml+nmat_sol(matnum))-dvaekb
c---------------------------------Temp spot for dumping i-kb wvflow
c------------------   only for nsp=1
c
               if(tort.GT.666) then
                if((i.EQ.1).AND.(kb.EQ.2)) then
                   if (.not. found_name) then
                      if (null1(root_name)) then
                         if (nmfil(5) .ne. nmfily(3) .and.
     &                        nmfil(5) .ne. ' ') then
                            call file_prefix(nmfil(5), iroot)
                            if (iroot .gt. 100) iroot = 100
                            root(1:iroot) = nmfil(5)(1:iroot)
                         else
                            if (nmfil(2)(1:1) .eq. ' ' ) then
                               write (ierr, *)
     &                             'FILE ERROR: nmfil2 file: ',
     &                              nmfil(2), ' unable to determine ',
     &                              'wvflux file prefix'
                               stop
                            else
                               call file_prefix(nmfil(2), iroot)
                               if (iroot .gt. 100) iroot = 100
                               root(1:iroot) = nmfil(2)(1:iroot)
                            end if
                         end if
                      else
                         iroot = len_trim (root_name)
                         if (iroot .gt. 100) iroot = 100
                         root(1:iroot) = root_name(1:iroot)
                      end if
                      fsuffix = '.wvflux'
                      fname =  root(1:iroot) // fsuffix
                      found_name = .true.
                   end if
                   iwvfile = open_file(fname, 'unknown')
                   rewind iwvfile
                   write(iwvfile,*) 'cord(i,1) nodei nodekb wvflow(kg/s)
     &                  wvflow(kg/yr) wlflow(kg/s) wlflow(kg/yr)'
                end if
c----     --    - -  --  -    - -   -     -       -        -

                pntr = iau+nmatadd

                if(i.LT.kb) then
                write(iwvfile,*) cord(i,1), i, kb, a_wvxy(pntr),
     &           a_wvxy(pntr)*3.15e7,a_axy(pntr), a_axy(pntr)*3.15e7
                end if
               end if
c----------------------------------------------------------------
            enddo
c--------------------------------------------------------------------
c Add in Water Vapor Diffusion term  for Henrys 3 (Water Vapor Tracer)
c    PHS 3/24/2004
c Find mass flux, upwind direction, compute term used later Watervapor
c
c    Take out t8 t7 t9 terms  replace with t7wv t8wv t9wv
c--------------------------------------------------------------------
           if(a_henry(nsp).EQ.666.) then
            do jm = 1, iq
               kb = it8(jm)
               iau=it11(jm)
               neighc=it9(jm)
               t8wv(neighc) = a_wvxy(iau+nmatadd)
               fid = 0.5
               if(t8wv(neighc).lt.0.0) then
                  fid=dnwgta
                  fid1 = 1.-fid
                  t7wv(neighc) = fid*dva(kb)
                  t9wv(neighc) = fid1*dva(i)
               elseif(t8wv(neighc).gt.0.) then
                  fid=upwgta
                  fid1 = 1.-fid
                  t7wv(neighc) = fid*dva(kb)
                  t9wv(neighc) = fid1*dva(i)
               else
                  t7wv(neighc) = toldil
                  t9wv(neighc) = toldil
               end if
            enddo
c
c     Add Water Vapor Diffusion terms  to residual and Jacobian
c       also, make anv = (ptot/pv)*anv
c
c     dir$ ivdep
            anvi_wv = anvi/(1-cnvf(i))
            danvi_wv = danvi/(1-cnvf(i))
            do jm=1,iq
               kb=it8(jm)
               kbnsp = kb + (nsp - 1) * neq
               kz=kb-icd
               neighc=it9(jm)
               iau=it11(jm)
               ial=it12(jm)
               jml=nelmdg(kz)-neqp1
               dvafi=t9wv(neighc)
               dvafkb=t7wv(neighc)
               anvkb_wv=anv(kb+npn)/(1-cnvf(kb))
               danvkb_wv=danv(kb+npn)/(1-cnvf(kb))

               vxyflow = t8wv(neighc)
               vxyd = vxyflow/(dvafkb+dvafi)
               vxyf=(dvafkb*anvkb_wv+dvafi*anvi_wv)
               vxy=vxyd*vxyf
               dvaei=vxyd*dvafi*danvi_wv
               dvaekb=vxyd*dvafkb*danvkb_wv
               bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num))+vxy
               bp(kz+nrhs_sol(spec_num))=bp(kz+nrhs_sol(spec_num))-vxy
               a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+dvaei
               a(ial+nmat_sol(matnum))=a(ial+nmat_sol(matnum))-dvaei
               a(iau+nmat_sol(matnum))=a(iau+nmat_sol(matnum))+dvaekb
               a(jml+nmat_sol(matnum))=a(jml+nmat_sol(matnum))-dvaekb
            enddo
           end if
c
c            END OF NEW WATER VAPOR SPECIES  PHS 3/24/2004
c--------------------------------------------------------------------
c
         endif
         call ss_trans(i,rc_ss,drc_ss)
         storage_term = sx1d*(awc*denci(itr)+ayc*dencj(itr))
         bp(iz+nrhs_sol(spec_num))=bp(iz+nrhs_sol(spec_num)) +
     2        storage_term+rc_ss
         a(jmia+nmat_sol(matnum))=a(jmia+nmat_sol(matnum))+sx1d
     2        *awc*akc(itr)+drc_ss

      enddo

c------------------------- Temp set-up for dumping wvflow
      if(tort.EQ.666) close(iwvfile)
c---------------------------------------

      return
      end


      subroutine slss (wk, iwk, x, tem)
clll. optimize
      integer iwk
      integer iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     2   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     1   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     2   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     3   nslj, ngp, nlu, nnz, nsp, nzl, nzu
      integer i
      double precision wk, x, tem
      double precision rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      double precision rlss
      double precision di, hl0, phl0, r
      dimension wk(*), iwk(*), x(1), tem(1)
      common /ls0001/ rowns(209),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(14), iowns(6),
     4   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      common /lss001/ rlss(6),
     1   iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     2   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     3   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     4   nslj, ngp, nlu, nnz, nsp, nzl, nzu
c-----------------------------------------------------------------------
c this routine manages the solution of the linear system arising from
c a chord iteration.  it is called if miter .ne. 0.
c if miter is 1 or 2, it calls cdrv to accomplish this.
c if miter = 3 it updates the coefficient h*el0 in the diagonal
c matrix, and then computes the solution.
c communication with slss uses the following variables..
c wk    = real work space containing the inverse diagonal matrix if
c         miter = 3 and the lu decomposition of the matrix otherwise.
c         storage of matrix elements starts at wk(3).
c         wk also contains the following matrix-related data..
c         wk(1) = sqrt(uround) (not used here),
c         wk(2) = hl0, the previous value of h*el0, used if miter = 3.
c iwk   = integer work space for matrix-related data, assumed to
c         be equivalenced to wk.  in addition, wk(iprsp) and iwk(ipisp)
c         are assumed to have identical locations.
c x     = the right-hand side vector on input, and the solution vector
c         on output, of length n.
c tem   = vector of work space of length n, not used in this version.
c iersl = output flag (in common).
c         iersl = 0  if no trouble occurred.
c         iersl = -1 if cdrv returned an error flag (miter = 1 or 2).
c                    this should never occur and is considered fatal.
c         iersl = 1  if a singular matrix arose with miter = 3.
c this routine also uses other variables in common.
c-----------------------------------------------------------------------
      iersl = 0
      go to (100, 100, 300), miter
 100  call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),x,x,nsp,iwk(ipisp),wk(iprsp),iesp,4,iersl)
      if (iersl .ne. 0) iersl = -1
      return
c
 300  phl0 = wk(2)
      hl0 = h*el0
      wk(2) = hl0
      if (hl0 .eq. phl0) go to 330
      r = hl0/phl0
      do 320 i = 1,n
        di = 1.0d0 - r*(1.0d0 - 1.0d0/wk(i+2))
        if (dabs(di) .eq. 0.0d0) go to 390
 320    wk(i+2) = 1.0d0/di
 330  do 340 i = 1,n
 340    x(i) = wk(i+2)*x(i)
      return
 390  iersl = 1
      return
c
c----------------------- end of subroutine slss ------------------------
      end