odepack_sub1.f

*DECK DUMACH
      DOUBLE PRECISION FUNCTION dumach ()
C***BEGIN PROLOGUE  DUMACH
C***PURPOSE  Compute the unit roundoff of the machine.
C***CATEGORY  R1
C***TYPE      DOUBLE PRECISION (RUMACH-S, DUMACH-D)
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C *Usage:
C        DOUBLE PRECISION  A, DUMACH
C        A = DUMACH()
C
C *Function Return Values:
C     A : the unit roundoff of the machine.
C
C *Description:
C     The unit roundoff is defined as the smallest positive machine
C     number u such that  1.0 + u .ne. 1.0.  This is computed by DUMACH
C     in a machine-independent manner.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DUMSUM
C***REVISION HISTORY  (YYYYMMDD)
C   19930216  DATE WRITTEN
C   19930818  Added SLATEC-format prologue.  (FNF)
C   20030707  Added DUMSUM to force normal storage of COMP.  (ACH)
C***END PROLOGUE  DUMACH
C
      DOUBLE PRECISION u, comp
C***FIRST EXECUTABLE STATEMENT  DUMACH
      u = 1.0d0
 10   u = u*0.5d0
      CALL dumsum(1.0d0, u, comp)
      IF (comp .NE. 1.0d0) GO TO 10
      dumach = u*2.0d0
      RETURN
C----------------------- End of Function DUMACH ------------------------
      END
      SUBROUTINE dumsum(A,B,C)
C     Routine to force normal storing of A + B, for DUMACH.
      DOUBLE PRECISION a, b, c
      c = a + b
      RETURN
      END
*DECK DCFODE
      SUBROUTINE dcfode (METH, ELCO, TESCO)
C***BEGIN PROLOGUE  DCFODE
C***SUBSIDIARY
C***PURPOSE  Set ODE integrator coefficients.
C***TYPE      DOUBLE PRECISION (SCFODE-S, DCFODE-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  DCFODE is called by the integrator routine to set coefficients
C  needed there.  The coefficients for the current method, as
C  given by the value of METH, are set for all orders and saved.
C  The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2.
C  (A smaller value of the maximum order is also allowed.)
C  DCFODE is called once at the beginning of the problem,
C  and is not called again unless and until METH is changed.
C
C  The ELCO array contains the basic method coefficients.
C  The coefficients el(i), 1 .le. i .le. nq+1, for the method of
C  order nq are stored in ELCO(i,nq).  They are given by a genetrating
C  polynomial, i.e.,
C      l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq.
C  For the implicit Adams methods, l(x) is given by
C      dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1),    l(-1) = 0.
C  For the BDF methods, l(x) is given by
C      l(x) = (x+1)*(x+2)* ... *(x+nq)/K,
C  where         K = factorial(nq)*(1 + 1/2 + ... + 1/nq).
C
C  The TESCO array contains test constants used for the
C  local error test and the selection of step size and/or order.
C  At order nq, TESCO(k,nq) is used for the selection of step
C  size at order nq - 1 if k = 1, at order nq if k = 2, and at order
C  nq + 1 if k = 3.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C***END PROLOGUE  DCFODE
C**End
      INTEGER meth
      INTEGER i, ib, nq, nqm1, nqp1
      DOUBLE PRECISION elco, tesco
      DOUBLE PRECISION agamq, fnq, fnqm1, pc, pint, ragq,
     1   rqfac, rq1fac, tsign, xpin
      dimension elco(13,12), tesco(3,12)
      dimension pc(12)
C
C***FIRST EXECUTABLE STATEMENT  DCFODE
      GO TO (100, 200), meth
C
 100  elco(1,1) = 1.0d0
      elco(2,1) = 1.0d0
      tesco(1,1) = 0.0d0
      tesco(2,1) = 2.0d0
      tesco(1,2) = 1.0d0
      tesco(3,12) = 0.0d0
      pc(1) = 1.0d0
      rqfac = 1.0d0
      DO 140 nq = 2,12
C-----------------------------------------------------------------------
C The PC array will contain the coefficients of the polynomial
C     p(x) = (x+1)*(x+2)*...*(x+nq-1).
C Initially, p(x) = 1.
C-----------------------------------------------------------------------
        rq1fac = rqfac
        rqfac = rqfac/nq
        nqm1 = nq - 1
        fnqm1 = nqm1
        nqp1 = nq + 1
C Form coefficients of p(x)*(x+nq-1). ----------------------------------
        pc(nq) = 0.0d0
        DO 110 ib = 1,nqm1
          i = nqp1 - ib
 110      pc(i) = pc(i-1) + fnqm1*pc(i)
        pc(1) = fnqm1*pc(1)
C Compute integral, -1 to 0, of p(x) and x*p(x). -----------------------
        pint = pc(1)
        xpin = pc(1)/2.0d0
        tsign = 1.0d0
        DO 120 i = 2,nq
          tsign = -tsign
          pint = pint + tsign*pc(i)/i
 120      xpin = xpin + tsign*pc(i)/(i+1)
C Store coefficients in ELCO and TESCO. --------------------------------
        elco(1,nq) = pint*rq1fac
        elco(2,nq) = 1.0d0
        DO 130 i = 2,nq
 130      elco(i+1,nq) = rq1fac*pc(i)/i
        agamq = rqfac*xpin
        ragq = 1.0d0/agamq
        tesco(2,nq) = ragq
        IF (nq .LT. 12) tesco(1,nqp1) = ragq*rqfac/nqp1
        tesco(3,nqm1) = ragq
 140    CONTINUE
      RETURN
C
 200  pc(1) = 1.0d0
      rq1fac = 1.0d0
      DO 230 nq = 1,5
C-----------------------------------------------------------------------
C The PC array will contain the coefficients of the polynomial
C     p(x) = (x+1)*(x+2)*...*(x+nq).
C Initially, p(x) = 1.
C-----------------------------------------------------------------------
        fnq = nq
        nqp1 = nq + 1
C Form coefficients of p(x)*(x+nq). ------------------------------------
        pc(nqp1) = 0.0d0
        DO 210 ib = 1,nq
          i = nq + 2 - ib
 210      pc(i) = pc(i-1) + fnq*pc(i)
        pc(1) = fnq*pc(1)
C Store coefficients in ELCO and TESCO. --------------------------------
        DO 220 i = 1,nqp1
 220      elco(i,nq) = pc(i)/pc(2)
        elco(2,nq) = 1.0d0
        tesco(1,nq) = rq1fac
        tesco(2,nq) = nqp1/elco(1,nq)
        tesco(3,nq) = (nq+2)/elco(1,nq)
        rq1fac = rq1fac/fnq
 230    CONTINUE
      RETURN
C----------------------- END OF SUBROUTINE DCFODE ----------------------
      END
*DECK DINTDY
      SUBROUTINE dintdy (T, K, YH, NYH, DKY, IFLAG)
C***BEGIN PROLOGUE  DINTDY
C***SUBSIDIARY
C***PURPOSE  Interpolate solution derivatives.
C***TYPE      DOUBLE PRECISION (SINTDY-S, DINTDY-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  DINTDY computes interpolated values of the K-th derivative of the
C  dependent variable vector y, and stores it in DKY.  This routine
C  is called within the package with K = 0 and T = TOUT, but may
C  also be called by the user for any K up to the current order.
C  (See detailed instructions in the usage documentation.)
C
C  The computed values in DKY are gotten by interpolation using the
C  Nordsieck history array YH.  This array corresponds uniquely to a
C  vector-valued polynomial of degree NQCUR or less, and DKY is set
C  to the K-th derivative of this polynomial at T.
C  The formula for DKY is:
C               q
C   DKY(i)  =  sum  c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1)
C              j=K
C  where  c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR.
C  The quantities  nq = NQCUR, l = nq+1, N = NEQ, tn, and h are
C  communicated by COMMON.  The above sum is done in reverse order.
C  IFLAG is returned negative if either K or T is out of bounds.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  XERRWD
C***COMMON BLOCKS    DLS001
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C   010418  Reduced size of Common block /DLS001/. (ACH)
C   031105  Restored 'own' variables to Common block /DLS001/, to
C           enable interrupt/restart feature. (ACH)
C   050427  Corrected roundoff decrement in TP. (ACH)
C***END PROLOGUE  DINTDY
C**End
      INTEGER k, nyh, iflag
      DOUBLE PRECISION t, yh, dky
      dimension yh(nyh,*), dky(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, ic, j, jb, jb2, jj, jj1, jp1
      DOUBLE PRECISION c, r, s, tp
      CHARACTER*80 msg
C
C***FIRST EXECUTABLE STATEMENT  DINTDY
      iflag = 0
      IF (k .LT. 0 .OR. k .GT. nq) GO TO 80
      tp = tn - hu -  100.0d0*uround*sign(abs(tn) + abs(hu), hu)
      IF ((t-tp)*(t-tn) .GT. 0.0d0) GO TO 90
C
      s = (t - tn)/h
      ic = 1
      IF (k .EQ. 0) GO TO 15
      jj1 = l - k
      DO 10 jj = jj1,nq
 10     ic = ic*jj
 15   c = ic
      DO 20 i = 1,n
 20     dky(i) = c*yh(i,l)
      IF (k .EQ. nq) GO TO 55
      jb2 = nq - k
      DO 50 jb = 1,jb2
        j = nq - jb
        jp1 = j + 1
        ic = 1
        IF (k .EQ. 0) GO TO 35
        jj1 = jp1 - k
        DO 30 jj = jj1,j
 30       ic = ic*jj
 35     c = ic
        DO 40 i = 1,n
 40       dky(i) = c*yh(i,jp1) + s*dky(i)
 50     CONTINUE
      IF (k .EQ. 0) RETURN
 55   r = h**(-k)
      DO 60 i = 1,n
 60     dky(i) = r*dky(i)
      RETURN
C
 80   msg = 'DINTDY-  K (=I1) illegal      '
      CALL xerrwd (msg, 30, 51, 0, 1, k, 0, 0, 0.0d0, 0.0d0)
      iflag = -1
      RETURN
 90   msg = 'DINTDY-  T (=R1) illegal      '
      CALL xerrwd (msg, 30, 52, 0, 0, 0, 0, 1, t, 0.0d0)
      msg='      T not in interval TCUR - HU (= R1) to TCUR (=R2)      '
      CALL xerrwd (msg, 60, 52, 0, 0, 0, 0, 2, tp, tn)
      iflag = -2
      RETURN
C----------------------- END OF SUBROUTINE DINTDY ----------------------
      END
*DECK DPREPJ
      SUBROUTINE dprepj (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM,
     1   F, JAC)
C***BEGIN PROLOGUE  DPREPJ
C***SUBSIDIARY
C***PURPOSE  Compute and process Newton iteration matrix.
C***TYPE      DOUBLE PRECISION (SPREPJ-S, DPREPJ-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  DPREPJ is called by DSTODE to compute and process the matrix
C  P = I - h*el(1)*J , where J is an approximation to the Jacobian.
C  Here J is computed by the user-supplied routine JAC if
C  MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5.
C  If MITER = 3, a diagonal approximation to J is used.
C  J is stored in WM and replaced by P.  If MITER .ne. 3, P is then
C  subjected to LU decomposition in preparation for later solution
C  of linear systems with P as coefficient matrix.  This is done
C  by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5.
C
C  In addition to variables described in DSTODE and DLSODE prologues,
C  communication with DPREPJ uses the following:
C  Y     = array containing predicted values on entry.
C  FTEM  = work array of length N (ACOR in DSTODE).
C  SAVF  = array containing f evaluated at predicted y.
C  WM    = real work space for matrices.  On output it contains the
C          inverse diagonal matrix if MITER = 3 and the LU decomposition
C          of P if MITER is 1, 2 , 4, or 5.
C          Storage of matrix elements starts at WM(3).
C          WM also contains the following matrix-related data:
C          WM(1) = SQRT(UROUND), used in numerical Jacobian increments.
C          WM(2) = H*EL0, saved for later use if MITER = 3.
C  IWM   = integer work space containing pivot information, starting at
C          IWM(21), if MITER is 1, 2, 4, or 5.  IWM also contains band
C          parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
C  EL0   = EL(1) (input).
C  IERPJ = output error flag,  = 0 if no trouble, .gt. 0 if
C          P matrix found to be singular.
C  JCUR  = output flag = 1 to indicate that the Jacobian matrix
C          (or approximation) is now current.
C  This routine also uses the COMMON variables EL0, H, TN, UROUND,
C  MITER, N, NFE, and NJE.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  DGBFA, DGEFA, DVNORM
C***COMMON BLOCKS    DLS001
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890504  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C   010418  Reduced size of Common block /DLS001/. (ACH)
C   031105  Restored 'own' variables to Common block /DLS001/, to
C           enable interrupt/restart feature. (ACH)
C***END PROLOGUE  DPREPJ
C**End
      EXTERNAL f, jac
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, ewt, ftem, savf, wm
      dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*),
     1   wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, i1, i2, ier, ii, j, j1, jj, lenp,
     1   mba, mband, meb1, meband, ml, ml3, mu, np1
      DOUBLE PRECISION con, di, fac, hl0, r, r0, srur, yi, yj, yjj,
     1   dvnorm
C
C***FIRST EXECUTABLE STATEMENT  DPREPJ
      nje = nje + 1
      ierpj = 0
      jcur = 1
      hl0 = h*el0
      GO TO (100, 200, 300, 400, 500), miter
C If MITER = 1, call JAC and multiply by scalar. -----------------------
 100  lenp = n*n
      DO 110 i = 1,lenp
 110    wm(i+2) = 0.0d0
      CALL jac (neq, tn, y, 0, 0, wm(3), n)
      con = -hl0
      DO 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
      GO TO 240
C If MITER = 2, make N calls to F to approximate J. --------------------
 200  fac = dvnorm(n, savf, ewt)
      r0 = 1000.0d0*abs(h)*uround*n*fac
      IF (r0 .EQ. 0.0d0) r0 = 1.0d0
      srur = wm(1)
      j1 = 2
      DO 230 j = 1,n
        yj = y(j)
        r = max(srur*abs(yj),r0/ewt(j))
        y(j) = y(j) + r
        fac = -hl0/r
        CALL f (neq, tn, y, ftem)
        DO 220 i = 1,n
 220      wm(i+j1) = (ftem(i) - savf(i))*fac
        y(j) = yj
        j1 = j1 + n
 230    CONTINUE
      nfe = nfe + n
C Add identity matrix. -------------------------------------------------
 240  j = 3
      np1 = n + 1
      DO 250 i = 1,n
        wm(j) = wm(j) + 1.0d0
 250    j = j + np1
C Do LU decomposition on P. --------------------------------------------
      CALL dgefa (wm(3), n, n, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C If MITER = 3, construct a diagonal approximation to J and P. ---------
 300  wm(2) = hl0
      r = el0*0.1d0
      DO 310 i = 1,n
 310    y(i) = y(i) + r*(h*savf(i) - yh(i,2))
      CALL f (neq, tn, y, wm(3))
      nfe = nfe + 1
      DO 320 i = 1,n
        r0 = h*savf(i) - yh(i,2)
        di = 0.1d0*r0 - h*(wm(i+2) - savf(i))
        wm(i+2) = 1.0d0
        IF (abs(r0) .LT. uround/ewt(i)) GO TO 320
        IF (abs(di) .EQ. 0.0d0) GO TO 330
        wm(i+2) = 0.1d0*r0/di
 320    CONTINUE
      RETURN
 330  ierpj = 1
      RETURN
C If MITER = 4, call JAC and multiply by scalar. -----------------------
 400  ml = iwm(1)
      mu = iwm(2)
      ml3 = ml + 3
      mband = ml + mu + 1
      meband = mband + ml
      lenp = meband*n
      DO 410 i = 1,lenp
 410    wm(i+2) = 0.0d0
      CALL jac (neq, tn, y, ml, mu, wm(ml3), meband)
      con = -hl0
      DO 420 i = 1,lenp
 420    wm(i+2) = wm(i+2)*con
      GO TO 570
C If MITER = 5, make MBAND calls to F to approximate J. ----------------
 500  ml = iwm(1)
      mu = iwm(2)
      mband = ml + mu + 1
      mba = min(mband,n)
      meband = mband + ml
      meb1 = meband - 1
      srur = wm(1)
      fac = dvnorm(n, savf, ewt)
      r0 = 1000.0d0*abs(h)*uround*n*fac
      IF (r0 .EQ. 0.0d0) r0 = 1.0d0
      DO 560 j = 1,mba
        DO 530 i = j,n,mband
          yi = y(i)
          r = max(srur*abs(yi),r0/ewt(i))
 530      y(i) = y(i) + r
        CALL f (neq, tn, y, ftem)
        DO 550 jj = j,n,mband
          y(jj) = yh(jj,1)
          yjj = y(jj)
          r = max(srur*abs(yjj),r0/ewt(jj))
          fac = -hl0/r
          i1 = max(jj-mu,1)
          i2 = min(jj+ml,n)
          ii = jj*meb1 - ml + 2
          DO 540 i = i1,i2
 540        wm(ii+i) = (ftem(i) - savf(i))*fac
 550      CONTINUE
 560    CONTINUE
      nfe = nfe + mba
C Add identity matrix. -------------------------------------------------
 570  ii = mband + 2
      DO 580 i = 1,n
        wm(ii) = wm(ii) + 1.0d0
 580    ii = ii + meband
C Do LU decomposition of P. --------------------------------------------
      CALL dgbfa (wm(3), meband, n, ml, mu, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C----------------------- END OF SUBROUTINE DPREPJ ----------------------
      END
*DECK DSOLSY
      SUBROUTINE dsolsy (WM, IWM, X, TEM)
C***BEGIN PROLOGUE  DSOLSY
C***SUBSIDIARY
C***PURPOSE  ODEPACK linear system solver.
C***TYPE      DOUBLE PRECISION (SSOLSY-S, DSOLSY-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
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 DGESL to accomplish this.
C  If MITER = 3 it updates the coefficient h*EL0 in the diagonal
C  matrix, and then computes the solution.
C  If MITER is 4 or 5, it calls DGBSL.
C  Communication with DSOLSY uses the following variables:
C  WM    = 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 WM(3).
C          WM also contains the following matrix-related data:
C          WM(1) = SQRT(UROUND) (not used here),
C          WM(2) = HL0, the previous value of h*EL0, used if MITER = 3.
C  IWM   = integer work space containing pivot information, starting at
C          IWM(21), if MITER is 1, 2, 4, or 5.  IWM also contains band
C          parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
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).  IERSL = 0 if no trouble occurred.
C          IERSL = 1 if a singular matrix arose with MITER = 3.
C  This routine also uses the COMMON variables EL0, H, MITER, and N.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  DGBSL, DGESL
C***COMMON BLOCKS    DLS001
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C   010418  Reduced size of Common block /DLS001/. (ACH)
C   031105  Restored 'own' variables to Common block /DLS001/, to
C           enable interrupt/restart feature. (ACH)
C***END PROLOGUE  DSOLSY
C**End
      INTEGER iwm
      DOUBLE PRECISION wm, x, tem
      dimension wm(*), iwm(*), x(*), tem(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, meband, ml, mu
      DOUBLE PRECISION di, hl0, phl0, r
C
C***FIRST EXECUTABLE STATEMENT  DSOLSY
      iersl = 0
      GO TO (100, 100, 300, 400, 400), miter
 100  CALL dgesl (wm(3), n, n, iwm(21), x, 0)
      RETURN
C
 300  phl0 = wm(2)
      hl0 = h*el0
      wm(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/wm(i+2))
        IF (abs(di) .EQ. 0.0d0) GO TO 390
 320    wm(i+2) = 1.0d0/di
 330  DO 340 i = 1,n
 340    x(i) = wm(i+2)*x(i)
      RETURN
 390  iersl = 1
      RETURN
C
 400  ml = iwm(1)
      mu = iwm(2)
      meband = 2*ml + mu + 1
      CALL dgbsl (wm(3), meband, n, ml, mu, iwm(21), x, 0)
      RETURN
C----------------------- END OF SUBROUTINE DSOLSY ----------------------
      END
*DECK DSRCOM
      SUBROUTINE dsrcom (RSAV, ISAV, JOB)
C***BEGIN PROLOGUE  DSRCOM
C***SUBSIDIARY
C***PURPOSE  Save/restore ODEPACK COMMON blocks.
C***TYPE      DOUBLE PRECISION (SSRCOM-S, DSRCOM-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  This routine saves or restores (depending on JOB) the contents of
C  the COMMON block DLS001, which is used internally
C  by one or more ODEPACK solvers.
C
C  RSAV = real array of length 218 or more.
C  ISAV = integer array of length 37 or more.
C  JOB  = flag indicating to save or restore the COMMON blocks:
C         JOB  = 1 if COMMON is to be saved (written to RSAV/ISAV)
C         JOB  = 2 if COMMON is to be restored (read from RSAV/ISAV)
C         A call with JOB = 2 presumes a prior call with JOB = 1.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DLS001
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   921116  Deleted treatment of block /EH0001/.  (ACH)
C   930801  Reduced Common block length by 2.  (ACH)
C   930809  Renamed to allow single/double precision versions. (ACH)
C   010418  Reduced Common block length by 209+12. (ACH)
C   031105  Restored 'own' variables to Common block /DLS001/, to
C           enable interrupt/restart feature. (ACH)
C   031112  Added SAVE statement for data-loaded constants.
C***END PROLOGUE  DSRCOM
C**End
      INTEGER isav, job
      INTEGER ils
      INTEGER i, lenils, lenrls
      DOUBLE PRECISION rsav,   rls
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils
      COMMON /dls001/ rls(218), ils(37)
      DATA lenrls/218/, lenils/37/
C
C***FIRST EXECUTABLE STATEMENT  DSRCOM
      IF (job .EQ. 2) GO TO 100
C
      DO 10 i = 1,lenrls
 10     rsav(i) = rls(i)
      DO 20 i = 1,lenils
 20     isav(i) = ils(i)
      RETURN
C
 100  CONTINUE
      DO 110 i = 1,lenrls
 110     rls(i) = rsav(i)
      DO 120 i = 1,lenils
 120     ils(i) = isav(i)
      RETURN
C----------------------- END OF SUBROUTINE DSRCOM ----------------------
      END
*DECK DSTODE
      SUBROUTINE dstode (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR,
     1   WM, IWM, F, JAC, PJAC, SLVS)
C***BEGIN PROLOGUE  DSTODE
C***SUBSIDIARY
C***PURPOSE  Performs one step of an ODEPACK integration.
C***TYPE      DOUBLE PRECISION (SSTODE-S, DSTODE-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  DSTODE performs one step of the integration of an initial value
C  problem for a system of ordinary differential equations.
C  Note:  DSTODE is independent of the value of the iteration method
C  indicator MITER, when this is .ne. 0, and hence is independent
C  of the type of chord method used, or the Jacobian structure.
C  Communication with DSTODE is done with the following variables:
C
C  NEQ    = integer array containing problem size in NEQ(1), and
C           passed as the NEQ argument in all calls to F and JAC.
C  Y      = an array of length .ge. N used as the Y argument in
C           all calls to F and JAC.
C  YH     = an NYH by LMAX array containing the dependent variables
C           and their approximate scaled derivatives, where
C           LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C           j-th derivative of y(i), scaled by h**j/factorial(j)
C           (j = 0,1,...,NQ).  on entry for the first step, the first
C           two columns of YH must be set from the initial values.
C  NYH    = a constant integer .ge. N, the first dimension of YH.
C  YH1    = a one-dimensional array occupying the same space as YH.
C  EWT    = an array of length N containing multiplicative weights
C           for local error measurements.  Local errors in Y(i) are
C           compared to 1.0/EWT(i) in various error tests.
C  SAVF   = an array of working storage, of length N.
C           Also used for input of YH(*,MAXORD+2) when JSTART = -1
C           and MAXORD .lt. the current order NQ.
C  ACOR   = a work array of length N, used for the accumulated
C           corrections.  On a successful return, ACOR(i) contains
C           the estimated one-step local error in Y(i).
C  WM,IWM = real and integer work arrays associated with matrix
C           operations in chord iteration (MITER .ne. 0).
C  PJAC   = name of routine to evaluate and preprocess Jacobian matrix
C           and P = I - h*el0*JAC, if a chord method is being used.
C  SLVS   = name of routine to solve linear system in chord iteration.
C  CCMAX  = maximum relative change in h*el0 before PJAC is called.
C  H      = the step size to be attempted on the next step.
C           H is altered by the error control algorithm during the
C           problem.  H can be either positive or negative, but its
C           sign must remain constant throughout the problem.
C  HMIN   = the minimum absolute value of the step size h to be used.
C  HMXI   = inverse of the maximum absolute value of h to be used.
C           HMXI = 0.0 is allowed and corresponds to an infinite hmax.
C           HMIN and HMXI may be changed at any time, but will not
C           take effect until the next change of h is considered.
C  TN     = the independent variable. TN is updated on each step taken.
C  JSTART = an integer used for input only, with the following
C           values and meanings:
C                0  perform the first step.
C            .gt.0  take a new step continuing from the last.
C               -1  take the next step with a new value of H, MAXORD,
C                     N, METH, MITER, and/or matrix parameters.
C               -2  take the next step with a new value of H,
C                     but with other inputs unchanged.
C           On return, JSTART is set to 1 to facilitate continuation.
C  KFLAG  = a completion code with the following meanings:
C                0  the step was succesful.
C               -1  the requested error could not be achieved.
C               -2  corrector convergence could not be achieved.
C               -3  fatal error in PJAC or SLVS.
C           A return with KFLAG = -1 or -2 means either
C           abs(H) = HMIN or 10 consecutive failures occurred.
C           On a return with KFLAG negative, the values of TN and
C           the YH array are as of the beginning of the last
C           step, and H is the last step size attempted.
C  MAXORD = the maximum order of integration method to be allowed.
C  MAXCOR = the maximum number of corrector iterations allowed.
C  MSBP   = maximum number of steps between PJAC calls (MITER .gt. 0).
C  MXNCF  = maximum number of convergence failures allowed.
C  METH/MITER = the method flags.  See description in driver.
C  N      = the number of first-order differential equations.
C  The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD,
C  MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  DCFODE, DVNORM
C***COMMON BLOCKS    DLS001
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C   010418  Reduced size of Common block /DLS001/. (ACH)
C   031105  Restored 'own' variables to Common block /DLS001/, to
C           enable interrupt/restart feature. (ACH)
C***END PROLOGUE  DSTODE
C**End
      EXTERNAL f, jac, pjac, slvs
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, yh1, ewt, savf, acor, wm
      dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*),
     1   acor(*), wm(*), iwm(*)
      INTEGER iownd, ialth, ipup, lmax, meo, nqnyh, nslp,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, i1, iredo, iret, j, jb, m, ncf, newq
      DOUBLE PRECISION conit, crate, el, elco, hold, rmax, tesco,
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup,
     1   r, rh, rhdn, rhsm, rhup, told, dvnorm
      COMMON /dls001/ conit, crate, el(13), elco(13,12),
     1   hold, rmax, tesco(3,12),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(6), ialth, ipup, lmax, meo, nqnyh, nslp,
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
C
C***FIRST EXECUTABLE STATEMENT  DSTODE
      kflag = 0
      told = tn
      ncf = 0
      ierpj = 0
      iersl = 0
      jcur = 0
      icf = 0
      delp = 0.0d0
      IF (jstart .GT. 0) GO TO 200
      IF (jstart .EQ. -1) GO TO 100
      IF (jstart .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set to 2
C for the next increase.
C-----------------------------------------------------------------------
      lmax = maxord + 1
      nq = 1
      l = 2
      ialth = 2
      rmax = 10000.0d0
      rc = 0.0d0
      el0 = 1.0d0
      crate = 0.7d0
      hold = h
      meo = meth
      nslp = 0
      ipup = miter
      iret = 3
      GO TO 140
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If the caller has changed MAXORD to a value less than the current
C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  ipup = miter
      lmax = maxord + 1
      IF (ialth .EQ. 1) ialth = 2
      IF (meth .EQ. meo) GO TO 110
      CALL dcfode (meth, elco, tesco)
      meo = meth
      IF (nq .GT. maxord) GO TO 120
      ialth = l
      iret = 1
      GO TO 150
 110  IF (nq .LE. maxord) GO TO 160
 120  nq = maxord
      l = lmax
      DO 125 i = 1,l
 125    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      ddn = dvnorm(n, savf, ewt)/tesco(1,l)
      exdn = 1.0d0/l
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
      rh = min(rhdn,1.0d0)
      iredo = 3
      IF (h .EQ. hold) GO TO 170
      rh = min(rh,abs(h/hold))
      h = hold
      GO TO 175
C-----------------------------------------------------------------------
C DCFODE is called to get all the integration coefficients for the
C current METH.  Then the EL vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 140  CALL dcfode (meth, elco, tesco)
 150  DO 155 i = 1,l
 155    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      GO TO (160, 170, 200), iret
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (h .EQ. hold) GO TO 200
      rh = h/hold
      h = hold
      iredo = 3
      GO TO 175
 170  rh = max(rh,hmin/abs(h))
 175  rh = min(rh,rmax)
      rh = rh/max(1.0d0,abs(h)*hmxi*rh)
      r = 1.0d0
      DO 180 j = 2,l
        r = r*rh
        DO 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
      h = h*rh
      rc = rc*rh
      ialth = l
      IF (iredo .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal Triangle matrix.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C When RC differs from 1 by more than CCMAX, IPUP is set to MITER
C to force PJAC to be called, if a Jacobian is involved.
C In any case, PJAC is called at least every MSBP steps.
C-----------------------------------------------------------------------
 200  IF (abs(rc-1.0d0) .GT. ccmax) ipup = miter
      IF (nst .GE. nslp+msbp) ipup = miter
      tn = tn + h
      i1 = nqnyh + 1
      DO 215 jb = 1,nq
        i1 = i1 - nyh
Cdir$ ivdep
        DO 210 i = i1,nqnyh
 210      yh1(i) = yh1(i) + yh1(i+nyh)
 215    CONTINUE
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the R.M.S. norm of each correction, weighted by the error
C weight vector EWT.  The sum of the corrections is accumulated in the
C vector ACOR(i).  The YH array is not altered in the corrector loop.
C-----------------------------------------------------------------------
 220  m = 0
      DO 230 i = 1,n
 230    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      IF (ipup .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, the matrix P = I - h*el(1)*J is reevaluated and
C preprocessed before starting the corrector iteration.  IPUP is set
C to 0 as an indicator that this has been done.
C-----------------------------------------------------------------------
      CALL pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac)
      ipup = 0
      rc = 1.0d0
      nslp = nst
      crate = 0.7d0
      IF (ierpj .NE. 0) GO TO 430
 250  DO 260 i = 1,n
 260    acor(i) = 0.0d0
 270  IF (miter .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation.
C-----------------------------------------------------------------------
      DO 290 i = 1,n
        savf(i) = h*savf(i) - yh(i,2)
 290    y(i) = savf(i) - acor(i)
      del = dvnorm(n, y, ewt)
      DO 300 i = 1,n
        y(i) = yh(i,1) + el(1)*savf(i)
 300    acor(i) = savf(i)
      GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix.
C-----------------------------------------------------------------------
 350  DO 360 i = 1,n
 360    y(i) = h*savf(i) - (yh(i,2) + acor(i))
      CALL slvs (wm, iwm, y, savf)
      IF (iersl .LT. 0) GO TO 430
      IF (iersl .GT. 0) GO TO 410
      del = dvnorm(n, y, ewt)
      DO 380 i = 1,n
        acor(i) = acor(i) + y(i)
 380    y(i) = yh(i,1) + el(1)*acor(i)
C-----------------------------------------------------------------------
C Test for convergence.  If M.gt.0, an estimate of the convergence
C rate constant is stored in CRATE, and this is used in the test.
C-----------------------------------------------------------------------
 400  IF (m .NE. 0) crate = max(0.2d0*crate,del/delp)
      dcon = del*min(1.0d0,1.5d0*crate)/(tesco(2,nq)*conit)
      IF (dcon .LE. 1.0d0) GO TO 450
      m = m + 1
      IF (m .EQ. maxcor) GO TO 410
      IF (m .GE. 2 .AND. del .GT. 2.0d0*delp) GO TO 410
      delp = del
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      GO TO 270
C-----------------------------------------------------------------------
C The corrector iteration failed to converge.
C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for
C the next try.  Otherwise the YH array is retracted to its values
C before prediction, and H is reduced, if possible.  If H cannot be
C reduced or MXNCF failures have occurred, exit with KFLAG = -2.
C-----------------------------------------------------------------------
 410  IF (miter .EQ. 0 .OR. jcur .EQ. 1) GO TO 430
      icf = 1
      ipup = miter
      GO TO 220
 430  icf = 2
      ncf = ncf + 1
      rmax = 2.0d0
      tn = told
      i1 = nqnyh + 1
      DO 445 jb = 1,nq
        i1 = i1 - nyh
Cdir$ ivdep
        DO 440 i = i1,nqnyh
 440      yh1(i) = yh1(i) - yh1(i+nyh)
 445    CONTINUE
      IF (ierpj .LT. 0 .OR. iersl .LT. 0) GO TO 680
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 670
      IF (ncf .EQ. mxncf) GO TO 670
      rh = 0.25d0
      ipup = miter
      iredo = 1
      GO TO 170
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0
C to signal that the Jacobian involved may need updating later.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 450  jcur = 0
      IF (m .EQ. 0) dsm = del/tesco(2,nq)
      IF (m .GT. 0) dsm = dvnorm(n, acor, ewt)/tesco(2,nq)
      IF (dsm .GT. 1.0d0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C Consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      kflag = 0
      iredo = 0
      nst = nst + 1
      hu = h
      nqu = nq
      DO 470 j = 1,l
        DO 470 i = 1,n
 470      yh(i,j) = yh(i,j) + el(j)*acor(i)
      ialth = ialth - 1
      IF (ialth .EQ. 0) GO TO 520
      IF (ialth .GT. 1) GO TO 700
      IF (l .EQ. lmax) GO TO 700
      DO 490 i = 1,n
 490    yh(i,lmax) = acor(i)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.2 or less.
C-----------------------------------------------------------------------
 500  kflag = kflag - 1
      tn = told
      i1 = nqnyh + 1
      DO 515 jb = 1,nq
        i1 = i1 - nyh
Cdir$ ivdep
        DO 510 i = i1,nqnyh
 510      yh1(i) = yh1(i) - yh1(i+nyh)
 515    CONTINUE
      rmax = 2.0d0
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 660
      IF (kflag .LE. -3) GO TO 640
      iredo = 2
      rhup = 0.0d0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C In the case of failure, RHUP = 0.0 to avoid an order increase.
C The largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  rhup = 0.0d0
      IF (l .EQ. lmax) GO TO 540
      DO 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
      dup = dvnorm(n, savf, ewt)/tesco(3,nq)
      exup = 1.0d0/(l+1)
      rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0)
 540  exsm = 1.0d0/l
      rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rhdn = 0.0d0
      IF (nq .EQ. 1) GO TO 560
      ddn = dvnorm(n, yh(1,l), ewt)/tesco(1,nq)
      exdn = 1.0d0/nq
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
 560  IF (rhsm .GE. rhup) GO TO 570
      IF (rhup .GT. rhdn) GO TO 590
      GO TO 580
 570  IF (rhsm .LT. rhdn) GO TO 580
      newq = nq
      rh = rhsm
      GO TO 620
 580  newq = nq - 1
      rh = rhdn
      IF (kflag .LT. 0 .AND. rh .GT. 1.0d0) rh = 1.0d0
      GO TO 620
 590  newq = l
      rh = rhup
      IF (rh .LT. 1.1d0) GO TO 610
      r = el(l)/l
      DO 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
      GO TO 630
 610  ialth = 3
      GO TO 700
 620  IF ((kflag .EQ. 0) .AND. (rh .LT. 1.1d0)) GO TO 610
      IF (kflag .LE. -2) rh = min(rh,0.2d0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, l, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (newq .EQ. nq) GO TO 170
 630  nq = newq
      l = nq + 1
      iret = 2
      GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more failures have occured.
C If 10 failures have occurred, exit with KFLAG = -1.
C It is assumed that the derivatives that have accumulated in the
C YH array have errors of the wrong order.  Hence the first
C derivative is recomputed, and the order is set to 1.  Then
C H is reduced by a factor of 10, and the step is retried,
C until it succeeds or H reaches HMIN.
C-----------------------------------------------------------------------
 640  IF (kflag .EQ. -10) GO TO 660
      rh = 0.1d0
      rh = max(hmin/abs(h),rh)
      h = h*rh
      DO 645 i = 1,n
 645    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      DO 650 i = 1,n
 650    yh(i,2) = h*savf(i)
      ipup = miter
      ialth = 5
      IF (nq .EQ. 1) GO TO 200
      nq = 1
      l = 2
      iret = 3
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  kflag = -1
      GO TO 720
 670  kflag = -2
      GO TO 720
 680  kflag = -3
      GO TO 720
 690  rmax = 10.0d0
 700  r = 1.0d0/tesco(2,nqu)
      DO 710 i = 1,n
 710    acor(i) = acor(i)*r
 720  hold = h
      jstart = 1
      RETURN
C----------------------- END OF SUBROUTINE DSTODE ----------------------
      END
*DECK DEWSET
      SUBROUTINE dewset (N, ITOL, RTOL, ATOL, YCUR, EWT)
C***BEGIN PROLOGUE  DEWSET
C***SUBSIDIARY
C***PURPOSE  Set error weight vector.
C***TYPE      DOUBLE PRECISION (SEWSET-S, DEWSET-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  This subroutine sets the error weight vector EWT according to
C      EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i),  i = 1,...,N,
C  with the subscript on RTOL and/or ATOL possibly replaced by 1 above,
C  depending on the value of ITOL.
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C***END PROLOGUE  DEWSET
C**End
      INTEGER n, itol
      INTEGER i
      DOUBLE PRECISION rtol, atol, ycur, ewt
      dimension rtol(*), atol(*), ycur(n), ewt(n)
C
C***FIRST EXECUTABLE STATEMENT  DEWSET
      GO TO (10, 20, 30, 40), itol
 10   CONTINUE
      DO 15 i = 1,n
 15     ewt(i) = rtol(1)*abs(ycur(i)) + atol(1)
      RETURN
 20   CONTINUE
      DO 25 i = 1,n
 25     ewt(i) = rtol(1)*abs(ycur(i)) + atol(i)
      RETURN
 30   CONTINUE
      DO 35 i = 1,n
 35     ewt(i) = rtol(i)*abs(ycur(i)) + atol(1)
      RETURN
 40   CONTINUE
      DO 45 i = 1,n
 45     ewt(i) = rtol(i)*abs(ycur(i)) + atol(i)
      RETURN
C----------------------- END OF SUBROUTINE DEWSET ----------------------
      END
*DECK DVNORM
      DOUBLE PRECISION FUNCTION dvnorm (N, V, W)
C***BEGIN PROLOGUE  DVNORM
C***SUBSIDIARY
C***PURPOSE  Weighted root-mean-square vector norm.
C***TYPE      DOUBLE PRECISION (SVNORM-S, DVNORM-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  This function routine computes the weighted root-mean-square norm
C  of the vector of length N contained in the array V, with weights
C  contained in the array W of length N:
C    DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 )
C
C***SEE ALSO  DLSODE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890501  Modified prologue to SLATEC/LDOC format.  (FNF)
C   890503  Minor cosmetic changes.  (FNF)
C   930809  Renamed to allow single/double precision versions. (ACH)
C***END PROLOGUE  DVNORM
C**End
      INTEGER n,   i
      DOUBLE PRECISION v, w,   sum
      dimension v(n), w(n)
C
C***FIRST EXECUTABLE STATEMENT  DVNORM
      sum = 0.0d0
      DO 10 i = 1,n
 10     sum = sum + (v(i)*w(i))**2
      dvnorm = sqrt(sum/n)
      RETURN
C----------------------- END OF FUNCTION DVNORM ------------------------
      END
*DECK DIPREP
      SUBROUTINE diprep (NEQ, Y, RWORK, IA, JA, IPFLAG, F, JAC)
      EXTERNAL f, jac
      INTEGER neq, ia, ja, ipflag
      DOUBLE PRECISION y, rwork
      dimension neq(*), y(*), rwork(*), ia(*), ja(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rlss
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ 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
      INTEGER i, imax, lewtn, lyhd, lyhn
C-----------------------------------------------------------------------
C This routine serves as an interface between the driver and
C Subroutine DPREP.  It is called only if MITER is 1 or 2.
C Tasks performed here are:
C  * call DPREP,
C  * reset the required WM segment length LENWK,
C  * move YH back to its final location (following WM in RWORK),
C  * reset pointers for YH, SAVF, EWT, and ACOR, and
C  * move EWT to its new position if ISTATE = 1.
C IPFLAG is an output error indication flag.  IPFLAG = 0 if there was
C no trouble, and IPFLAG is the value of the DPREP error flag IPPER
C if there was trouble in Subroutine DPREP.
C-----------------------------------------------------------------------
      ipflag = 0
C Call DPREP to do matrix preprocessing operations. --------------------
      CALL dprep (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt),
     1   rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac)
      lenwk = max(lreq,lwmin)
      IF (ipflag .LT. 0) RETURN
C If DPREP was successful, move YH to end of required space for WM. ----
      lyhn = lwm + lenwk
      IF (lyhn .GT. lyh) RETURN
      lyhd = lyh - lyhn
      IF (lyhd .EQ. 0) GO TO 20
      imax = lyhn - 1 + lenyhm
      DO 10 i = lyhn,imax
 10     rwork(i) = rwork(i+lyhd)
      lyh = lyhn
C Reset pointers for SAVF, EWT, and ACOR. ------------------------------
 20   lsavf = lyh + lenyh
      lewtn = lsavf + n
      lacor = lewtn + n
      IF (istatc .EQ. 3) GO TO 40
C If ISTATE = 1, move EWT (left) to its new position. ------------------
      IF (lewtn .GT. lewt) RETURN
      DO 30 i = 1,n
 30     rwork(i+lewtn-1) = rwork(i+lewt-1)
 40   lewt = lewtn
      RETURN
C----------------------- End of Subroutine DIPREP ----------------------
      END
*DECK DPREP
      SUBROUTINE dprep (NEQ, Y, YH, SAVF, EWT, FTEM, IA, JA,
     1                     WK, IWK, IPPER, F, JAC)
      EXTERNAL f,jac
      INTEGER neq, ia, ja, iwk, ipper
      DOUBLE PRECISION y, yh, savf, ewt, ftem, wk
      dimension neq(*), y(*), yh(*), savf(*), ewt(*), ftem(*),
     1   ia(*), ja(*), wk(*), iwk(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION con0, conmin, ccmxj, psmall, rbig, seth
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ con0, conmin, ccmxj, psmall, rbig, seth,
     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
      INTEGER i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, jfound, k,
     1   knew, kmax, kmin, ldif, lenigp, liwk, maxg, np1, nzsut
      DOUBLE PRECISION dq, dyj, erwt, fac, yj
C-----------------------------------------------------------------------
C This routine performs preprocessing related to the sparse linear
C systems that must be solved if MITER = 1 or 2.
C The operations that are performed here are:
C  * compute sparseness structure of Jacobian according to MOSS,
C  * compute grouping of column indices (MITER = 2),
C  * compute a new ordering of rows and columns of the matrix,
C  * reorder JA corresponding to the new ordering,
C  * perform a symbolic LU factorization of the matrix, and
C  * set pointers for segments of the IWK/WK array.
C In addition to variables described previously, DPREP uses the
C following for communication:
C YH     = the history array.  Only the first column, containing the
C          current Y vector, is used.  Used only if MOSS .ne. 0.
C SAVF   = a work array of length NEQ, used only if MOSS .ne. 0.
C EWT    = array of length NEQ containing (inverted) error weights.
C          Used only if MOSS = 2 or if ISTATE = MOSS = 1.
C FTEM   = a work array of length NEQ, identical to ACOR in the driver,
C          used only if MOSS = 2.
C WK     = a real work array of length LENWK, identical to WM in
C          the driver.
C IWK    = integer work array, assumed to occupy the same space as WK.
C LENWK  = the length of the work arrays WK and IWK.
C ISTATC = a copy of the driver input argument ISTATE (= 1 on the
C          first call, = 3 on a continuation call).
C IYS    = flag value from ODRV or CDRV.
C IPPER  = output error flag with the following values and meanings:
C          0  no error.
C         -1  insufficient storage for internal structure pointers.
C         -2  insufficient storage for JGROUP.
C         -3  insufficient storage for ODRV.
C         -4  other error flag from ODRV (should never occur).
C         -5  insufficient storage for CDRV.
C         -6  other error flag from CDRV.
C-----------------------------------------------------------------------
      ibian = lrat*2
      ipian = ibian + 1
      np1 = n + 1
      ipjan = ipian + np1
      ibjan = ipjan - 1
      liwk = lenwk*lrat
      IF (ipjan+n-1 .GT. liwk) GO TO 210
      IF (moss .EQ. 0) GO TO 30
C
      IF (istatc .EQ. 3) GO TO 20
C ISTATE = 1 and MOSS .ne. 0.  Perturb Y for structure determination. --
      DO 10 i = 1,n
        erwt = 1.0d0/ewt(i)
        fac = 1.0d0 + 1.0d0/(i + 1.0d0)
        y(i) = y(i) + fac*sign(erwt,y(i))
 10     CONTINUE
      GO TO (70, 100), moss
C
 20   CONTINUE
C ISTATE = 3 and MOSS .ne. 0.  Load Y from YH(*,1). --------------------
      DO 25 i = 1,n
 25     y(i) = yh(i)
      GO TO (70, 100), moss
C
C MOSS = 0.  Process user's IA,JA.  Add diagonal entries if necessary. -
 30   knew = ipjan
      kmin = ia(1)
      iwk(ipian) = 1
      DO 60 j = 1,n
        jfound = 0
        kmax = ia(j+1) - 1
        IF (kmin .GT. kmax) GO TO 45
        DO 40 k = kmin,kmax
          i = ja(k)
          IF (i .EQ. j) jfound = 1
          IF (knew .GT. liwk) GO TO 210
          iwk(knew) = i
          knew = knew + 1
 40       CONTINUE
        IF (jfound .EQ. 1) GO TO 50
 45     IF (knew .GT. liwk) GO TO 210
        iwk(knew) = j
        knew = knew + 1
 50     iwk(ipian+j) = knew + 1 - ipjan
        kmin = kmax + 1
 60     CONTINUE
      GO TO 140
C
C MOSS = 1.  Compute structure from user-supplied Jacobian routine JAC.
 70   CONTINUE
C A dummy call to F allows user to create temporaries for use in JAC. --
      CALL f (neq, tn, y, savf)
      k = ipjan
      iwk(ipian) = 1
      DO 90 j = 1,n
        IF (k .GT. liwk) GO TO 210
        iwk(k) = j
        k = k + 1
        DO 75 i = 1,n
 75       savf(i) = 0.0d0
        CALL jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), savf)
        DO 80 i = 1,n
          IF (abs(savf(i)) .LE. seth) GO TO 80
          IF (i .EQ. j) GO TO 80
          IF (k .GT. liwk) GO TO 210
          iwk(k) = i
          k = k + 1
 80       CONTINUE
        iwk(ipian+j) = k + 1 - ipjan
 90     CONTINUE
      GO TO 140
C
C MOSS = 2.  Compute structure from results of N + 1 calls to F. -------
 100  k = ipjan
      iwk(ipian) = 1
      CALL f (neq, tn, y, savf)
      DO 120 j = 1,n
        IF (k .GT. liwk) GO TO 210
        iwk(k) = j
        k = k + 1
        yj = y(j)
        erwt = 1.0d0/ewt(j)
        dyj = sign(erwt,yj)
        y(j) = yj + dyj
        CALL f (neq, tn, y, ftem)
        y(j) = yj
        DO 110 i = 1,n
          dq = (ftem(i) - savf(i))/dyj
          IF (abs(dq) .LE. seth) GO TO 110
          IF (i .EQ. j) GO TO 110
          IF (k .GT. liwk) GO TO 210
          iwk(k) = i
          k = k + 1
 110      CONTINUE
        iwk(ipian+j) = k + 1 - ipjan
 120    CONTINUE
C
 140  CONTINUE
      IF (moss .EQ. 0 .OR. istatc .NE. 1) GO TO 150
C If ISTATE = 1 and MOSS .ne. 0, restore Y from YH. --------------------
      DO 145 i = 1,n
 145    y(i) = yh(i)
 150  nnz = iwk(ipian+n) - 1
      lenigp = 0
      ipigp = ipjan + nnz
      IF (miter .NE. 2) GO TO 160
C
C Compute grouping of column indices (MITER = 2). ----------------------
      maxg = np1
      ipjgp = ipjan + nnz
      ibjgp = ipjgp - 1
      ipigp = ipjgp + n
      iptt1 = ipigp + np1
      iptt2 = iptt1 + n
      lreq = iptt2 + n - 1
      IF (lreq .GT. liwk) GO TO 220
      CALL jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp),
     1   iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier)
      IF (ier .NE. 0) GO TO 220
      lenigp = ngp + 1
C
C Compute new ordering of rows/columns of Jacobian. --------------------
 160  ipr = ipigp + lenigp
      ipc = ipr
      ipic = ipc + n
      ipisp = ipic + n
      iprsp = (ipisp - 2)/lrat + 2
      iesp = lenwk + 1 - iprsp
      IF (iesp .LT. 0) GO TO 230
      ibr = ipr - 1
      DO 170 i = 1,n
 170    iwk(ibr+i) = i
      nsp = liwk + 1 - ipisp
      CALL odrv (n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic),
     1   nsp, iwk(ipisp), 1, iys)
      IF (iys .EQ. 11*n+1) GO TO 240
      IF (iys .NE. 0) GO TO 230
C
C Reorder JAN and do symbolic LU factorization of matrix. --------------
      ipa = lenwk + 1 - nnz
      nsp = ipa - iprsp
      lreq = max(12*n/lrat, 6*n/lrat+2*n+nnz) + 3
      lreq = lreq + iprsp - 1 + nnz
      IF (lreq .GT. lenwk) GO TO 250
      iba = ipa - 1
      DO 180 i = 1,nnz
 180    wk(iba+i) = 0.0d0
      ipisp = lrat*(iprsp - 1) + 1
      CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys)
      lreq = lenwk - iesp
      IF (iys .EQ. 10*n+1) GO TO 250
      IF (iys .NE. 0) GO TO 260
      ipil = ipisp
      ipiu = ipil + 2*n + 1
      nzu = iwk(ipil+n) - iwk(ipil)
      nzl = iwk(ipiu+n) - iwk(ipiu)
      IF (lrat .GT. 1) GO TO 190
      CALL adjlr (n, iwk(ipisp), ldif)
      lreq = lreq + ldif
 190  CONTINUE
      IF (lrat .EQ. 2 .AND. nnz .EQ. n) lreq = lreq + 1
      nsp = nsp + lreq - lenwk
      ipa = lreq + 1 - nnz
      iba = ipa - 1
      ipper = 0
      RETURN
C
 210  ipper = -1
      lreq = 2 + (2*n + 1)/lrat
      lreq = max(lenwk+1,lreq)
      RETURN
C
 220  ipper = -2
      lreq = (lreq - 1)/lrat + 1
      RETURN
C
 230  ipper = -3
      CALL cntnzu (n, iwk(ipian), iwk(ipjan), nzsut)
      lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1
      RETURN
C
 240  ipper = -4
      RETURN
C
 250  ipper = -5
      RETURN
C
 260  ipper = -6
      lreq = lenwk
      RETURN
C----------------------- End of Subroutine DPREP -----------------------
      END
*DECK JGROUP
      SUBROUTINE jgroup (N,IA,JA,MAXG,NGRP,IGP,JGP,INCL,JDONE,IER)
      INTEGER n, ia, ja, maxg, ngrp, igp, jgp, incl, jdone, ier
      dimension ia(*), ja(*), igp(*), jgp(*), incl(*), jdone(*)
C-----------------------------------------------------------------------
C This subroutine constructs groupings of the column indices of
C the Jacobian matrix, used in the numerical evaluation of the
C Jacobian by finite differences.
C
C Input:
C N      = the order of the matrix.
C IA,JA  = sparse structure descriptors of the matrix by rows.
C MAXG   = length of available storage in the IGP array.
C
C Output:
C NGRP   = number of groups.
C JGP    = array of length N containing the column indices by groups.
C IGP    = pointer array of length NGRP + 1 to the locations in JGP
C          of the beginning of each group.
C IER    = error indicator.  IER = 0 if no error occurred, or 1 if
C          MAXG was insufficient.
C
C INCL and JDONE are working arrays of length N.
C-----------------------------------------------------------------------
      INTEGER i, j, k, kmin, kmax, ncol, ng
C
      ier = 0
      DO 10 j = 1,n
 10     jdone(j) = 0
      ncol = 1
      DO 60 ng = 1,maxg
        igp(ng) = ncol
        DO 20 i = 1,n
 20       incl(i) = 0
        DO 50 j = 1,n
C Reject column J if it is already in a group.--------------------------
          IF (jdone(j) .EQ. 1) GO TO 50
          kmin = ia(j)
          kmax = ia(j+1) - 1
          DO 30 k = kmin,kmax
C Reject column J if it overlaps any column already in this group.------
            i = ja(k)
            IF (incl(i) .EQ. 1) GO TO 50
 30         CONTINUE
C Accept column J into group NG.----------------------------------------
          jgp(ncol) = j
          ncol = ncol + 1
          jdone(j) = 1
          DO 40 k = kmin,kmax
            i = ja(k)
 40         incl(i) = 1
 50       CONTINUE
C Stop if this group is empty (grouping is complete).-------------------
        IF (ncol .EQ. igp(ng)) GO TO 70
 60     CONTINUE
C Error return if not all columns were chosen (MAXG too small).---------
      IF (ncol .LE. n) GO TO 80
      ng = maxg
 70   ngrp = ng - 1
      RETURN
 80   ier = 1
      RETURN
C----------------------- End of Subroutine JGROUP ----------------------
      END
*DECK ADJLR
      SUBROUTINE adjlr (N, ISP, LDIF)
      INTEGER n, isp, ldif
      dimension isp(*)
C-----------------------------------------------------------------------
C This routine computes an adjustment, LDIF, to the required
C integer storage space in IWK (sparse matrix work space).
C It is called only if the word length ratio is LRAT = 1.
C This is to account for the possibility that the symbolic LU phase
C may require more storage than the numerical LU and solution phases.
C-----------------------------------------------------------------------
      INTEGER ip, jlmax, jumax, lnfc, lsfc, nzlu
C
      ip = 2*n + 1
C Get JLMAX = IJL(N) and JUMAX = IJU(N) (sizes of JL and JU). ----------
      jlmax = isp(ip)
      jumax = isp(ip+ip)
C NZLU = (size of L) + (size of U) = (IL(N+1)-IL(1)) + (IU(N+1)-IU(1)).
      nzlu = isp(n+1) - isp(1) + isp(ip+n+1) - isp(ip+1)
      lsfc = 12*n + 3 + 2*max(jlmax,jumax)
      lnfc = 9*n + 2 + jlmax + jumax + nzlu
      ldif = max(0, lsfc - lnfc)
      RETURN
C----------------------- End of Subroutine ADJLR -----------------------
      END
*DECK CNTNZU
      SUBROUTINE cntnzu (N, IA, JA, NZSUT)
      INTEGER n, ia, ja, nzsut
      dimension ia(*), ja(*)
C-----------------------------------------------------------------------
C This routine counts the number of nonzero elements in the strict
C upper triangle of the matrix M + M(transpose), where the sparsity
C structure of M is given by pointer arrays IA and JA.
C This is needed to compute the storage requirements for the
C sparse matrix reordering operation in ODRV.
C-----------------------------------------------------------------------
      INTEGER ii, jj, j, jmin, jmax, k, kmin, kmax, num
C
      num = 0
      DO 50 ii = 1,n
        jmin = ia(ii)
        jmax = ia(ii+1) - 1
        IF (jmin .GT. jmax) GO TO 50
        DO 40 j = jmin,jmax
          IF (ja(j) - ii) 10, 40, 30
 10       jj =ja(j)
          kmin = ia(jj)
          kmax = ia(jj+1) - 1
          IF (kmin .GT. kmax) GO TO 30
          DO 20 k = kmin,kmax
            IF (ja(k) .EQ. ii) GO TO 40
 20         CONTINUE
 30       num = num + 1
 40       CONTINUE
 50     CONTINUE
      nzsut = num
      RETURN
C----------------------- End of Subroutine CNTNZU ----------------------
      END
*DECK DPRJS
      SUBROUTINE dprjs (NEQ,Y,YH,NYH,EWT,FTEM,SAVF,WK,IWK,F,JAC)
      EXTERNAL f,jac
      INTEGER neq, nyh, iwk
      DOUBLE PRECISION y, yh, ewt, ftem, savf, wk
      dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*),
     1   wk(*), iwk(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION con0, conmin, ccmxj, psmall, rbig, seth
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ con0, conmin, ccmxj, psmall, rbig, seth,
     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
      INTEGER i, imul, j, jj, jok, jmax, jmin, k, kmax, kmin, ng
      DOUBLE PRECISION con, di, fac, hl0, pij, r, r0, rcon, rcont,
     1   srur, dvnorm
C-----------------------------------------------------------------------
C DPRJS is called to compute and process the matrix
C P = I - H*EL(1)*J , where J is an approximation to the Jacobian.
C J is computed by columns, either by the user-supplied routine JAC
C if MITER = 1, or by finite differencing if MITER = 2.
C if MITER = 3, a diagonal approximation to J is used.
C if MITER = 1 or 2, and if the existing value of the Jacobian
C (as contained in P) is considered acceptable, then a new value of
C P is reconstructed from the old value.  In any case, when MITER
C is 1 or 2, the P matrix is subjected to LU decomposition in CDRV.
C P and its LU decomposition are stored (separately) in WK.
C
C In addition to variables described previously, communication
C with DPRJS uses the following:
C Y     = array containing predicted values on entry.
C FTEM  = work array of length N (ACOR in DSTODE).
C SAVF  = array containing f evaluated at predicted y.
C WK    = real work space for matrices.  On output it contains the
C         inverse diagonal matrix if MITER = 3, and P and its sparse
C         LU decomposition if MITER is 1 or 2.
C         Storage of matrix elements starts at WK(3).
C         WK also contains the following matrix-related data:
C         WK(1) = SQRT(UROUND), used in numerical Jacobian increments.
C         WK(2) = H*EL0, saved for later use 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 EL0   = EL(1) (input).
C IERPJ = output error flag (in Common).
C       = 0 if no error.
C       = 1  if zero pivot found in CDRV.
C       = 2  if a singular matrix arose with MITER = 3.
C       = -1 if insufficient storage for CDRV (should not occur here).
C       = -2 if other error found in CDRV (should not occur here).
C JCUR  = output flag showing status of (approximate) Jacobian matrix:
C          = 1 to indicate that the Jacobian is now current, or
C          = 0 to indicate that a saved value was used.
C This routine also uses other variables in Common.
C-----------------------------------------------------------------------
      hl0 = h*el0
      con = -hl0
      IF (miter .EQ. 3) GO TO 300
C See whether J should be reevaluated (JOK = 0) or not (JOK = 1). ------
      jok = 1
      IF (nst .EQ. 0 .OR. nst .GE. nslj+msbj) jok = 0
      IF (icf .EQ. 1 .AND. abs(rc - 1.0d0) .LT. ccmxj) jok = 0
      IF (icf .EQ. 2) jok = 0
      IF (jok .EQ. 1) GO TO 250
C
C MITER = 1 or 2, and the Jacobian is to be reevaluated. ---------------
 20   jcur = 1
      nje = nje + 1
      nslj = nst
      iplost = 0
      conmin = abs(con)
      GO TO (100, 200), miter
C
C If MITER = 1, call JAC, multiply by scalar, and add identity. --------
 100  CONTINUE
      kmin = iwk(ipian)
      DO 130 j = 1, n
        kmax = iwk(ipian+j) - 1
        DO 110 i = 1,n
 110      ftem(i) = 0.0d0
        CALL jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), ftem)
        DO 120 k = kmin, kmax
          i = iwk(ibjan+k)
          wk(iba+k) = ftem(i)*con
          IF (i .EQ. j) wk(iba+k) = wk(iba+k) + 1.0d0
 120      CONTINUE
        kmin = kmax + 1
 130    CONTINUE
      GO TO 290
C
C If MITER = 2, make NGP calls to F to approximate J and P. ------------
 200  CONTINUE
      fac = dvnorm(n, savf, ewt)
      r0 = 1000.0d0 * abs(h) * uround * n * fac
      IF (r0 .EQ. 0.0d0) r0 = 1.0d0
      srur = wk(1)
      jmin = iwk(ipigp)
      DO 240 ng = 1,ngp
        jmax = iwk(ipigp+ng) - 1
        DO 210 j = jmin,jmax
          jj = iwk(ibjgp+j)
          r = max(srur*abs(y(jj)),r0/ewt(jj))
 210      y(jj) = y(jj) + r
        CALL f (neq, tn, y, ftem)
        DO 230 j = jmin,jmax
          jj = iwk(ibjgp+j)
          y(jj) = yh(jj,1)
          r = max(srur*abs(y(jj)),r0/ewt(jj))
          fac = -hl0/r
          kmin =iwk(ibian+jj)
          kmax =iwk(ibian+jj+1) - 1
          DO 220 k = kmin,kmax
            i = iwk(ibjan+k)
            wk(iba+k) = (ftem(i) - savf(i))*fac
            IF (i .EQ. jj) wk(iba+k) = wk(iba+k) + 1.0d0
 220        CONTINUE
 230      CONTINUE
        jmin = jmax + 1
 240    CONTINUE
      nfe = nfe + ngp
      GO TO 290
C
C If JOK = 1, reconstruct new P from old P. ----------------------------
 250  jcur = 0
      rcon = con/con0
      rcont = abs(con)/conmin
      IF (rcont .GT. rbig .AND. iplost .EQ. 1) GO TO 20
      kmin = iwk(ipian)
      DO 275 j = 1,n
        kmax = iwk(ipian+j) - 1
        DO 270 k = kmin,kmax
          i = iwk(ibjan+k)
          pij = wk(iba+k)
          IF (i .NE. j) GO TO 260
          pij = pij - 1.0d0
          IF (abs(pij) .GE. psmall) GO TO 260
            iplost = 1
            conmin = min(abs(con0),conmin)
 260      pij = pij*rcon
          IF (i .EQ. j) pij = pij + 1.0d0
          wk(iba+k) = pij
 270      CONTINUE
        kmin = kmax + 1
 275    CONTINUE
C
C Do numerical factorization of P matrix. ------------------------------
 290  nlu = nlu + 1
      con0 = con
      ierpj = 0
      DO 295 i = 1,n
 295    ftem(i) = 0.0d0
      CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),ftem,ftem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys)
      IF (iys .EQ. 0) RETURN
      imul = (iys - 1)/n
      ierpj = -2
      IF (imul .EQ. 8) ierpj = 1
      IF (imul .EQ. 10) ierpj = -1
      RETURN
C
C If MITER = 3, construct a diagonal approximation to J and P. ---------
 300  CONTINUE
      jcur = 1
      nje = nje + 1
      wk(2) = hl0
      ierpj = 0
      r = el0*0.1d0
      DO 310 i = 1,n
 310    y(i) = y(i) + r*(h*savf(i) - yh(i,2))
      CALL f (neq, tn, y, wk(3))
      nfe = nfe + 1
      DO 320 i = 1,n
        r0 = h*savf(i) - yh(i,2)
        di = 0.1d0*r0 - h*(wk(i+2) - savf(i))
        wk(i+2) = 1.0d0
        IF (abs(r0) .LT. uround/ewt(i)) GO TO 320
        IF (abs(di) .EQ. 0.0d0) GO TO 330
        wk(i+2) = 0.1d0*r0/di
 320    CONTINUE
      RETURN
 330  ierpj = 2
      RETURN
C----------------------- End of Subroutine DPRJS -----------------------
      END
*DECK DSOLSS
      SUBROUTINE dsolss (WK, IWK, X, TEM)
      INTEGER iwk
      DOUBLE PRECISION wk, x, tem
      dimension wk(*), iwk(*), x(*), tem(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rlss
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ 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
      INTEGER i
      DOUBLE PRECISION di, hl0, phl0, r
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 DSOLSS 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 (abs(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 DSOLSS ----------------------
      END
*DECK DSRCMS
      SUBROUTINE dsrcms (RSAV, ISAV, JOB)
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of
C the Common blocks DLS001, DLSS01, which are used
C internally by one or more ODEPACK solvers.
C
C RSAV = real array of length 224 or more.
C ISAV = integer array of length 71 or more.
C JOB  = flag indicating to save or restore the Common blocks:
C        JOB  = 1 if Common is to be saved (written to RSAV/ISAV)
C        JOB  = 2 if Common is to be restored (read from RSAV/ISAV)
C        A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
      INTEGER isav, job
      INTEGER ils, ilss
      INTEGER i, lenils, leniss, lenrls, lenrss
      DOUBLE PRECISION rsav,   rls, rlss
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils, lenrss, leniss
      COMMON /dls001/ rls(218), ils(37)
      COMMON /dlss01/ rlss(6), ilss(34)
      DATA lenrls/218/, lenils/37/, lenrss/6/, leniss/34/
C
      IF (job .EQ. 2) GO TO 100
      DO 10 i = 1,lenrls
 10     rsav(i) = rls(i)
      DO 15 i = 1,lenrss
 15     rsav(lenrls+i) = rlss(i)
C
      DO 20 i = 1,lenils
 20     isav(i) = ils(i)
      DO 25 i = 1,leniss
 25     isav(lenils+i) = ilss(i)
C
      RETURN
C
 100  CONTINUE
      DO 110 i = 1,lenrls
 110     rls(i) = rsav(i)
      DO 115 i = 1,lenrss
 115     rlss(i) = rsav(lenrls+i)
C
      DO 120 i = 1,lenils
 120     ils(i) = isav(i)
      DO 125 i = 1,leniss
 125     ilss(i) = isav(lenils+i)
C
      RETURN
C----------------------- End of Subroutine DSRCMS ----------------------
      END
*DECK ODRV
      subroutine odrv
     *     (n, ia,ja,a, p,ip, nsp,isp, path, flag)
c                                                                 5/2/83
c***********************************************************************
c  odrv -- driver for sparse matrix reordering routines
c***********************************************************************
c
c  description
c
c    odrv finds a minimum degree ordering of the rows and columns
c    of a matrix m stored in (ia,ja,a) format (see below).  for the
c    reordered matrix, the work and storage required to perform
c    gaussian elimination is (usually) significantly less.
c
c    note.. odrv and its subordinate routines have been modified to
c    compute orderings for general matrices, not necessarily having any
c    symmetry.  the miminum degree ordering is computed for the
c    structure of the symmetric matrix  m + m-transpose.
c    modifications to the original odrv module have been made in
c    the coding in subroutine mdi, and in the initial comments in
c    subroutines odrv and md.
c
c    if only the nonzero entries in the upper triangle of m are being
c    stored, then odrv symmetrically reorders (ia,ja,a), (optionally)
c    with the diagonal entries placed first in each row.  this is to
c    ensure that if m(i,j) will be in the upper triangle of m with
c    respect to the new ordering, then m(i,j) is stored in row i (and
c    thus m(j,i) is not stored),  whereas if m(i,j) will be in the
c    strict lower triangle of m, then m(j,i) is stored in row j (and
c    thus m(i,j) is not stored).
c
c
c  storage of sparse matrices
c
c    the nonzero entries of the matrix m are stored row-by-row in the
c    array a.  to identify the individual nonzero entries in each row,
c    we need to know in which column each entry lies.  these column
c    indices are stored in the array ja.  i.e., if  a(k) = m(i,j),  then
c    ja(k) = j.  to identify the individual rows, we need to know where
c    each row starts.  these row pointers are stored in the array ia.
c    i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row
c    and  a(k) = m(i,j),  then  ia(i) = k.  moreover, ia(n+1) points to
c    the first location following the last element in the last row.
c    thus, the number of entries in the i-th row is  ia(i+1) - ia(i),
c    the nonzero entries in the i-th row are stored consecutively in
c
c            a(ia(i)),  a(ia(i)+1),  ..., a(ia(i+1)-1),
c
c    and the corresponding column indices are stored consecutively in
c
c            ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1).
c
c    when the coefficient matrix is symmetric, only the nonzero entries
c    in the upper triangle need be stored.  for example, the matrix
c
c             ( 1  0  2  3  0 )
c             ( 0  4  0  0  0 )
c         m = ( 2  0  5  6  0 )
c             ( 3  0  6  7  8 )
c             ( 0  0  0  8  9 )
c
c    could be stored as
c
c            - 1  2  3  4  5  6  7  8  9 10 11 12 13
c         ---+--------------------------------------
c         ia - 1  4  5  8 12 14
c         ja - 1  3  4  2  1  3  4  1  3  4  5  4  5
c          a - 1  2  3  4  2  5  6  3  6  7  8  8  9
c
c    or (symmetrically) as
c
c            - 1  2  3  4  5  6  7  8  9
c         ---+--------------------------
c         ia - 1  4  5  7  9 10
c         ja - 1  3  4  2  3  4  4  5  5
c          a - 1  2  3  4  5  6  7  8  9          .
c
c
c  parameters
c
c    n    - order of the matrix
c
c    ia   - integer one-dimensional array containing pointers to delimit
c           rows in ja and a.  dimension = n+1
c
c    ja   - integer one-dimensional array containing the column indices
c           corresponding to the elements of a.  dimension = number of
c           nonzero entries in (the upper triangle of) m
c
c    a    - real one-dimensional array containing the nonzero entries in
c           (the upper triangle of) m, stored by rows.  dimension =
c           number of nonzero entries in (the upper triangle of) m
c
c    p    - integer one-dimensional array used to return the permutation
c           of the rows and columns of m corresponding to the minimum
c           degree ordering.  dimension = n
c
c    ip   - integer one-dimensional array used to return the inverse of
c           the permutation returned in p.  dimension = n
c
c    nsp  - declared dimension of the one-dimensional array isp.  nsp
c           must be at least  3n+4k,  where k is the number of nonzeroes
c           in the strict upper triangle of m
c
c    isp  - integer one-dimensional array used for working storage.
c           dimension = nsp
c
c    path - integer path specification.  values and their meanings are -
c             1  find minimum degree ordering only
c             2  find minimum degree ordering and reorder symmetrically
c                  stored matrix (used when only the nonzero entries in
c                  the upper triangle of m are being stored)
c             3  reorder symmetrically stored matrix as specified by
c                  input permutation (used when an ordering has already
c                  been determined and only the nonzero entries in the
c                  upper triangle of m are being stored)
c             4  same as 2 but put diagonal entries at start of each row
c             5  same as 3 but put diagonal entries at start of each row
c
c    flag - integer error flag.  values and their meanings are -
c               0    no errors detected
c              9n+k  insufficient storage in md
c             10n+1  insufficient storage in odrv
c             11n+1  illegal path specification
c
c
c  conversion from real to double precision
c
c    change the real declarations in odrv and sro to double precision
c    declarations.
c
c-----------------------------------------------------------------------
c
      integer  ia(*), ja(*),  p(*), ip(*),  isp(*),  path,  flag,
     *   v, l, head,  tmp, q
c...  real  a(*)
      double precision  a(*)
      logical  dflag
c
c----initialize error flag and validate path specification
      flag = 0
      if (path.lt.1 .or. 5.lt.path)  go to 111
c
c----allocate storage and find minimum degree ordering
      if ((path-1) * (path-2) * (path-4) .ne. 0)  go to 1
        max = (nsp-n)/2
        v    = 1
        l    = v     +  max
        head = l     +  max
        next = head  +  n
        if (max.lt.n)  go to 110
c
        call  md
     *     (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag)
        if (flag.ne.0)  go to 100
c
c----allocate storage and symmetrically reorder matrix
   1  if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0)  go to 2
        tmp = (nsp+1) -      n
        q   = tmp     - (ia(n+1)-1)
        if (q.lt.1)  go to 110
c
        dflag = path.eq.4 .or. path.eq.5
        call sro
     *     (n,  ip,  ia, ja, a,  isp(tmp),  isp(q),  dflag)
c
   2  return
c
c ** error -- error detected in md
 100  return
c ** error -- insufficient storage
 110  flag = 10*n + 1
      return
c ** error -- illegal path specified
 111  flag = 11*n + 1
      return
      end
      subroutine md
     *     (n, ia,ja, max, v,l, head,last,next, mark, flag)
c***********************************************************************
c  md -- minimum degree algorithm (based on element model)
c***********************************************************************
c
c  description
c
c    md finds a minimum degree ordering of the rows and columns of a
c    general sparse matrix m stored in (ia,ja,a) format.
c    when the structure of m is nonsymmetric, the ordering is that
c    obtained for the symmetric matrix  m + m-transpose.
c
c
c  additional parameters
c
c    max  - declared dimension of the one-dimensional arrays v and l.
c           max must be at least  n+2k,  where k is the number of
c           nonzeroes in the strict upper triangle of m + m-transpose
c
c    v    - integer one-dimensional work array.  dimension = max
c
c    l    - integer one-dimensional work array.  dimension = max
c
c    head - integer one-dimensional work array.  dimension = n
c
c    last - integer one-dimensional array used to return the permutation
c           of the rows and columns of m corresponding to the minimum
c           degree ordering.  dimension = n
c
c    next - integer one-dimensional array used to return the inverse of
c           the permutation returned in last.  dimension = n
c
c    mark - integer one-dimensional work array (may be the same as v).
c           dimension = n
c
c    flag - integer error flag.  values and their meanings are -
c             0     no errors detected
c             9n+k  insufficient storage in md
c
c
c  definitions of internal parameters
c
c    ---------+---------------------------------------------------------
c    v(s)     - value field of list entry
c    ---------+---------------------------------------------------------
c    l(s)     - link field of list entry  (0 =) end of list)
c    ---------+---------------------------------------------------------
c    l(vi)    - pointer to element list of uneliminated vertex vi
c    ---------+---------------------------------------------------------
c    l(ej)    - pointer to boundary list of active element ej
c    ---------+---------------------------------------------------------
c    head(d)  - vj =) vj head of d-list d
c             -  0 =) no vertex in d-list d
c
c
c             -                  vi uneliminated vertex
c             -          vi in ek           -       vi not in ek
c    ---------+-----------------------------+---------------------------
c    next(vi) - undefined but nonnegative   - vj =) vj next in d-list
c             -                             -  0 =) vi tail of d-list
c    ---------+-----------------------------+---------------------------
c    last(vi) - (not set until mdp)         - -d =) vi head of d-list d
c             --vk =) compute degree        - vj =) vj last in d-list
c             - ej =) vi prototype of ej    -  0 =) vi not in any d-list
c             -  0 =) do not compute degree -
c    ---------+-----------------------------+---------------------------
c    mark(vi) - mark(vk)                    - nonneg. tag .lt. mark(vk)
c
c
c             -                   vi eliminated vertex
c             -      ei active element      -           otherwise
c    ---------+-----------------------------+---------------------------
c    next(vi) - -j =) vi was j-th vertex    - -j =) vi was j-th vertex
c             -       to be eliminated      -       to be eliminated
c    ---------+-----------------------------+---------------------------
c    last(vi) -  m =) size of ei = m        - undefined
c    ---------+-----------------------------+---------------------------
c    mark(vi) - -m =) overlap count of ei   - undefined
c             -       with ek = m           -
c             - otherwise nonnegative tag   -
c             -       .lt. mark(vk)         -
c
c-----------------------------------------------------------------------
c
      integer  ia(*), ja(*),  v(*), l(*),  head(*), last(*), next(*),
     *   mark(*),  flag,  tag, dmin, vk,ek, tail
      equivalence(vk,ek)
c
c----initialization
      tag = 0
      call  mdi
     *   (n, ia,ja, max,v,l, head,last,next, mark,tag, flag)
      if (flag.ne.0)  return
c
      k = 0
      dmin = 1
c
c----while  k .lt. n  do
   1  if (k.ge.n)  go to 4
c
c------search for vertex of minimum degree
   2    if (head(dmin).gt.0)  go to 3
          dmin = dmin + 1
          go to 2
c
c------remove vertex vk of minimum degree from degree list
   3    vk = head(dmin)
        head(dmin) = next(vk)
        if (head(dmin).gt.0)  last(head(dmin)) = -dmin
c
c------number vertex vk, adjust tag, and tag vk
        k = k+1
        next(vk) = -k
        last(ek) = dmin - 1
        tag = tag + last(ek)
        mark(vk) = tag
c
c------form element ek from uneliminated neighbors of vk
        call  mdm
     *     (vk,tail, v,l, last,next, mark)
c
c------purge inactive elements and do mass elimination
        call  mdp
     *     (k,ek,tail, v,l, head,last,next, mark)
c
c------update degrees of uneliminated vertices in ek
        call  mdu
     *     (ek,dmin, v,l, head,last,next, mark)
c
        go to 1
c
c----generate inverse permutation from permutation
   4  do 5 k=1,n
        next(k) = -next(k)
   5    last(next(k)) = k
c
      return
      end
      subroutine mdi
     *     (n, ia,ja, max,v,l, head,last,next, mark,tag, flag)
c***********************************************************************
c  mdi -- initialization
c***********************************************************************
      integer  ia(*), ja(*),  v(*), l(*),  head(*), last(*), next(*),
     *   mark(*), tag,  flag,  sfs, vi,dvi, vj
c
c----initialize degrees, element lists, and degree lists
      do 1 vi=1,n
        mark(vi) = 1
        l(vi) = 0
   1    head(vi) = 0
      sfs = n+1
c
c----create nonzero structure
c----for each nonzero entry a(vi,vj)
      do 6 vi=1,n
        jmin = ia(vi)
        jmax = ia(vi+1) - 1
        if (jmin.gt.jmax)  go to 6
        do 5 j=jmin,jmax
          vj = ja(j)
          if (vj-vi) 2, 5, 4
c
c------if a(vi,vj) is in strict lower triangle
c------check for previous occurrence of a(vj,vi)
   2      lvk = vi
          kmax = mark(vi) - 1
          if (kmax .eq. 0) go to 4
          do 3 k=1,kmax
            lvk = l(lvk)
            if (v(lvk).eq.vj) go to 5
   3        continue
c----for unentered entries a(vi,vj)
   4        if (sfs.ge.max)  go to 101
c
c------enter vj in element list for vi
            mark(vi) = mark(vi) + 1
            v(sfs) = vj
            l(sfs) = l(vi)
            l(vi) = sfs
            sfs = sfs+1
c
c------enter vi in element list for vj
            mark(vj) = mark(vj) + 1
            v(sfs) = vi
            l(sfs) = l(vj)
            l(vj) = sfs
            sfs = sfs+1
   5      continue
   6    continue
c
c----create degree lists and initialize mark vector
      do 7 vi=1,n
        dvi = mark(vi)
        next(vi) = head(dvi)
        head(dvi) = vi
        last(vi) = -dvi
        nextvi = next(vi)
        if (nextvi.gt.0)  last(nextvi) = vi
   7    mark(vi) = tag
c
      return
c
c ** error-  insufficient storage
 101  flag = 9*n + vi
      return
      end
      subroutine mdm
     *     (vk,tail, v,l, last,next, mark)
c***********************************************************************
c  mdm -- form element from uneliminated neighbors of vk
c***********************************************************************
      integer  vk, tail,  v(*), l(*),   last(*), next(*),   mark(*),
     *   tag, s,ls,vs,es, b,lb,vb, blp,blpmax
      equivalence(vs, es)
c
c----initialize tag and list of uneliminated neighbors
      tag = mark(vk)
      tail = vk
c
c----for each vertex/element vs/es in element list of vk
      ls = l(vk)
   1  s = ls
      if (s.eq.0)  go to 5
        ls = l(s)
        vs = v(s)
        if (next(vs).lt.0)  go to 2
c
c------if vs is uneliminated vertex, then tag and append to list of
c------uneliminated neighbors
          mark(vs) = tag
          l(tail) = s
          tail = s
          go to 4
c
c------if es is active element, then ...
c--------for each vertex vb in boundary list of element es
   2      lb = l(es)
          blpmax = last(es)
          do 3 blp=1,blpmax
            b = lb
            lb = l(b)
            vb = v(b)
c
c----------if vb is untagged vertex, then tag and append to list of
c----------uneliminated neighbors
            if (mark(vb).ge.tag)  go to 3
              mark(vb) = tag
              l(tail) = b
              tail = b
   3        continue
c
c--------mark es inactive
          mark(es) = tag
c
   4    go to 1
c
c----terminate list of uneliminated neighbors
   5  l(tail) = 0
c
      return
      end
      subroutine mdp
     *     (k,ek,tail, v,l, head,last,next, mark)
c***********************************************************************
c  mdp -- purge inactive elements and do mass elimination
c***********************************************************************
      integer  ek, tail,  v(*), l(*),  head(*), last(*), next(*),
     *   mark(*),  tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax
c
c----initialize tag
      tag = mark(ek)
c
c----for each vertex vi in ek
      li = ek
      ilpmax = last(ek)
      if (ilpmax.le.0)  go to 12
      do 11 ilp=1,ilpmax
        i = li
        li = l(i)
        vi = v(li)
c
c------remove vi from degree list
        if (last(vi).eq.0)  go to 3
          if (last(vi).gt.0)  go to 1
            head(-last(vi)) = next(vi)
            go to 2
   1        next(last(vi)) = next(vi)
   2      if (next(vi).gt.0)  last(next(vi)) = last(vi)
c
c------remove inactive items from element list of vi
   3    ls = vi
   4    s = ls
        ls = l(s)
        if (ls.eq.0)  go to 6
          es = v(ls)
          if (mark(es).lt.tag)  go to 5
            free = ls
            l(s) = l(ls)
            ls = s
   5      go to 4
c
c------if vi is interior vertex, then remove from list and eliminate
   6    lvi = l(vi)
        if (lvi.ne.0)  go to 7
          l(i) = l(li)
          li = i
c
          k = k+1
          next(vi) = -k
          last(ek) = last(ek) - 1
          go to 11
c
c------else ...
c--------classify vertex vi
   7      if (l(lvi).ne.0)  go to 9
            evi = v(lvi)
            if (next(evi).ge.0)  go to 9
              if (mark(evi).lt.0)  go to 8
c
c----------if vi is prototype vertex, then mark as such, initialize
c----------overlap count for corresponding element, and move vi to end
c----------of boundary list
                last(vi) = evi
                mark(evi) = -1
                l(tail) = li
                tail = li
                l(i) = l(li)
                li = i
                go to 10
c
c----------else if vi is duplicate vertex, then mark as such and adjust
c----------overlap count for corresponding element
   8            last(vi) = 0
                mark(evi) = mark(evi) - 1
                go to 10
c
c----------else mark vi to compute degree
   9            last(vi) = -ek
c
c--------insert ek in element list of vi
  10      v(free) = ek
          l(free) = l(vi)
          l(vi) = free
  11    continue
c
c----terminate boundary list
  12  l(tail) = 0
c
      return
      end
      subroutine mdu
     *     (ek,dmin, v,l, head,last,next, mark)
c***********************************************************************
c  mdu -- update degrees of uneliminated vertices in ek
c***********************************************************************
      integer  ek, dmin,  v(*), l(*),  head(*), last(*), next(*),
     *   mark(*),  tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax,
     *   blp,blpmax
      equivalence(vs, es)
c
c----initialize tag
      tag = mark(ek) - last(ek)
c
c----for each vertex vi in ek
      i = ek
      ilpmax = last(ek)
      if (ilpmax.le.0)  go to 11
      do 10 ilp=1,ilpmax
        i = l(i)
        vi = v(i)
        if (last(vi))  1, 10, 8
c
c------if vi neither prototype nor duplicate vertex, then merge elements
c------to compute degree
   1      tag = tag + 1
          dvi = last(ek)
c
c--------for each vertex/element vs/es in element list of vi
          s = l(vi)
   2      s = l(s)
          if (s.eq.0)  go to 9
            vs = v(s)
            if (next(vs).lt.0)  go to 3
c
c----------if vs is uneliminated vertex, then tag and adjust degree
              mark(vs) = tag
              dvi = dvi + 1
              go to 5
c
c----------if es is active element, then expand
c------------check for outmatched vertex
   3          if (mark(es).lt.0)  go to 6
c
c------------for each vertex vb in es
              b = es
              blpmax = last(es)
              do 4 blp=1,blpmax
                b = l(b)
                vb = v(b)
c
c--------------if vb is untagged, then tag and adjust degree
                if (mark(vb).ge.tag)  go to 4
                  mark(vb) = tag
                  dvi = dvi + 1
   4            continue
c
   5        go to 2
c
c------else if vi is outmatched vertex, then adjust overlaps but do not
c------compute degree
   6      last(vi) = 0
          mark(es) = mark(es) - 1
   7      s = l(s)
          if (s.eq.0)  go to 10
            es = v(s)
            if (mark(es).lt.0)  mark(es) = mark(es) - 1
            go to 7
c
c------else if vi is prototype vertex, then calculate degree by
c------inclusion/exclusion and reset overlap count
   8      evi = last(vi)
          dvi = last(ek) + last(evi) + mark(evi)
          mark(evi) = 0
c
c------insert vi in appropriate degree list
   9    next(vi) = head(dvi)
        head(dvi) = vi
        last(vi) = -dvi
        if (next(vi).gt.0)  last(next(vi)) = vi
        if (dvi.lt.dmin)  dmin = dvi
c
  10    continue
c
  11  return
      end
      subroutine sro
     *     (n, ip, ia,ja,a, q, r, dflag)
c***********************************************************************
c  sro -- symmetric reordering of sparse symmetric matrix
c***********************************************************************
c
c  description
c
c    the nonzero entries of the matrix m are assumed to be stored
c    symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i)
c    are stored if i ne j).
c
c    sro does not rearrange the order of the rows, but does move
c    nonzeroes from one row to another to ensure that if m(i,j) will be
c    in the upper triangle of m with respect to the new ordering, then
c    m(i,j) is stored in row i (and thus m(j,i) is not stored),  whereas
c    if m(i,j) will be in the strict lower triangle of m, then m(j,i) is
c    stored in row j (and thus m(i,j) is not stored).
c
c
c  additional parameters
c
c    q     - integer one-dimensional work array.  dimension = n
c
c    r     - integer one-dimensional work array.  dimension = number of
c            nonzero entries in the upper triangle of m
c
c    dflag - logical variable.  if dflag = .true., then store nonzero
c            diagonal elements at the beginning of the row
c
c-----------------------------------------------------------------------
c
      integer  ip(*),  ia(*), ja(*),  q(*), r(*)
c...  real  a(*),  ak
      double precision  a(*),  ak
      logical  dflag
c
c
c--phase 1 -- find row in which to store each nonzero
c----initialize count of nonzeroes to be stored in each row
      do 1 i=1,n
  1     q(i) = 0
c
c----for each nonzero element a(j)
      do 3 i=1,n
        jmin = ia(i)
        jmax = ia(i+1) - 1
        if (jmin.gt.jmax)  go to 3
        do 2 j=jmin,jmax
c
c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ...
          k = ja(j)
          if (ip(k).lt.ip(i))  ja(j) = i
          if (ip(k).ge.ip(i))  k = i
          r(j) = k
c
c--------... and increment count of nonzeroes (=q(r(j)) in that row
  2       q(k) = q(k) + 1
  3     continue
c
c
c--phase 2 -- find new ia and permutation to apply to (ja,a)
c----determine pointers to delimit rows in permuted (ja,a)
      do 4 i=1,n
        ia(i+1) = ia(i) + q(i)
  4     q(i) = ia(i+1)
c
c----determine where each (ja(j),a(j)) is stored in permuted (ja,a)
c----for each nonzero element (in reverse order)
      ilast = 0
      jmin = ia(1)
      jmax = ia(n+1) - 1
      j = jmax
      do 6 jdummy=jmin,jmax
        i = r(j)
        if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast)  go to 5
c
c------if dflag, then put diagonal nonzero at beginning of row
          r(j) = ia(i)
          ilast = i
          go to 6
c
c------put (off-diagonal) nonzero in last unused location in row
  5       q(i) = q(i) - 1
          r(j) = q(i)
c
  6     j = j-1
c
c
c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering)
      do 8 j=jmin,jmax
  7     if (r(j).eq.j)  go to 8
          k = r(j)
          r(j) = r(k)
          r(k) = k
          jak = ja(k)
          ja(k) = ja(j)
          ja(j) = jak
          ak = a(k)
          a(k) = a(j)
          a(j) = ak
          go to 7
  8     continue
c
      return
      end
*DECK CDRV
      subroutine cdrv
     *     (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag)
c*** subroutine cdrv
c*** driver for subroutines for solving sparse nonsymmetric systems of
c       linear equations (compressed pointer storage)
c
c
c    parameters
c    class abbreviations are--
c       n - integer variable
c       f - real variable
c       v - supplies a value to the driver
c       r - returns a result from the driver
c       i - used internally by the driver
c       a - array
c
c class - parameter
c ------+----------
c       -
c         the nonzero entries of the coefficient matrix m are stored
c    row-by-row in the array a.  to identify the individual nonzero
c    entries in each row, we need to know in which column each entry
c    lies.  the column indices which correspond to the nonzero entries
c    of m are stored in the array ja.  i.e., if  a(k) = m(i,j),  then
c    ja(k) = j.  in addition, we need to know where each row starts and
c    how long it is.  the index positions in ja and a where the rows of
c    m begin are stored in the array ia.  i.e., if m(i,j) is the first
c    nonzero entry (stored) in the i-th row and a(k) = m(i,j),  then
c    ia(i) = k.  moreover, the index in ja and a of the first location
c    following the last element in the last row is stored in ia(n+1).
c    thus, the number of entries in the i-th row is given by
c    ia(i+1) - ia(i),  the nonzero entries of the i-th row are stored
c    consecutively in
c            a(ia(i)),  a(ia(i)+1),  ..., a(ia(i+1)-1),
c    and the corresponding column indices are stored consecutively in
c            ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1).
c    for example, the 5 by 5 matrix
c                ( 1. 0. 2. 0. 0.)
c                ( 0. 3. 0. 0. 0.)
c            m = ( 0. 4. 5. 6. 0.)
c                ( 0. 0. 0. 7. 0.)
c                ( 0. 0. 0. 8. 9.)
c    would be stored as
c               - 1  2  3  4  5  6  7  8  9
c            ---+--------------------------
c            ia - 1  3  4  7  8 10
c            ja - 1  3  2  2  3  4  4  4  5
c             a - 1. 2. 3. 4. 5. 6. 7. 8. 9.         .
c
c nv    - n     - number of variables/equations.
c fva   - a     - nonzero entries of the coefficient matrix m, stored
c       -           by rows.
c       -           size = number of nonzero entries in m.
c nva   - ia    - pointers to delimit the rows in a.
c       -           size = n+1.
c nva   - ja    - column numbers corresponding to the elements of a.
c       -           size = size of a.
c fva   - b     - right-hand side b.  b and z can the same array.
c       -           size = n.
c fra   - z     - solution x.  b and z can be the same array.
c       -           size = n.
c
c         the rows and columns of the original matrix m can be
c    reordered (e.g., to reduce fillin or ensure numerical stability)
c    before calling the driver.  if no reordering is done, then set
c    r(i) = c(i) = ic(i) = i  for i=1,...,n.  the solution z is returned
c    in the original order.
c         if the columns have been reordered (i.e.,  c(i).ne.i  for some
c    i), then the driver will call a subroutine (nroc) which rearranges
c    each row of ja and a, leaving the rows in the original order, but
c    placing the elements of each row in increasing order with respect
c    to the new ordering.  if  path.ne.1,  then nroc is assumed to have
c    been called already.
c
c nva   - r     - ordering of the rows of m.
c       -           size = n.
c nva   - c     - ordering of the columns of m.
c       -           size = n.
c nva   - ic    - inverse of the ordering of the columns of m.  i.e.,
c       -           ic(c(i)) = i  for i=1,...,n.
c       -           size = n.
c
c         the solution of the system of linear equations is divided into
c    three stages --
c      nsfc -- the matrix m is processed symbolically to determine where
c               fillin will occur during the numeric factorization.
c      nnfc -- the matrix m is factored numerically into the product ldu
c               of a unit lower triangular matrix l, a diagonal matrix
c               d, and a unit upper triangular matrix u, and the system
c               mx = b  is solved.
c      nnsc -- the linear system  mx = b  is solved using the ldu
c  or           factorization from nnfc.
c      nntc -- the transposed linear system  mt x = b  is solved using
c               the ldu factorization from nnf.
c    for several systems whose coefficient matrices have the same
c    nonzero structure, nsfc need be done only once (for the first
c    system).  then nnfc is done once for each additional system.  for
c    several systems with the same coefficient matrix, nsfc and nnfc
c    need be done only once (for the first system).  then nnsc or nntc
c    is done once for each additional right-hand side.
c
c nv    - path  - path specification.  values and their meanings are --
c       -           1  perform nroc, nsfc, and nnfc.
c       -           2  perform nnfc only  (nsfc is assumed to have been
c       -               done in a manner compatible with the storage
c       -               allocation used in the driver).
c       -           3  perform nnsc only  (nsfc and nnfc are assumed to
c       -               have been done in a manner compatible with the
c       -               storage allocation used in the driver).
c       -           4  perform nntc only  (nsfc and nnfc are assumed to
c       -               have been done in a manner compatible with the
c       -               storage allocation used in the driver).
c       -           5  perform nroc and nsfc.
c
c         various errors are detected by the driver and the individual
c    subroutines.
c
c nr    - flag  - error flag.  values and their meanings are --
c       -             0     no errors detected
c       -             n+k   null row in a  --  row = k
c       -            2n+k   duplicate entry in a  --  row = k
c       -            3n+k   insufficient storage in nsfc  --  row = k
c       -            4n+1   insufficient storage in nnfc
c       -            5n+k   null pivot  --  row = k
c       -            6n+k   insufficient storage in nsfc  --  row = k
c       -            7n+1   insufficient storage in nnfc
c       -            8n+k   zero pivot  --  row = k
c       -           10n+1   insufficient storage in cdrv
c       -           11n+1   illegal path specification
c
c         working storage is needed for the factored form of the matrix
c    m plus various temporary vectors.  the arrays isp and rsp should be
c    equivalenced.  integer storage is allocated from the beginning of
c    isp and real storage from the end of rsp.
c
c nv    - nsp   - declared dimension of rsp.  nsp generally must
c       -           be larger than  8n+2 + 2k  (where  k = (number of
c       -           nonzero entries in m)).
c nvira - isp   - integer working storage divided up into various arrays
c       -           needed by the subroutines.  isp and rsp should be
c       -           equivalenced.
c       -           size = lratio*nsp.
c fvira - rsp   - real working storage divided up into various arrays
c       -           needed by the subroutines.  isp and rsp should be
c       -           equivalenced.
c       -           size = nsp.
c nr    - esp   - if sufficient storage was available to perform the
c       -           symbolic factorization (nsfc), then esp is set to
c       -           the amount of excess storage provided (negative if
c       -           insufficient storage was available to perform the
c       -           numeric factorization (nnfc)).
c
c
c  conversion to double precision
c
c    to convert these routines for double precision arrays..
c    (1) use the double precision declarations in place of the real
c    declarations in each subprogram, as given in comment cards.
c    (2) change the data-loaded value of the integer  lratio
c    in subroutine cdrv, as indicated below.
c    (3) change e0 to d0 in the constants in statement number 10
c    in subroutine nnfc and the line following that.
c
      integer  r(*), c(*), ic(*),  ia(*), ja(*),  isp(*), esp,  path,
     *   flag,  d, u, q, row, tmp, ar,  umax
c     real  a(*), b(*), z(*), rsp(*)
      double precision  a(*), b(*), z(*), rsp(*)
c
c  set lratio equal to the ratio between the length of floating point
c  and integer array data.  e. g., lratio = 1 for (real, integer),
c  lratio = 2 for (double precision, integer)
c
      data lratio/2/
c
      if (path.lt.1 .or. 5.lt.path)  go to 111
c******initialize and divide up temporary storage  *******************
      il   = 1
      ijl  = il  + (n+1)
      iu   = ijl +   n
      iju  = iu  + (n+1)
      irl  = iju +   n
      jrl  = irl +   n
      jl   = jrl +   n
c
c  ******  reorder a if necessary, call nsfc if flag is set  ***********
      if ((path-1) * (path-5) .ne. 0)  go to 5
        max = (lratio*nsp + 1 - jl) - (n+1) - 5*n
        jlmax = max/2
        q     = jl   + jlmax
        ira   = q    + (n+1)
        jra   = ira  +   n
        irac  = jra  +   n
        iru   = irac +   n
        jru   = iru  +   n
        jutmp = jru  +   n
        jumax = lratio*nsp  + 1 - jutmp
        esp = max/lratio
        if (jlmax.le.0 .or. jumax.le.0)  go to 110
c
        do 1 i=1,n
          if (c(i).ne.i)  go to 2
   1      continue
        go to 3
   2    ar = nsp + 1 - n
        call  nroc
     *     (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag)
        if (flag.ne.0)  go to 100
c
   3    call  nsfc
     *     (n, r, ic, ia,ja,
     *      jlmax, isp(il), isp(jl), isp(ijl),
     *      jumax, isp(iu), isp(jutmp), isp(iju),
     *      isp(q), isp(ira), isp(jra), isp(irac),
     *      isp(irl), isp(jrl), isp(iru), isp(jru),  flag)
        if(flag .ne. 0)  go to 100
c  ******  move ju next to jl  *****************************************
        jlmax = isp(ijl+n-1)
        ju    = jl + jlmax
        jumax = isp(iju+n-1)
        if (jumax.le.0)  go to 5
        do 4 j=1,jumax
   4      isp(ju+j-1) = isp(jutmp+j-1)
c
c  ******  call remaining subroutines  *********************************
   5  jlmax = isp(ijl+n-1)
      ju    = jl  + jlmax
      jumax = isp(iju+n-1)
      l     = (ju + jumax - 2 + lratio)  /  lratio    +    1
      lmax  = isp(il+n) - 1
      d     = l   + lmax
      u     = d   + n
      row   = nsp + 1 - n
      tmp   = row - n
      umax  = tmp - u
      esp   = umax - (isp(iu+n) - 1)
c
      if ((path-1) * (path-2) .ne. 0)  go to 6
        if (umax.lt.0)  go to 110
        call nnfc
     *     (n,  r, c, ic,  ia, ja, a, z, b,
     *      lmax, isp(il), isp(jl), isp(ijl), rsp(l),  rsp(d),
     *      umax, isp(iu), isp(ju), isp(iju), rsp(u),
     *      rsp(row), rsp(tmp),  isp(irl), isp(jrl),  flag)
        if(flag .ne. 0)  go to 100
c
   6  if ((path-3) .ne. 0)  go to 7
        call nnsc
     *     (n,  r, c,  isp(il), isp(jl), isp(ijl), rsp(l),
     *      rsp(d),    isp(iu), isp(ju), isp(iju), rsp(u),
     *      z, b,  rsp(tmp))
c
   7  if ((path-4) .ne. 0)  go to 8
        call nntc
     *     (n,  r, c,  isp(il), isp(jl), isp(ijl), rsp(l),
     *      rsp(d),    isp(iu), isp(ju), isp(iju), rsp(u),
     *      z, b,  rsp(tmp))
   8  return
c
c ** error.. error detected in nroc, nsfc, nnfc, or nnsc
 100  return
c ** error.. insufficient storage
 110  flag = 10*n + 1
      return
c ** error.. illegal path specification
 111  flag = 11*n + 1
      return
      end
      subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag)
c
c       ----------------------------------------------------------------
c
c               yale sparse matrix package - nonsymmetric codes
c                    solving the system of equations mx = b
c
c    i.   calling sequences
c         the coefficient matrix can be processed by an ordering routine
c    (e.g., to reduce fillin or ensure numerical stability) before using
c    the remaining subroutines.  if no reordering is done, then set
c    r(i) = c(i) = ic(i) = i  for i=1,...,n.  if an ordering subroutine
c    is used, then nroc should be used to reorder the coefficient matrix
c    the calling sequence is --
c        (       (matrix ordering))
c        (nroc   (matrix reordering))
c         nsfc   (symbolic factorization to determine where fillin will
c                  occur during numeric factorization)
c         nnfc   (numeric factorization into product ldu of unit lower
c                  triangular matrix l, diagonal matrix d, and unit
c                  upper triangular matrix u, and solution of linear
c                  system)
c         nnsc   (solution of linear system for additional right-hand
c                  side using ldu factorization from nnfc)
c    (if only one system of equations is to be solved, then the
c    subroutine trk should be used.)
c
c    ii.  storage of sparse matrices
c         the nonzero entries of the coefficient matrix m are stored
c    row-by-row in the array a.  to identify the individual nonzero
c    entries in each row, we need to know in which column each entry
c    lies.  the column indices which correspond to the nonzero entries
c    of m are stored in the array ja.  i.e., if  a(k) = m(i,j),  then
c    ja(k) = j.  in addition, we need to know where each row starts and
c    how long it is.  the index positions in ja and a where the rows of
c    m begin are stored in the array ia.  i.e., if m(i,j) is the first
c    (leftmost) entry in the i-th row and  a(k) = m(i,j),  then
c    ia(i) = k.  moreover, the index in ja and a of the first location
c    following the last element in the last row is stored in ia(n+1).
c    thus, the number of entries in the i-th row is given by
c    ia(i+1) - ia(i),  the nonzero entries of the i-th row are stored
c    consecutively in
c            a(ia(i)),  a(ia(i)+1),  ..., a(ia(i+1)-1),
c    and the corresponding column indices are stored consecutively in
c            ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1).
c    for example, the 5 by 5 matrix
c                ( 1. 0. 2. 0. 0.)
c                ( 0. 3. 0. 0. 0.)
c            m = ( 0. 4. 5. 6. 0.)
c                ( 0. 0. 0. 7. 0.)
c                ( 0. 0. 0. 8. 9.)
c    would be stored as
c               - 1  2  3  4  5  6  7  8  9
c            ---+--------------------------
c            ia - 1  3  4  7  8 10
c            ja - 1  3  2  2  3  4  4  4  5
c             a - 1. 2. 3. 4. 5. 6. 7. 8. 9.         .
c
c         the strict upper (lower) triangular portion of the matrix
c    u (l) is stored in a similar fashion using the arrays  iu, ju, u
c    (il, jl, l)  except that an additional array iju (ijl) is used to
c    compress storage of ju (jl) by allowing some sequences of column
c    (row) indices to used for more than one row (column)  (n.b., l is
c    stored by columns).  iju(k) (ijl(k)) points to the starting
c    location in ju (jl) of entries for the kth row (column).
c    compression in ju (jl) occurs in two ways.  first, if a row
c    (column) i was merged into the current row (column) k, and the
c    number of elements merged in from (the tail portion of) row
c    (column) i is the same as the final length of row (column) k, then
c    the kth row (column) and the tail of row (column) i are identical
c    and iju(k) (ijl(k)) points to the start of the tail.  second, if
c    some tail portion of the (k-1)st row (column) is identical to the
c    head of the kth row (column), then iju(k) (ijl(k)) points to the
c    start of that tail portion.  for example, the nonzero structure of
c    the strict upper triangular part of the matrix
c            d 0 x x x
c            0 d 0 x x
c            0 0 d x 0
c            0 0 0 d x
c            0 0 0 0 d
c    would be represented as
c                - 1 2 3 4 5 6
c            ----+------------
c             iu - 1 4 6 7 8 8
c             ju - 3 4 5 4
c            iju - 1 2 4 3           .
c    the diagonal entries of l and u are assumed to be equal to one and
c    are not stored.  the array d contains the reciprocals of the
c    diagonal entries of the matrix d.
c
c    iii. additional storage savings
c         in nsfc, r and ic can be the same array in the calling
c    sequence if no reordering of the coefficient matrix has been done.
c         in nnfc, r, c, and ic can all be the same array if no
c    reordering has been done.  if only the rows have been reordered,
c    then c and ic can be the same array.  if the row and column
c    orderings are the same, then r and c can be the same array.  z and
c    row can be the same array.
c         in nnsc or nntc, r and c can be the same array if no
c    reordering has been done or if the row and column orderings are the
c    same.  z and b can be the same array.  however, then b will be
c    destroyed.
c
c    iv.  parameters
c         following is a list of parameters to the programs.  names are
c    uniform among the various subroutines.  class abbreviations are --
c       n - integer variable
c       f - real variable
c       v - supplies a value to a subroutine
c       r - returns a result from a subroutine
c       i - used internally by a subroutine
c       a - array
c
c class - parameter
c ------+----------
c fva   - a     - nonzero entries of the coefficient matrix m, stored
c       -           by rows.
c       -           size = number of nonzero entries in m.
c fva   - b     - right-hand side b.
c       -           size = n.
c nva   - c     - ordering of the columns of m.
c       -           size = n.
c fvra  - d     - reciprocals of the diagonal entries of the matrix d.
c       -           size = n.
c nr    - flag  - error flag.  values and their meanings are --
c       -            0     no errors detected
c       -            n+k   null row in a  --  row = k
c       -           2n+k   duplicate entry in a  --  row = k
c       -           3n+k   insufficient storage for jl  --  row = k
c       -           4n+1   insufficient storage for l
c       -           5n+k   null pivot  --  row = k
c       -           6n+k   insufficient storage for ju  --  row = k
c       -           7n+1   insufficient storage for u
c       -           8n+k   zero pivot  --  row = k
c nva   - ia    - pointers to delimit the rows of a.
c       -           size = n+1.
c nvra  - ijl   - pointers to the first element in each column in jl,
c       -           used to compress storage in jl.
c       -           size = n.
c nvra  - iju   - pointers to the first element in each row in ju, used
c       -           to compress storage in ju.
c       -           size = n.
c nvra  - il    - pointers to delimit the columns of l.
c       -           size = n+1.
c nvra  - iu    - pointers to delimit the rows of u.
c       -           size = n+1.
c nva   - ja    - column numbers corresponding to the elements of a.
c       -           size = size of a.
c nvra  - jl    - row numbers corresponding to the elements of l.
c       -           size = jlmax.
c nv    - jlmax - declared dimension of jl.  jlmax must be larger than
c       -           the number of nonzeros in the strict lower triangle
c       -           of m plus fillin minus compression.
c nvra  - ju    - column numbers corresponding to the elements of u.
c       -           size = jumax.
c nv    - jumax - declared dimension of ju.  jumax must be larger than
c       -           the number of nonzeros in the strict upper triangle
c       -           of m plus fillin minus compression.
c fvra  - l     - nonzero entries in the strict lower triangular portion
c       -           of the matrix l, stored by columns.
c       -           size = lmax.
c nv    - lmax  - declared dimension of l.  lmax must be larger than
c       -           the number of nonzeros in the strict lower triangle
c       -           of m plus fillin  (il(n+1)-1 after nsfc).
c nv    - n     - number of variables/equations.
c nva   - r     - ordering of the rows of m.
c       -           size = n.
c fvra  - u     - nonzero entries in the strict upper triangular portion
c       -           of the matrix u, stored by rows.
c       -           size = umax.
c nv    - umax  - declared dimension of u.  umax must be larger than
c       -           the number of nonzeros in the strict upper triangle
c       -           of m plus fillin  (iu(n+1)-1 after nsfc).
c fra   - z     - solution x.
c       -           size = n.
c
c       ----------------------------------------------------------------
c
c*** subroutine nroc
c*** reorders rows of a, leaving row order unchanged
c
c
c       input parameters.. n, ic, ia, ja, a
c       output parameters.. ja, a, flag
c
c       parameters used internally..
c nia   - p     - at the kth step, p is a linked list of the reordered
c       -           column indices of the kth row of a.  p(n+1) points
c       -           to the first entry in the list.
c       -           size = n+1.
c nia   - jar   - at the kth step,jar contains the elements of the
c       -           reordered column indices of a.
c       -           size = n.
c fia   - ar    - at the kth step, ar contains the elements of the
c       -           reordered row of a.
c       -           size = n.
c
      integer  ic(*), ia(*), ja(*), jar(*), p(*), flag
c     real  a(*), ar(*)
      double precision  a(*), ar(*)
c
c  ******  for each nonempty row  *******************************
      do 5 k=1,n
        jmin = ia(k)
        jmax = ia(k+1) - 1
        if(jmin .gt. jmax) go to 5
        p(n+1) = n + 1
c  ******  insert each element in the list  *********************
        do 3 j=jmin,jmax
          newj = ic(ja(j))
          i = n + 1
   1      if(p(i) .ge. newj) go to 2
            i = p(i)
            go to 1
   2      if(p(i) .eq. newj) go to 102
          p(newj) = p(i)
          p(i) = newj
          jar(newj) = ja(j)
          ar(newj) = a(j)
   3      continue
c  ******  replace old row in ja and a  *************************
        i = n + 1
        do 4 j=jmin,jmax
          i = p(i)
          ja(j) = jar(i)
   4      a(j) = ar(i)
   5    continue
      flag = 0
      return
c
c ** error.. duplicate entry in a
 102  flag = n + k
      return
      end
      subroutine nsfc
     *      (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju,
     *       q, ira,jra, irac, irl,jrl, iru,jru, flag)
c*** subroutine nsfc
c*** symbolic ldu-factorization of nonsymmetric sparse matrix
c      (compressed pointer storage)
c
c
c       input variables.. n, r, ic, ia, ja, jlmax, jumax.
c       output variables.. il, jl, ijl, iu, ju, iju, flag.
c
c       parameters used internally..
c nia   - q     - suppose  m*  is the result of reordering  m.  if
c       -           processing of the ith row of  m*  (hence the ith
c       -           row of  u) is being done,  q(j)  is initially
c       -           nonzero if  m*(i,j) is nonzero (j.ge.i).  since
c       -           values need not be stored, each entry points to the
c       -           next nonzero and  q(n+1)  points to the first.  n+1
c       -           indicates the end of the list.  for example, if n=9
c       -           and the 5th row of  m*  is
c       -              0 x x 0 x 0 0 x 0
c       -           then  q  will initially be
c       -              a a a a 8 a a 10 5           (a - arbitrary).
c       -           as the algorithm proceeds, other elements of  q
c       -           are inserted in the list because of fillin.
c       -           q  is used in an analogous manner to compute the
c       -           ith column of  l.
c       -           size = n+1.
c nia   - ira,  - vectors used to find the columns of  m.  at the kth
c nia   - jra,      step of the factorization,  irac(k)  points to the
c nia   - irac      head of a linked list in  jra  of row indices i
c       -           such that i .ge. k and  m(i,k)  is nonzero.  zero
c       -           indicates the end of the list.  ira(i)  (i.ge.k)
c       -           points to the smallest j such that j .ge. k and
c       -           m(i,j)  is nonzero.
c       -           size of each = n.
c nia   - irl,  - vectors used to find the rows of  l.  at the kth step
c nia   - jrl       of the factorization,  jrl(k)  points to the head
c       -           of a linked list in  jrl  of column indices j
c       -           such j .lt. k and  l(k,j)  is nonzero.  zero
c       -           indicates the end of the list.  irl(j)  (j.lt.k)
c       -           points to the smallest i such that i .ge. k and
c       -           l(i,j)  is nonzero.
c       -           size of each = n.
c nia   - iru,  - vectors used in a manner analogous to  irl and jrl
c nia   - jru       to find the columns of  u.
c       -           size of each = n.
c
c  internal variables..
c    jlptr - points to the last position used in  jl.
c    juptr - points to the last position used in  ju.
c    jmin,jmax - are the indices in  a or u  of the first and last
c                elements to be examined in a given row.
c                for example,  jmin=ia(k), jmax=ia(k+1)-1.
c
      integer cend, qm, rend, rk, vj
      integer ia(*), ja(*), ira(*), jra(*), il(*), jl(*), ijl(*)
      integer iu(*), ju(*), iju(*), irl(*), jrl(*), iru(*), jru(*)
      integer r(*), ic(*), q(*), irac(*), flag
c
c  ******  initialize pointers  ****************************************
      np1 = n + 1
      jlmin = 1
      jlptr = 0
      il(1) = 1
      jumin = 1
      juptr = 0
      iu(1) = 1
      do 1 k=1,n
        irac(k) = 0
        jra(k) = 0
        jrl(k) = 0
   1    jru(k) = 0
c  ******  initialize column pointers for a  ***************************
      do 2 k=1,n
        rk = r(k)
        iak = ia(rk)
        if (iak .ge. ia(rk+1))  go to 101
        jaiak = ic(ja(iak))
        if (jaiak .gt. k)  go to 105
        jra(k) = irac(jaiak)
        irac(jaiak) = k
   2    ira(k) = iak
c
c  ******  for each column of l and row of u  **************************
      do 41 k=1,n
c
c  ******  initialize q for computing kth column of l  *****************
        q(np1) = np1
        luk = -1
c  ******  by filling in kth column of a  ******************************
        vj = irac(k)
        if (vj .eq. 0)  go to 5
   3      qm = np1
   4      m = qm
          qm =  q(m)
          if (qm .lt. vj)  go to 4
          if (qm .eq. vj)  go to 102
            luk = luk + 1
            q(m) = vj
            q(vj) = qm
            vj = jra(vj)
            if (vj .ne. 0)  go to 3
c  ******  link through jru  *******************************************
   5    lastid = 0
        lasti = 0
        ijl(k) = jlptr
        i = k
   6      i = jru(i)
          if (i .eq. 0)  go to 10
          qm = np1
          jmin = irl(i)
          jmax = ijl(i) + il(i+1) - il(i) - 1
          long = jmax - jmin
          if (long .lt. 0)  go to 6
          jtmp = jl(jmin)
          if (jtmp .ne. k)  long = long + 1
          if (jtmp .eq. k)  r(i) = -r(i)
          if (lastid .ge. long)  go to 7
            lasti = i
            lastid = long
c  ******  and merge the corresponding columns into the kth column  ****
   7      do 9 j=jmin,jmax
            vj = jl(j)
   8        m = qm
            qm = q(m)
            if (qm .lt. vj)  go to 8
            if (qm .eq. vj)  go to 9
              luk = luk + 1
              q(m) = vj
              q(vj) = qm
              qm = vj
   9        continue
            go to 6
c  ******  lasti is the longest column merged into the kth  ************
c  ******  see if it equals the entire kth column  *********************
  10    qm = q(np1)
        if (qm .ne. k)  go to 105
        if (luk .eq. 0)  go to 17
        if (lastid .ne. luk)  go to 11
c  ******  if so, jl can be compressed  ********************************
        irll = irl(lasti)
        ijl(k) = irll + 1
        if (jl(irll) .ne. k)  ijl(k) = ijl(k) - 1
        go to 17
c  ******  if not, see if kth column can overlap the previous one  *****
  11    if (jlmin .gt. jlptr)  go to 15
        qm = q(qm)
        do 12 j=jlmin,jlptr
          if (jl(j) - qm)  12, 13, 15
  12      continue
        go to 15
  13    ijl(k) = j
        do 14 i=j,jlptr
          if (jl(i) .ne. qm)  go to 15
          qm = q(qm)
          if (qm .gt. n)  go to 17
  14      continue
        jlptr = j - 1
c  ******  move column indices from q to jl, update vectors  ***********
  15    jlmin = jlptr + 1
        ijl(k) = jlmin
        if (luk .eq. 0)  go to 17
        jlptr = jlptr + luk
        if (jlptr .gt. jlmax)  go to 103
          qm = q(np1)
          do 16 j=jlmin,jlptr
            qm = q(qm)
  16        jl(j) = qm
  17    irl(k) = ijl(k)
        il(k+1) = il(k) + luk
c
c  ******  initialize q for computing kth row of u  ********************
        q(np1) = np1
        luk = -1
c  ******  by filling in kth row of reordered a  ***********************
        rk = r(k)
        jmin = ira(k)
        jmax = ia(rk+1) - 1
        if (jmin .gt. jmax)  go to 20
        do 19 j=jmin,jmax
          vj = ic(ja(j))
          qm = np1
  18      m = qm
          qm = q(m)
          if (qm .lt. vj)  go to 18
          if (qm .eq. vj)  go to 102
            luk = luk + 1
            q(m) = vj
            q(vj) = qm
  19      continue
c  ******  link through jrl,  ******************************************
  20    lastid = 0
        lasti = 0
        iju(k) = juptr
        i = k
        i1 = jrl(k)
  21      i = i1
          if (i .eq. 0)  go to 26
          i1 = jrl(i)
          qm = np1
          jmin = iru(i)
          jmax = iju(i) + iu(i+1) - iu(i) - 1
          long = jmax - jmin
          if (long .lt. 0)  go to 21
          jtmp = ju(jmin)
          if (jtmp .eq. k)  go to 22
c  ******  update irl and jrl, *****************************************
            long = long + 1
            cend = ijl(i) + il(i+1) - il(i)
            irl(i) = irl(i) + 1
            if (irl(i) .ge. cend)  go to 22
              j = jl(irl(i))
              jrl(i) = jrl(j)
              jrl(j) = i
  22      if (lastid .ge. long)  go to 23
            lasti = i
            lastid = long
c  ******  and merge the corresponding rows into the kth row  **********
  23      do 25 j=jmin,jmax
            vj = ju(j)
  24        m = qm
            qm = q(m)
            if (qm .lt. vj)  go to 24
            if (qm .eq. vj)  go to 25
              luk = luk + 1
              q(m) = vj
              q(vj) = qm
              qm = vj
  25        continue
          go to 21
c  ******  update jrl(k) and irl(k)  ***********************************
  26    if (il(k+1) .le. il(k))  go to 27
          j = jl(irl(k))
          jrl(k) = jrl(j)
          jrl(j) = k
c  ******  lasti is the longest row merged into the kth  ***************
c  ******  see if it equals the entire kth row  ************************
  27    qm = q(np1)
        if (qm .ne. k)  go to 105
        if (luk .eq. 0)  go to 34
        if (lastid .ne. luk)  go to 28
c  ******  if so, ju can be compressed  ********************************
        irul = iru(lasti)
        iju(k) = irul + 1
        if (ju(irul) .ne. k)  iju(k) = iju(k) - 1
        go to 34
c  ******  if not, see if kth row can overlap the previous one  ********
  28    if (jumin .gt. juptr)  go to 32
        qm = q(qm)
        do 29 j=jumin,juptr
          if (ju(j) - qm)  29, 30, 32
  29      continue
        go to 32
  30    iju(k) = j
        do 31 i=j,juptr
          if (ju(i) .ne. qm)  go to 32
          qm = q(qm)
          if (qm .gt. n)  go to 34
  31      continue
        juptr = j - 1
c  ******  move row indices from q to ju, update vectors  **************
  32    jumin = juptr + 1
        iju(k) = jumin
        if (luk .eq. 0)  go to 34
        juptr = juptr + luk
        if (juptr .gt. jumax)  go to 106
          qm = q(np1)
          do 33 j=jumin,juptr
            qm = q(qm)
  33        ju(j) = qm
  34    iru(k) = iju(k)
        iu(k+1) = iu(k) + luk
c
c  ******  update iru, jru  ********************************************
        i = k
  35      i1 = jru(i)
          if (r(i) .lt. 0)  go to 36
          rend = iju(i) + iu(i+1) - iu(i)
          if (iru(i) .ge. rend)  go to 37
            j = ju(iru(i))
            jru(i) = jru(j)
            jru(j) = i
            go to 37
  36      r(i) = -r(i)
  37      i = i1
          if (i .eq. 0)  go to 38
          iru(i) = iru(i) + 1
          go to 35
c
c  ******  update ira, jra, irac  **************************************
  38    i = irac(k)
        if (i .eq. 0)  go to 41
  39      i1 = jra(i)
          ira(i) = ira(i) + 1
          if (ira(i) .ge. ia(r(i)+1))  go to 40
          irai = ira(i)
          jairai = ic(ja(irai))
          if (jairai .gt. i)  go to 40
          jra(i) = irac(jairai)
          irac(jairai) = i
  40      i = i1
          if (i .ne. 0)  go to 39
  41    continue
c
      ijl(n) = jlptr
      iju(n) = juptr
      flag = 0
      return
c
c ** error.. null row in a
 101  flag = n + rk
      return
c ** error.. duplicate entry in a
 102  flag = 2*n + rk
      return
c ** error.. insufficient storage for jl
 103  flag = 3*n + k
      return
c ** error.. null pivot
 105  flag = 5*n + k
      return
c ** error.. insufficient storage for ju
 106  flag = 6*n + k
      return
      end
      subroutine nnfc
     *     (n, r,c,ic, ia,ja,a, z, b,
     *      lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u,
     *      row, tmp, irl,jrl, flag)
c*** subroutine nnfc
c*** numerical ldu-factorization of sparse nonsymmetric matrix and
c      solution of system of linear equations (compressed pointer
c      storage)
c
c
c       input variables..  n, r, c, ic, ia, ja, a, b,
c                          il, jl, ijl, lmax, iu, ju, iju, umax
c       output variables.. z, l, d, u, flag
c
c       parameters used internally..
c nia   - irl,  - vectors used to find the rows of  l.  at the kth step
c nia   - jrl       of the factorization,  jrl(k)  points to the head
c       -           of a linked list in  jrl  of column indices j
c       -           such j .lt. k and  l(k,j)  is nonzero.  zero
c       -           indicates the end of the list.  irl(j)  (j.lt.k)
c       -           points to the smallest i such that i .ge. k and
c       -           l(i,j)  is nonzero.
c       -           size of each = n.
c fia   - row   - holds intermediate values in calculation of  u and l.
c       -           size = n.
c fia   - tmp   - holds new right-hand side  b*  for solution of the
c       -           equation ux = b*.
c       -           size = n.
c
c  internal variables..
c    jmin, jmax - indices of the first and last positions in a row to
c      be examined.
c    sum - used in calculating  tmp.
c
      integer rk,umax
      integer  r(*), c(*), ic(*), ia(*), ja(*), il(*), jl(*), ijl(*)
      integer  iu(*), ju(*), iju(*), irl(*), jrl(*), flag
c     real  a(*), l(*), d(*), u(*), z(*), b(*), row(*)
c     real tmp(*), lki, sum, dk
      double precision  a(*), l(*), d(*), u(*), z(*), b(*), row(*)
      double precision  tmp(*), lki, sum, dk
c
c  ******  initialize pointers and test storage  ***********************
      if(il(n+1)-1 .gt. lmax) go to 104
      if(iu(n+1)-1 .gt. umax) go to 107
      do 1 k=1,n
        irl(k) = il(k)
        jrl(k) = 0
   1    continue
c
c  ******  for each row  ***********************************************
      do 19 k=1,n
c  ******  reverse jrl and zero row where kth row of l will fill in  ***
        row(k) = 0
        i1 = 0
        if (jrl(k) .eq. 0) go to 3
        i = jrl(k)
   2    i2 = jrl(i)
        jrl(i) = i1
        i1 = i
        row(i) = 0
        i = i2
        if (i .ne. 0) go to 2
c  ******  set row to zero where u will fill in  ***********************
   3    jmin = iju(k)
        jmax = jmin + iu(k+1) - iu(k) - 1
        if (jmin .gt. jmax) go to 5
        do 4 j=jmin,jmax
   4      row(ju(j)) = 0
c  ******  place kth row of a in row  **********************************
   5    rk = r(k)
        jmin = ia(rk)
        jmax = ia(rk+1) - 1
        do 6 j=jmin,jmax
          row(ic(ja(j))) = a(j)
   6      continue
c  ******  initialize sum, and link through jrl  ***********************
        sum = b(rk)
        i = i1
        if (i .eq. 0) go to 10
c  ******  assign the kth row of l and adjust row, sum  ****************
   7      lki = -row(i)
c  ******  if l is not required, then comment out the following line  **
          l(irl(i)) = -lki
          sum = sum + lki * tmp(i)
          jmin = iu(i)
          jmax = iu(i+1) - 1
          if (jmin .gt. jmax) go to 9
          mu = iju(i) - jmin
          do 8 j=jmin,jmax
   8        row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j)
   9      i = jrl(i)
          if (i .ne. 0) go to 7
c
c  ******  assign kth row of u and diagonal d, set tmp(k)  *************
  10    if (row(k) .eq. 0.0d0) go to 108
        dk = 1.0d0 / row(k)
        d(k) = dk
        tmp(k) = sum * dk
        if (k .eq. n) go to 19
        jmin = iu(k)
        jmax = iu(k+1) - 1
        if (jmin .gt. jmax)  go to 12
        mu = iju(k) - jmin
        do 11 j=jmin,jmax
  11      u(j) = row(ju(mu+j)) * dk
  12    continue
c
c  ******  update irl and jrl, keeping jrl in decreasing order  ********
        i = i1
        if (i .eq. 0) go to 18
  14    irl(i) = irl(i) + 1
        i1 = jrl(i)
        if (irl(i) .ge. il(i+1)) go to 17
        ijlb = irl(i) - il(i) + ijl(i)
        j = jl(ijlb)
  15    if (i .gt. jrl(j)) go to 16
          j = jrl(j)
          go to 15
  16    jrl(i) = jrl(j)
        jrl(j) = i
  17    i = i1
        if (i .ne. 0) go to 14
  18    if (irl(k) .ge. il(k+1)) go to 19
        j = jl(ijl(k))
        jrl(k) = jrl(j)
        jrl(j) = k
  19    continue
c
c  ******  solve  ux = tmp  by back substitution  **********************
      k = n
      do 22 i=1,n
        sum =  tmp(k)
        jmin = iu(k)
        jmax = iu(k+1) - 1
        if (jmin .gt. jmax)  go to 21
        mu = iju(k) - jmin
        do 20 j=jmin,jmax
  20      sum = sum - u(j) * tmp(ju(mu+j))
  21    tmp(k) =  sum
        z(c(k)) =  sum
  22    k = k-1
      flag = 0
      return
c
c ** error.. insufficient storage for l
 104  flag = 4*n + 1
      return
c ** error.. insufficient storage for u
 107  flag = 7*n + 1
      return
c ** error.. zero pivot
 108  flag = 8*n + k
      return
      end
      subroutine nnsc
     *     (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp)
c*** subroutine nnsc
c*** numerical solution of sparse nonsymmetric system of linear
c      equations given ldu-factorization (compressed pointer storage)
c
c
c       input variables..  n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b
c       output variables.. z
c
c       parameters used internally..
c fia   - tmp   - temporary vector which gets result of solving  ly = b.
c       -           size = n.
c
c  internal variables..
c    jmin, jmax - indices of the first and last positions in a row of
c      u or l  to be used.
c
      integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*)
c     real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk, sum
      double precision  l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum
c
c  ******  set tmp to reordered b  *************************************
      do 1 k=1,n
   1    tmp(k) = b(r(k))
c  ******  solve  ly = b  by forward substitution  *********************
      do 3 k=1,n
        jmin = il(k)
        jmax = il(k+1) - 1
        tmpk = -d(k) * tmp(k)
        tmp(k) = -tmpk
        if (jmin .gt. jmax) go to 3
        ml = ijl(k) - jmin
        do 2 j=jmin,jmax
   2      tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j)
   3    continue
c  ******  solve  ux = y  by back substitution  ************************
      k = n
      do 6 i=1,n
        sum = -tmp(k)
        jmin = iu(k)
        jmax = iu(k+1) - 1
        if (jmin .gt. jmax) go to 5
        mu = iju(k) - jmin
        do 4 j=jmin,jmax
   4      sum = sum + u(j) * tmp(ju(mu+j))
   5    tmp(k) = -sum
        z(c(k)) = -sum
        k = k - 1
   6    continue
      return
      end
      subroutine nntc
     *     (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp)
c*** subroutine nntc
c*** numeric solution of the transpose of a sparse nonsymmetric system
c      of linear equations given lu-factorization (compressed pointer
c      storage)
c
c
c       input variables..  n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b
c       output variables.. z
c
c       parameters used internally..
c fia   - tmp   - temporary vector which gets result of solving ut y = b
c       -           size = n.
c
c  internal variables..
c    jmin, jmax - indices of the first and last positions in a row of
c      u or l  to be used.
c
      integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*)
c     real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum
      double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum
c
c  ******  set tmp to reordered b  *************************************
      do 1 k=1,n
   1    tmp(k) = b(c(k))
c  ******  solve  ut y = b  by forward substitution  *******************
      do 3 k=1,n
        jmin = iu(k)
        jmax = iu(k+1) - 1
        tmpk = -tmp(k)
        if (jmin .gt. jmax) go to 3
        mu = iju(k) - jmin
        do 2 j=jmin,jmax
   2      tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j)
   3    continue
c  ******  solve  lt x = y  by back substitution  **********************
      k = n
      do 6 i=1,n
        sum = -tmp(k)
        jmin = il(k)
        jmax = il(k+1) - 1
        if (jmin .gt. jmax) go to 5
        ml = ijl(k) - jmin
        do 4 j=jmin,jmax
   4      sum = sum + l(j) * tmp(jl(ml+j))
   5    tmp(k) = -sum * d(k)
        z(r(k)) = tmp(k)
        k = k - 1
   6    continue
      return
      end
*DECK DSTODA
      SUBROUTINE dstoda (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR,
     1   WM, IWM, F, JAC, PJAC, SLVS)
      EXTERNAL f, jac, pjac, slvs
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, yh1, ewt, savf, acor, wm
      dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*),
     1   acor(*), wm(*), iwm(*)
      INTEGER iownd, ialth, ipup, lmax, meo, nqnyh, nslp,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER iownd2, icount, irflag, jtyp, mused, mxordn, mxords
      DOUBLE PRECISION conit, crate, el, elco, hold, rmax, tesco,
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rownd2, cm1, cm2, pdest, pdlast, ratio,
     1   pdnorm
      COMMON /dls001/ conit, crate, el(13), elco(13,12),
     1   hold, rmax, tesco(3,12),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(6), ialth, ipup, lmax, meo, nqnyh, nslp,
     4   icf, ierpj, iersl, jcur, jstart, kflag, l,
     5   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     6   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlsa01/ rownd2, cm1(12), cm2(5), pdest, pdlast, ratio,
     1   pdnorm,
     2   iownd2(3), icount, irflag, jtyp, mused, mxordn, mxords
      INTEGER i, i1, iredo, iret, j, jb, m, ncf, newq
      INTEGER lm1, lm1p1, lm2, lm2p1, nqm1, nqm2
      DOUBLE PRECISION dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup,
     1   r, rh, rhdn, rhsm, rhup, told, dmnorm
      DOUBLE PRECISION alpha, dm1,dm2, exm1,exm2,
     1   pdh, pnorm, rate, rh1, rh1it, rh2, rm, sm1(12)
      SAVE sm1
      DATA sm1/0.5d0, 0.575d0, 0.55d0, 0.45d0, 0.35d0, 0.25d0,
     1   0.20d0, 0.15d0, 0.10d0, 0.075d0, 0.050d0, 0.025d0/
C-----------------------------------------------------------------------
C DSTODA performs one step of the integration of an initial value
C problem for a system of ordinary differential equations.
C Note: DSTODA is independent of the value of the iteration method
C indicator MITER, when this is .ne. 0, and hence is independent
C of the type of chord method used, or the Jacobian structure.
C Communication with DSTODA is done with the following variables:
C
C Y      = an array of length .ge. N used as the Y argument in
C          all calls to F and JAC.
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls to F and JAC.
C YH     = an NYH by LMAX array containing the dependent variables
C          and their approximate scaled derivatives, where
C          LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C          j-th derivative of y(i), scaled by H**j/factorial(j)
C          (j = 0,1,...,NQ).  On entry for the first step, the first
C          two columns of YH must be set from the initial values.
C NYH    = a constant integer .ge. N, the first dimension of YH.
C YH1    = a one-dimensional array occupying the same space as YH.
C EWT    = an array of length N containing multiplicative weights
C          for local error measurements.  Local errors in y(i) are
C          compared to 1.0/EWT(i) in various error tests.
C SAVF   = an array of working storage, of length N.
C ACOR   = a work array of length N, used for the accumulated
C          corrections.  On a successful return, ACOR(i) contains
C          the estimated one-step local error in y(i).
C WM,IWM = real and integer work arrays associated with matrix
C          operations in chord iteration (MITER .ne. 0).
C PJAC   = name of routine to evaluate and preprocess Jacobian matrix
C          and P = I - H*EL0*Jac, if a chord method is being used.
C          It also returns an estimate of norm(Jac) in PDNORM.
C SLVS   = name of routine to solve linear system in chord iteration.
C CCMAX  = maximum relative change in H*EL0 before PJAC is called.
C H      = the step size to be attempted on the next step.
C          H is altered by the error control algorithm during the
C          problem.  H can be either positive or negative, but its
C          sign must remain constant throughout the problem.
C HMIN   = the minimum absolute value of the step size H to be used.
C HMXI   = inverse of the maximum absolute value of H to be used.
C          HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C          HMIN and HMXI may be changed at any time, but will not
C          take effect until the next change of H is considered.
C TN     = the independent variable. TN is updated on each step taken.
C JSTART = an integer used for input only, with the following
C          values and meanings:
C               0  perform the first step.
C           .gt.0  take a new step continuing from the last.
C              -1  take the next step with a new value of H,
C                    N, METH, MITER, and/or matrix parameters.
C              -2  take the next step with a new value of H,
C                    but with other inputs unchanged.
C          On return, JSTART is set to 1 to facilitate continuation.
C KFLAG  = a completion code with the following meanings:
C               0  the step was succesful.
C              -1  the requested error could not be achieved.
C              -2  corrector convergence could not be achieved.
C              -3  fatal error in PJAC or SLVS.
C          A return with KFLAG = -1 or -2 means either
C          ABS(H) = HMIN or 10 consecutive failures occurred.
C          On a return with KFLAG negative, the values of TN and
C          the YH array are as of the beginning of the last
C          step, and H is the last step size attempted.
C MAXORD = the maximum order of integration method to be allowed.
C MAXCOR = the maximum number of corrector iterations allowed.
C MSBP   = maximum number of steps between PJAC calls (MITER .gt. 0).
C MXNCF  = maximum number of convergence failures allowed.
C METH   = current method.
C          METH = 1 means Adams method (nonstiff)
C          METH = 2 means BDF method (stiff)
C          METH may be reset by DSTODA.
C MITER  = corrector iteration method.
C          MITER = 0 means functional iteration.
C          MITER = JT .gt. 0 means a chord iteration corresponding
C          to Jacobian type JT.  (The DLSODA/DLSODAR argument JT is
C          communicated here as JTYP, but is not used in DSTODA
C          except to load MITER following a method switch.)
C          MITER may be reset by DSTODA.
C N      = the number of first-order differential equations.
C-----------------------------------------------------------------------
      kflag = 0
      told = tn
      ncf = 0
      ierpj = 0
      iersl = 0
      jcur = 0
      icf = 0
      delp = 0.0d0
      IF (jstart .GT. 0) GO TO 200
      IF (jstart .EQ. -1) GO TO 100
      IF (jstart .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set at 2
C for the next increase.
C DCFODE is called to get the needed coefficients for both methods.
C-----------------------------------------------------------------------
      lmax = maxord + 1
      nq = 1
      l = 2
      ialth = 2
      rmax = 10000.0d0
      rc = 0.0d0
      el0 = 1.0d0
      crate = 0.7d0
      hold = h
      nslp = 0
      ipup = miter
      iret = 3
C Initialize switching parameters.  METH = 1 is assumed initially. -----
      icount = 20
      irflag = 0
      pdest = 0.0d0
      pdlast = 0.0d0
      ratio = 5.0d0
      CALL dcfode (2, elco, tesco)
      DO 10 i = 1,5
 10     cm2(i) = tesco(2,i)*elco(i+1,i)
      CALL dcfode (1, elco, tesco)
      DO 20 i = 1,12
 20     cm1(i) = tesco(2,i)*elco(i+1,i)
      GO TO 150
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  ipup = miter
      lmax = maxord + 1
      IF (ialth .EQ. 1) ialth = 2
      IF (meth .EQ. mused) GO TO 160
      CALL dcfode (meth, elco, tesco)
      ialth = l
      iret = 1
C-----------------------------------------------------------------------
C The el vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 150  DO 155 i = 1,l
 155    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      GO TO (160, 170, 200), iret
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (h .EQ. hold) GO TO 200
      rh = h/hold
      h = hold
      iredo = 3
      GO TO 175
 170  rh = max(rh,hmin/abs(h))
 175  rh = min(rh,rmax)
      rh = rh/max(1.0d0,abs(h)*hmxi*rh)
C-----------------------------------------------------------------------
C If METH = 1, also restrict the new step size by the stability region.
C If this reduces H, set IRFLAG to 1 so that if there are roundoff
C problems later, we can assume that is the cause of the trouble.
C-----------------------------------------------------------------------
      IF (meth .EQ. 2) GO TO 178
      irflag = 0
      pdh = max(abs(h)*pdlast,0.000001d0)
      IF (rh*pdh*1.00001d0 .LT. sm1(nq)) GO TO 178
      rh = sm1(nq)/pdh
      irflag = 1
 178  CONTINUE
      r = 1.0d0
      DO 180 j = 2,l
        r = r*rh
        DO 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
      h = h*rh
      rc = rc*rh
      ialth = l
      IF (iredo .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C When RC differs from 1 by more than CCMAX, IPUP is set to MITER
C to force PJAC to be called, if a Jacobian is involved.
C In any case, PJAC is called at least every MSBP steps.
C-----------------------------------------------------------------------
 200  IF (abs(rc-1.0d0) .GT. ccmax) ipup = miter
      IF (nst .GE. nslp+msbp) ipup = miter
      tn = tn + h
      i1 = nqnyh + 1
      DO 215 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 210 i = i1,nqnyh
 210      yh1(i) = yh1(i) + yh1(i+nyh)
 215    CONTINUE
      pnorm = dmnorm(n, yh1, ewt)
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the RMS-norm of each correction, weighted by the error
C weight vector EWT.  The sum of the corrections is accumulated in the
C vector ACOR(i).  The YH array is not altered in the corrector loop.
C-----------------------------------------------------------------------
 220  m = 0
      rate = 0.0d0
      del = 0.0d0
      DO 230 i = 1,n
 230    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      IF (ipup .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, the matrix P = I - H*EL(1)*J is reevaluated and
C preprocessed before starting the corrector iteration.  IPUP is set
C to 0 as an indicator that this has been done.
C-----------------------------------------------------------------------
      CALL pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac)
      ipup = 0
      rc = 1.0d0
      nslp = nst
      crate = 0.7d0
      IF (ierpj .NE. 0) GO TO 430
 250  DO 260 i = 1,n
 260    acor(i) = 0.0d0
 270  IF (miter .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation.
C-----------------------------------------------------------------------
      DO 290 i = 1,n
        savf(i) = h*savf(i) - yh(i,2)
 290    y(i) = savf(i) - acor(i)
      del = dmnorm(n, y, ewt)
      DO 300 i = 1,n
        y(i) = yh(i,1) + el(1)*savf(i)
 300    acor(i) = savf(i)
      GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix.
C-----------------------------------------------------------------------
 350  DO 360 i = 1,n
 360    y(i) = h*savf(i) - (yh(i,2) + acor(i))
      CALL slvs (wm, iwm, y, savf)
      IF (iersl .LT. 0) GO TO 430
      IF (iersl .GT. 0) GO TO 410
      del = dmnorm(n, y, ewt)
      DO 380 i = 1,n
        acor(i) = acor(i) + y(i)
 380    y(i) = yh(i,1) + el(1)*acor(i)
C-----------------------------------------------------------------------
C Test for convergence.  If M .gt. 0, an estimate of the convergence
C rate constant is stored in CRATE, and this is used in the test.
C
C We first check for a change of iterates that is the size of
C roundoff error.  If this occurs, the iteration has converged, and a
C new rate estimate is not formed.
C In all other cases, force at least two iterations to estimate a
C local Lipschitz constant estimate for Adams methods.
C On convergence, form PDEST = local maximum Lipschitz constant
C estimate.  PDLAST is the most recent nonzero estimate.
C-----------------------------------------------------------------------
 400  CONTINUE
      IF (del .LE. 100.0d0*pnorm*uround) GO TO 450
      IF (m .EQ. 0 .AND. meth .EQ. 1) GO TO 405
      IF (m .EQ. 0) GO TO 402
      rm = 1024.0d0
      IF (del .LE. 1024.0d0*delp) rm = del/delp
      rate = max(rate,rm)
      crate = max(0.2d0*crate,rm)
 402  dcon = del*min(1.0d0,1.5d0*crate)/(tesco(2,nq)*conit)
      IF (dcon .GT. 1.0d0) GO TO 405
      pdest = max(pdest,rate/abs(h*el(1)))
      IF (pdest .NE. 0.0d0) pdlast = pdest
      GO TO 450
 405  CONTINUE
      m = m + 1
      IF (m .EQ. maxcor) GO TO 410
      IF (m .GE. 2 .AND. del .GT. 2.0d0*delp) GO TO 410
      delp = del
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      GO TO 270
C-----------------------------------------------------------------------
C The corrector iteration failed to converge.
C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for
C the next try.  Otherwise the YH array is retracted to its values
C before prediction, and H is reduced, if possible.  If H cannot be
C reduced or MXNCF failures have occurred, exit with KFLAG = -2.
C-----------------------------------------------------------------------
 410  IF (miter .EQ. 0 .OR. jcur .EQ. 1) GO TO 430
      icf = 1
      ipup = miter
      GO TO 220
 430  icf = 2
      ncf = ncf + 1
      rmax = 2.0d0
      tn = told
      i1 = nqnyh + 1
      DO 445 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 440 i = i1,nqnyh
 440      yh1(i) = yh1(i) - yh1(i+nyh)
 445    CONTINUE
      IF (ierpj .LT. 0 .OR. iersl .LT. 0) GO TO 680
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 670
      IF (ncf .EQ. mxncf) GO TO 670
      rh = 0.25d0
      ipup = miter
      iredo = 1
      GO TO 170
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0
C to signal that the Jacobian involved may need updating later.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 450  jcur = 0
      IF (m .EQ. 0) dsm = del/tesco(2,nq)
      IF (m .GT. 0) dsm = dmnorm(n, acor, ewt)/tesco(2,nq)
      IF (dsm .GT. 1.0d0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C Decrease ICOUNT by 1, and if it is -1, consider switching methods.
C If a method switch is made, reset various parameters,
C rescale the YH array, and exit.  If there is no switch,
C consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      kflag = 0
      iredo = 0
      nst = nst + 1
      hu = h
      nqu = nq
      mused = meth
      DO 460 j = 1,l
        DO 460 i = 1,n
 460      yh(i,j) = yh(i,j) + el(j)*acor(i)
      icount = icount - 1
      IF (icount .GE. 0) GO TO 488
      IF (meth .EQ. 2) GO TO 480
C-----------------------------------------------------------------------
C We are currently using an Adams method.  Consider switching to BDF.
C If the current order is greater than 5, assume the problem is
C not stiff, and skip this section.
C If the Lipschitz constant and error estimate are not polluted
C by roundoff, go to 470 and perform the usual test.
C Otherwise, switch to the BDF methods if the last step was
C restricted to insure stability (irflag = 1), and stay with Adams
C method if not.  When switching to BDF with polluted error estimates,
C in the absence of other information, double the step size.
C
C When the estimates are OK, we make the usual test by computing
C the step size we could have (ideally) used on this step,
C with the current (Adams) method, and also that for the BDF.
C If NQ .gt. MXORDS, we consider changing to order MXORDS on switching.
C Compare the two step sizes to decide whether to switch.
C The step size advantage must be at least RATIO = 5 to switch.
C-----------------------------------------------------------------------
      IF (nq .GT. 5) GO TO 488
      IF (dsm .GT. 100.0d0*pnorm*uround .AND. pdest .NE. 0.0d0)
     1   GO TO 470
      IF (irflag .EQ. 0) GO TO 488
      rh2 = 2.0d0
      nqm2 = min(nq,mxords)
      GO TO 478
 470  CONTINUE
      exsm = 1.0d0/l
      rh1 = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rh1it = 2.0d0*rh1
      pdh = pdlast*abs(h)
      IF (pdh*rh1 .GT. 0.00001d0) rh1it = sm1(nq)/pdh
      rh1 = min(rh1,rh1it)
      IF (nq .LE. mxords) GO TO 474
         nqm2 = mxords
         lm2 = mxords + 1
         exm2 = 1.0d0/lm2
         lm2p1 = lm2 + 1
         dm2 = dmnorm(n, yh(1,lm2p1), ewt)/cm2(mxords)
         rh2 = 1.0d0/(1.2d0*dm2**exm2 + 0.0000012d0)
         GO TO 476
 474  dm2 = dsm*(cm1(nq)/cm2(nq))
      rh2 = 1.0d0/(1.2d0*dm2**exsm + 0.0000012d0)
      nqm2 = nq
 476  CONTINUE
      IF (rh2 .LT. ratio*rh1) GO TO 488
C THE SWITCH TEST PASSED.  RESET RELEVANT QUANTITIES FOR BDF. ----------
 478  rh = rh2
      icount = 20
      meth = 2
      miter = jtyp
      pdlast = 0.0d0
      nq = nqm2
      l = nq + 1
      GO TO 170
C-----------------------------------------------------------------------
C We are currently using a BDF method.  Consider switching to Adams.
C Compute the step size we could have (ideally) used on this step,
C with the current (BDF) method, and also that for the Adams.
C If NQ .gt. MXORDN, we consider changing to order MXORDN on switching.
C Compare the two step sizes to decide whether to switch.
C The step size advantage must be at least 5/RATIO = 1 to switch.
C If the step size for Adams would be so small as to cause
C roundoff pollution, we stay with BDF.
C-----------------------------------------------------------------------
 480  CONTINUE
      exsm = 1.0d0/l
      IF (mxordn .GE. nq) GO TO 484
         nqm1 = mxordn
         lm1 = mxordn + 1
         exm1 = 1.0d0/lm1
         lm1p1 = lm1 + 1
         dm1 = dmnorm(n, yh(1,lm1p1), ewt)/cm1(mxordn)
         rh1 = 1.0d0/(1.2d0*dm1**exm1 + 0.0000012d0)
         GO TO 486
 484  dm1 = dsm*(cm2(nq)/cm1(nq))
      rh1 = 1.0d0/(1.2d0*dm1**exsm + 0.0000012d0)
      nqm1 = nq
      exm1 = exsm
 486  rh1it = 2.0d0*rh1
      pdh = pdnorm*abs(h)
      IF (pdh*rh1 .GT. 0.00001d0) rh1it = sm1(nqm1)/pdh
      rh1 = min(rh1,rh1it)
      rh2 = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      IF (rh1*ratio .LT. 5.0d0*rh2) GO TO 488
      alpha = max(0.001d0,rh1)
      dm1 = (alpha**exm1)*dm1
      IF (dm1 .LE. 1000.0d0*uround*pnorm) GO TO 488
C The switch test passed.  Reset relevant quantities for Adams. --------
      rh = rh1
      icount = 20
      meth = 1
      miter = 0
      pdlast = 0.0d0
      nq = nqm1
      l = nq + 1
      GO TO 170
C
C No method switch is being made.  Do the usual step/order selection. --
 488  CONTINUE
      ialth = ialth - 1
      IF (ialth .EQ. 0) GO TO 520
      IF (ialth .GT. 1) GO TO 700
      IF (l .EQ. lmax) GO TO 700
      DO 490 i = 1,n
 490    yh(i,lmax) = acor(i)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.2 or less.
C-----------------------------------------------------------------------
 500  kflag = kflag - 1
      tn = told
      i1 = nqnyh + 1
      DO 515 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 510 i = i1,nqnyh
 510      yh1(i) = yh1(i) - yh1(i+nyh)
 515    CONTINUE
      rmax = 2.0d0
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 660
      IF (kflag .LE. -3) GO TO 640
      iredo = 2
      rhup = 0.0d0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C In the case of failure, RHUP = 0.0 to avoid an order increase.
C The largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  rhup = 0.0d0
      IF (l .EQ. lmax) GO TO 540
      DO 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
      dup = dmnorm(n, savf, ewt)/tesco(3,nq)
      exup = 1.0d0/(l+1)
      rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0)
 540  exsm = 1.0d0/l
      rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rhdn = 0.0d0
      IF (nq .EQ. 1) GO TO 550
      ddn = dmnorm(n, yh(1,l), ewt)/tesco(1,nq)
      exdn = 1.0d0/nq
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
C If METH = 1, limit RH according to the stability region also. --------
 550  IF (meth .EQ. 2) GO TO 560
      pdh = max(abs(h)*pdlast,0.000001d0)
      IF (l .LT. lmax) rhup = min(rhup,sm1(l)/pdh)
      rhsm = min(rhsm,sm1(nq)/pdh)
      IF (nq .GT. 1) rhdn = min(rhdn,sm1(nq-1)/pdh)
      pdest = 0.0d0
 560  IF (rhsm .GE. rhup) GO TO 570
      IF (rhup .GT. rhdn) GO TO 590
      GO TO 580
 570  IF (rhsm .LT. rhdn) GO TO 580
      newq = nq
      rh = rhsm
      GO TO 620
 580  newq = nq - 1
      rh = rhdn
      IF (kflag .LT. 0 .AND. rh .GT. 1.0d0) rh = 1.0d0
      GO TO 620
 590  newq = l
      rh = rhup
      IF (rh .LT. 1.1d0) GO TO 610
      r = el(l)/l
      DO 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
      GO TO 630
 610  ialth = 3
      GO TO 700
C If METH = 1 and H is restricted by stability, bypass 10 percent test.
 620  IF (meth .EQ. 2) GO TO 622
      IF (rh*pdh*1.00001d0 .GE. sm1(newq)) GO TO 625
 622  IF (kflag .EQ. 0 .AND. rh .LT. 1.1d0) GO TO 610
 625  IF (kflag .LE. -2) rh = min(rh,0.2d0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, L, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (newq .EQ. nq) GO TO 170
 630  nq = newq
      l = nq + 1
      iret = 2
      GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more failures have occured.
C If 10 failures have occurred, exit with KFLAG = -1.
C It is assumed that the derivatives that have accumulated in the
C YH array have errors of the wrong order.  Hence the first
C derivative is recomputed, and the order is set to 1.  Then
C H is reduced by a factor of 10, and the step is retried,
C until it succeeds or H reaches HMIN.
C-----------------------------------------------------------------------
 640  IF (kflag .EQ. -10) GO TO 660
      rh = 0.1d0
      rh = max(hmin/abs(h),rh)
      h = h*rh
      DO 645 i = 1,n
 645    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      DO 650 i = 1,n
 650    yh(i,2) = h*savf(i)
      ipup = miter
      ialth = 5
      IF (nq .EQ. 1) GO TO 200
      nq = 1
      l = 2
      iret = 3
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  kflag = -1
      GO TO 720
 670  kflag = -2
      GO TO 720
 680  kflag = -3
      GO TO 720
 690  rmax = 10.0d0
 700  r = 1.0d0/tesco(2,nqu)
      DO 710 i = 1,n
 710    acor(i) = acor(i)*r
 720  hold = h
      jstart = 1
      RETURN
C----------------------- End of Subroutine DSTODA ----------------------
      END
*DECK DPRJA
      SUBROUTINE dprja (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM,
     1   F, JAC)
      EXTERNAL f, jac
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, ewt, ftem, savf, wm
      dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*),
     1   wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER iownd2, iowns2, jtyp, mused, mxordn, mxords
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rownd2, rowns2, pdnorm
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlsa01/ rownd2, rowns2(20), pdnorm,
     1   iownd2(3), iowns2(2), jtyp, mused, mxordn, mxords
      INTEGER i, i1, i2, ier, ii, j, j1, jj, lenp,
     1   mba, mband, meb1, meband, ml, ml3, mu, np1
      DOUBLE PRECISION con, fac, hl0, r, r0, srur, yi, yj, yjj,
     1   dmnorm, dfnorm, dbnorm
C-----------------------------------------------------------------------
C DPRJA is called by DSTODA to compute and process the matrix
C P = I - H*EL(1)*J , where J is an approximation to the Jacobian.
C Here J is computed by the user-supplied routine JAC if
C MITER = 1 or 4 or by finite differencing if MITER = 2 or 5.
C J, scaled by -H*EL(1), is stored in WM.  Then the norm of J (the
C matrix norm consistent with the weighted max-norm on vectors given
C by DMNORM) is computed, and J is overwritten by P.  P is then
C subjected to LU decomposition in preparation for later solution
C of linear systems with P as coefficient matrix.  This is done
C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5.
C
C In addition to variables described previously, communication
C with DPRJA uses the following:
C Y     = array containing predicted values on entry.
C FTEM  = work array of length N (ACOR in DSTODA).
C SAVF  = array containing f evaluated at predicted y.
C WM    = real work space for matrices.  On output it contains the
C         LU decomposition of P.
C         Storage of matrix elements starts at WM(3).
C         WM also contains the following matrix-related data:
C         WM(1) = SQRT(UROUND), used in numerical Jacobian increments.
C IWM   = integer work space containing pivot information, starting at
C         IWM(21).   IWM also contains the band parameters
C         ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
C EL0   = EL(1) (input).
C PDNORM= norm of Jacobian matrix. (Output).
C IERPJ = output error flag,  = 0 if no trouble, .gt. 0 if
C         P matrix found to be singular.
C JCUR  = output flag = 1 to indicate that the Jacobian matrix
C         (or approximation) is now current.
C This routine also uses the Common variables EL0, H, TN, UROUND,
C MITER, N, NFE, and NJE.
C-----------------------------------------------------------------------
      nje = nje + 1
      ierpj = 0
      jcur = 1
      hl0 = h*el0
      GO TO (100, 200, 300, 400, 500), miter
C If MITER = 1, call JAC and multiply by scalar. -----------------------
 100  lenp = n*n
      DO 110 i = 1,lenp
 110    wm(i+2) = 0.0d0
      CALL jac (neq, tn, y, 0, 0, wm(3), n)
      con = -hl0
      DO 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
      GO TO 240
C If MITER = 2, make N calls to F to approximate J. --------------------
 200  fac = dmnorm(n, savf, ewt)
      r0 = 1000.0d0*abs(h)*uround*n*fac
      IF (r0 .EQ. 0.0d0) r0 = 1.0d0
      srur = wm(1)
      j1 = 2
      DO 230 j = 1,n
        yj = y(j)
        r = max(srur*abs(yj),r0/ewt(j))
        y(j) = y(j) + r
        fac = -hl0/r
        CALL f (neq, tn, y, ftem)
        DO 220 i = 1,n
 220      wm(i+j1) = (ftem(i) - savf(i))*fac
        y(j) = yj
        j1 = j1 + n
 230    CONTINUE
      nfe = nfe + n
 240  CONTINUE
C Compute norm of Jacobian. --------------------------------------------
      pdnorm = dfnorm(n, wm(3), ewt)/abs(hl0)
C Add identity matrix. -------------------------------------------------
      j = 3
      np1 = n + 1
      DO 250 i = 1,n
        wm(j) = wm(j) + 1.0d0
 250    j = j + np1
C Do LU decomposition on P. --------------------------------------------
      CALL dgefa (wm(3), n, n, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C Dummy block only, since MITER is never 3 in this routine. ------------
 300  RETURN
C If MITER = 4, call JAC and multiply by scalar. -----------------------
 400  ml = iwm(1)
      mu = iwm(2)
      ml3 = ml + 3
      mband = ml + mu + 1
      meband = mband + ml
      lenp = meband*n
      DO 410 i = 1,lenp
 410    wm(i+2) = 0.0d0
      CALL jac (neq, tn, y, ml, mu, wm(ml3), meband)
      con = -hl0
      DO 420 i = 1,lenp
 420    wm(i+2) = wm(i+2)*con
      GO TO 570
C If MITER = 5, make MBAND calls to F to approximate J. ----------------
 500  ml = iwm(1)
      mu = iwm(2)
      mband = ml + mu + 1
      mba = min(mband,n)
      meband = mband + ml
      meb1 = meband - 1
      srur = wm(1)
      fac = dmnorm(n, savf, ewt)
      r0 = 1000.0d0*abs(h)*uround*n*fac
      IF (r0 .EQ. 0.0d0) r0 = 1.0d0
      DO 560 j = 1,mba
        DO 530 i = j,n,mband
          yi = y(i)
          r = max(srur*abs(yi),r0/ewt(i))
 530      y(i) = y(i) + r
        CALL f (neq, tn, y, ftem)
        DO 550 jj = j,n,mband
          y(jj) = yh(jj,1)
          yjj = y(jj)
          r = max(srur*abs(yjj),r0/ewt(jj))
          fac = -hl0/r
          i1 = max(jj-mu,1)
          i2 = min(jj+ml,n)
          ii = jj*meb1 - ml + 2
          DO 540 i = i1,i2
 540        wm(ii+i) = (ftem(i) - savf(i))*fac
 550      CONTINUE
 560    CONTINUE
      nfe = nfe + mba
 570  CONTINUE
C Compute norm of Jacobian. --------------------------------------------
      pdnorm = dbnorm(n, wm(ml+3), meband, ml, mu, ewt)/abs(hl0)
C Add identity matrix. -------------------------------------------------
      ii = mband + 2
      DO 580 i = 1,n
        wm(ii) = wm(ii) + 1.0d0
 580    ii = ii + meband
C Do LU decomposition of P. --------------------------------------------
      CALL dgbfa (wm(3), meband, n, ml, mu, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C----------------------- End of Subroutine DPRJA -----------------------
      END
*DECK DMNORM
      DOUBLE PRECISION FUNCTION dmnorm (N, V, W)
C-----------------------------------------------------------------------
C This function routine computes the weighted max-norm
C of the vector of length N contained in the array V, with weights
C contained in the array w of length N:
C   DMNORM = MAX(i=1,...,N) ABS(V(i))*W(i)
C-----------------------------------------------------------------------
      INTEGER n,   i
      DOUBLE PRECISION v, w,   vm
      dimension v(n), w(n)
      vm = 0.0d0
      DO 10 i = 1,n
 10     vm = max(vm,abs(v(i))*w(i))
      dmnorm = vm
      RETURN
C----------------------- End of Function DMNORM ------------------------
      END
*DECK DFNORM
      DOUBLE PRECISION FUNCTION dfnorm (N, A, W)
C-----------------------------------------------------------------------
C This function computes the norm of a full N by N matrix,
C stored in the array A, that is consistent with the weighted max-norm
C on vectors, with weights stored in the array W:
C   DFNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) )
C-----------------------------------------------------------------------
      INTEGER n,   i, j
      DOUBLE PRECISION a,   w, an, sum
      dimension a(n,n), w(n)
      an = 0.0d0
      DO 20 i = 1,n
        sum = 0.0d0
        DO 10 j = 1,n
 10       sum = sum + abs(a(i,j))/w(j)
        an = max(an,sum*w(i))
 20     CONTINUE
      dfnorm = an
      RETURN
C----------------------- End of Function DFNORM ------------------------
      END
*DECK DBNORM
      DOUBLE PRECISION FUNCTION dbnorm (N, A, NRA, ML, MU, W)
C-----------------------------------------------------------------------
C This function computes the norm of a banded N by N matrix,
C stored in the array A, that is consistent with the weighted max-norm
C on vectors, with weights stored in the array W.
C ML and MU are the lower and upper half-bandwidths of the matrix.
C NRA is the first dimension of the A array, NRA .ge. ML+MU+1.
C In terms of the matrix elements a(i,j), the norm is given by:
C   DBNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) )
C-----------------------------------------------------------------------
      INTEGER n, nra, ml, mu
      INTEGER i, i1, jlo, jhi, j
      DOUBLE PRECISION a, w
      DOUBLE PRECISION an, sum
      dimension a(nra,n), w(n)
      an = 0.0d0
      DO 20 i = 1,n
        sum = 0.0d0
        i1 = i + mu + 1
        jlo = max(i-ml,1)
        jhi = min(i+mu,n)
        DO 10 j = jlo,jhi
 10       sum = sum + abs(a(i1-j,j))/w(j)
        an = max(an,sum*w(i))
 20     CONTINUE
      dbnorm = an
      RETURN
C----------------------- End of Function DBNORM ------------------------
      END
*DECK DSRCMA
      SUBROUTINE dsrcma (RSAV, ISAV, JOB)
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of
C the Common blocks DLS001, DLSA01, which are used
C internally by one or more ODEPACK solvers.
C
C RSAV = real array of length 240 or more.
C ISAV = integer array of length 46 or more.
C JOB  = flag indicating to save or restore the Common blocks:
C        JOB  = 1 if Common is to be saved (written to RSAV/ISAV)
C        JOB  = 2 if Common is to be restored (read from RSAV/ISAV)
C        A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
      INTEGER isav, job
      INTEGER ils, ilsa
      INTEGER i, lenrls, lenils, lenrla, lenila
      DOUBLE PRECISION rsav
      DOUBLE PRECISION rls, rlsa
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils, lenrla, lenila
      COMMON /dls001/ rls(218), ils(37)
      COMMON /dlsa01/ rlsa(22), ilsa(9)
      DATA lenrls/218/, lenils/37/, lenrla/22/, lenila/9/
C
      IF (job .EQ. 2) GO TO 100
      DO 10 i = 1,lenrls
 10     rsav(i) = rls(i)
      DO 15 i = 1,lenrla
 15     rsav(lenrls+i) = rlsa(i)
C
      DO 20 i = 1,lenils
 20     isav(i) = ils(i)
      DO 25 i = 1,lenila
 25     isav(lenils+i) = ilsa(i)
C
      RETURN
C
 100  CONTINUE
      DO 110 i = 1,lenrls
 110     rls(i) = rsav(i)
      DO 115 i = 1,lenrla
 115     rlsa(i) = rsav(lenrls+i)
C
      DO 120 i = 1,lenils
 120     ils(i) = isav(i)
      DO 125 i = 1,lenila
 125     ilsa(i) = isav(lenils+i)
C
      RETURN
C----------------------- End of Subroutine DSRCMA ----------------------
      END
*DECK DRCHEK
      SUBROUTINE drchek (JOB, G, NEQ, Y, YH,NYH, G0, G1, GX, JROOT, IRT)
      EXTERNAL g
      INTEGER job, neq, nyh, jroot, irt
      DOUBLE PRECISION y, yh, g0, g1, gx
      dimension neq(*), y(*), yh(nyh,*), g0(*), g1(*), gx(*), jroot(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER iownd3, iownr3, irfnd, itaskc, ngc, nge
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rownr3, t0, tlast, toutc
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlsr01/ rownr3(2), t0, tlast, toutc,
     1   iownd3(3), iownr3(2), irfnd, itaskc, ngc, nge
      INTEGER i, iflag, jflag
      DOUBLE PRECISION hming, t1, temp1, temp2, x
      LOGICAL zroot
C-----------------------------------------------------------------------
C This routine checks for the presence of a root in the vicinity of
C the current T, in a manner depending on the input flag JOB.  It calls
C Subroutine DROOTS to locate the root as precisely as possible.
C
C In addition to variables described previously, DRCHEK
C uses the following for communication:
C JOB    = integer flag indicating type of call:
C          JOB = 1 means the problem is being initialized, and DRCHEK
C                  is to look for a root at or very near the initial T.
C          JOB = 2 means a continuation call to the solver was just
C                  made, and DRCHEK is to check for a root in the
C                  relevant part of the step last taken.
C          JOB = 3 means a successful step was just taken, and DRCHEK
C                  is to look for a root in the interval of the step.
C G0     = array of length NG, containing the value of g at T = T0.
C          G0 is input for JOB .ge. 2, and output in all cases.
C G1,GX  = arrays of length NG for work space.
C IRT    = completion flag:
C          IRT = 0  means no root was found.
C          IRT = -1 means JOB = 1 and a root was found too near to T.
C          IRT = 1  means a legitimate root was found (JOB = 2 or 3).
C                   On return, T0 is the root location, and Y is the
C                   corresponding solution vector.
C T0     = value of T at one endpoint of interval of interest.  Only
C          roots beyond T0 in the direction of integration are sought.
C          T0 is input if JOB .ge. 2, and output in all cases.
C          T0 is updated by DRCHEK, whether a root is found or not.
C TLAST  = last value of T returned by the solver (input only).
C TOUTC  = copy of TOUT (input only).
C IRFND  = input flag showing whether the last step taken had a root.
C          IRFND = 1 if it did, = 0 if not.
C ITASKC = copy of ITASK (input only).
C NGC    = copy of NG (input only).
C-----------------------------------------------------------------------
      irt = 0
      DO 10 i = 1,ngc
 10     jroot(i) = 0
      hming = (abs(tn) + abs(h))*uround*100.0d0
C
      GO TO (100, 200, 300), job
C
C Evaluate g at initial T, and check for zero values. ------------------
 100  CONTINUE
      t0 = tn
      CALL g (neq, t0, y, ngc, g0)
      nge = 1
      zroot = .false.
      DO 110 i = 1,ngc
 110    IF (abs(g0(i)) .LE. 0.0d0) zroot = .true.
      IF (.NOT. zroot) GO TO 190
C g has a zero at T.  Look at g at T + (small increment). --------------
      temp2 = max(hming/abs(h), 0.1d0)
      temp1 = temp2*h
      t0 = t0 + temp1
      DO 120 i = 1,n
 120    y(i) = y(i) + temp2*yh(i,2)
      CALL g (neq, t0, y, ngc, g0)
      nge = nge + 1
      zroot = .false.
      DO 130 i = 1,ngc
 130    IF (abs(g0(i)) .LE. 0.0d0) zroot = .true.
      IF (.NOT. zroot) GO TO 190
C g has a zero at T and also close to T.  Take error return. -----------
      irt = -1
      RETURN
C
 190  CONTINUE
      RETURN
C
C
 200  CONTINUE
      IF (irfnd .EQ. 0) GO TO 260
C If a root was found on the previous step, evaluate G0 = g(T0). -------
      CALL dintdy (t0, 0, yh, nyh, y, iflag)
      CALL g (neq, t0, y, ngc, g0)
      nge = nge + 1
      zroot = .false.
      DO 210 i = 1,ngc
 210    IF (abs(g0(i)) .LE. 0.0d0) zroot = .true.
      IF (.NOT. zroot) GO TO 260
C g has a zero at T0.  Look at g at T + (small increment). -------------
      temp1 = sign(hming,h)
      t0 = t0 + temp1
      IF ((t0 - tn)*h .LT. 0.0d0) GO TO 230
      temp2 = temp1/h
      DO 220 i = 1,n
 220    y(i) = y(i) + temp2*yh(i,2)
      GO TO 240
 230  CALL dintdy (t0, 0, yh, nyh, y, iflag)
 240  CALL g (neq, t0, y, ngc, g0)
      nge = nge + 1
      zroot = .false.
      DO 250 i = 1,ngc
        IF (abs(g0(i)) .GT. 0.0d0) GO TO 250
        jroot(i) = 1
        zroot = .true.
 250    CONTINUE
      IF (.NOT. zroot) GO TO 260
C g has a zero at T0 and also close to T0.  Return root. ---------------
      irt = 1
      RETURN
C G0 has no zero components.  Proceed to check relevant interval. ------
 260  IF (tn .EQ. tlast) GO TO 390
C
 300  CONTINUE
C Set T1 to TN or TOUTC, whichever comes first, and get g at T1. -------
      IF (itaskc.EQ.2 .OR. itaskc.EQ.3 .OR. itaskc.EQ.5) GO TO 310
      IF ((toutc - tn)*h .GE. 0.0d0) GO TO 310
      t1 = toutc
      IF ((t1 - t0)*h .LE. 0.0d0) GO TO 390
      CALL dintdy (t1, 0, yh, nyh, y, iflag)
      GO TO 330
 310  t1 = tn
      DO 320 i = 1,n
 320    y(i) = yh(i,1)
 330  CALL g (neq, t1, y, ngc, g1)
      nge = nge + 1
C Call DROOTS to search for root in interval from T0 to T1. ------------
      jflag = 0
 350  CONTINUE
      CALL droots (ngc, hming, jflag, t0, t1, g0, g1, gx, x, jroot)
      IF (jflag .GT. 1) GO TO 360
      CALL dintdy (x, 0, yh, nyh, y, iflag)
      CALL g (neq, x, y, ngc, gx)
      nge = nge + 1
      GO TO 350
 360  t0 = x
      CALL dcopy (ngc, gx, 1, g0, 1)
      IF (jflag .EQ. 4) GO TO 390
C Found a root.  Interpolate to X and return. --------------------------
      CALL dintdy (x, 0, yh, nyh, y, iflag)
      irt = 1
      RETURN
C
 390  CONTINUE
      RETURN
C----------------------- End of Subroutine DRCHEK ----------------------
      END
*DECK DROOTS
      SUBROUTINE droots (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT)
      INTEGER ng, jflag, jroot
      DOUBLE PRECISION hmin, x0, x1, g0, g1, gx, x
      dimension g0(ng), g1(ng), gx(ng), jroot(ng)
      INTEGER iownd3, imax, last, idum3
      DOUBLE PRECISION alpha, x2, rdum3
      COMMON /dlsr01/ alpha, x2, rdum3(3),
     1   iownd3(3), imax, last, idum3(4)
C-----------------------------------------------------------------------
C This subroutine finds the leftmost root of a set of arbitrary
C functions gi(x) (i = 1,...,NG) in an interval (X0,X1).  Only roots
C of odd multiplicity (i.e. changes of sign of the gi) are found.
C Here the sign of X1 - X0 is arbitrary, but is constant for a given
C problem, and -leftmost- means nearest to X0.
C The values of the vector-valued function g(x) = (gi, i=1...NG)
C are communicated through the call sequence of DROOTS.
C The method used is the Illinois algorithm.
C
C Reference:
C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined
C Output Points for Solutions of ODEs, Sandia Report SAND80-0180,
C February 1980.
C
C Description of parameters.
C
C NG     = number of functions gi, or the number of components of
C          the vector valued function g(x).  Input only.
C
C HMIN   = resolution parameter in X.  Input only.  When a root is
C          found, it is located only to within an error of HMIN in X.
C          Typically, HMIN should be set to something on the order of
C               100 * UROUND * MAX(ABS(X0),ABS(X1)),
C          where UROUND is the unit roundoff of the machine.
C
C JFLAG  = integer flag for input and output communication.
C
C          On input, set JFLAG = 0 on the first call for the problem,
C          and leave it unchanged until the problem is completed.
C          (The problem is completed when JFLAG .ge. 2 on return.)
C
C          On output, JFLAG has the following values and meanings:
C          JFLAG = 1 means DROOTS needs a value of g(x).  Set GX = g(X)
C                    and call DROOTS again.
C          JFLAG = 2 means a root has been found.  The root is
C                    at X, and GX contains g(X).  (Actually, X is the
C                    rightmost approximation to the root on an interval
C                    (X0,X1) of size HMIN or less.)
C          JFLAG = 3 means X = X1 is a root, with one or more of the gi
C                    being zero at X1 and no sign changes in (X0,X1).
C                    GX contains g(X) on output.
C          JFLAG = 4 means no roots (of odd multiplicity) were
C                    found in (X0,X1) (no sign changes).
C
C X0,X1  = endpoints of the interval where roots are sought.
C          X1 and X0 are input when JFLAG = 0 (first call), and
C          must be left unchanged between calls until the problem is
C          completed.  X0 and X1 must be distinct, but X1 - X0 may be
C          of either sign.  However, the notion of -left- and -right-
C          will be used to mean nearer to X0 or X1, respectively.
C          When JFLAG .ge. 2 on return, X0 and X1 are output, and
C          are the endpoints of the relevant interval.
C
C G0,G1  = arrays of length NG containing the vectors g(X0) and g(X1),
C          respectively.  When JFLAG = 0, G0 and G1 are input and
C          none of the G0(i) should be zero.
C          When JFLAG .ge. 2 on return, G0 and G1 are output.
C
C GX     = array of length NG containing g(X).  GX is input
C          when JFLAG = 1, and output when JFLAG .ge. 2.
C
C X      = independent variable value.  Output only.
C          When JFLAG = 1 on output, X is the point at which g(x)
C          is to be evaluated and loaded into GX.
C          When JFLAG = 2 or 3, X is the root.
C          When JFLAG = 4, X is the right endpoint of the interval, X1.
C
C JROOT  = integer array of length NG.  Output only.
C          When JFLAG = 2 or 3, JROOT indicates which components
C          of g(x) have a root at X.  JROOT(i) is 1 if the i-th
C          component has a root, and JROOT(i) = 0 otherwise.
C-----------------------------------------------------------------------
      INTEGER i, imxold, nxlast
      DOUBLE PRECISION t2, tmax, fracint, fracsub, zero,half,tenth,five
      LOGICAL zroot, sgnchg, xroot
      SAVE zero, half, tenth, five
      DATA zero/0.0d0/, half/0.5d0/, tenth/0.1d0/, five/5.0d0/
C
      IF (jflag .EQ. 1) GO TO 200
C JFLAG .ne. 1.  Check for change in sign of g or zero at X1. ----------
      imax = 0
      tmax = zero
      zroot = .false.
      DO 120 i = 1,ng
        IF (abs(g1(i)) .GT. zero) GO TO 110
        zroot = .true.
        GO TO 120
C At this point, G0(i) has been checked and cannot be zero. ------------
 110    IF (sign(1.0d0,g0(i)) .EQ. sign(1.0d0,g1(i))) GO TO 120
          t2 = abs(g1(i)/(g1(i)-g0(i)))
          IF (t2 .LE. tmax) GO TO 120
            tmax = t2
            imax = i
 120    CONTINUE
      IF (imax .GT. 0) GO TO 130
      sgnchg = .false.
      GO TO 140
 130  sgnchg = .true.
 140  IF (.NOT. sgnchg) GO TO 400
C There is a sign change.  Find the first root in the interval. --------
      xroot = .false.
      nxlast = 0
      last = 1
C
C Repeat until the first root in the interval is found.  Loop point. ---
 150  CONTINUE
      IF (xroot) GO TO 300
      IF (nxlast .EQ. last) GO TO 160
      alpha = 1.0d0
      GO TO 180
 160  IF (last .EQ. 0) GO TO 170
      alpha = 0.5d0*alpha
      GO TO 180
 170  alpha = 2.0d0*alpha
 180  x2 = x1 - (x1 - x0)*g1(imax) / (g1(imax) - alpha*g0(imax))
C If X2 is too close to X0 or X1, adjust it inward, by a fractional ----
C distance that is between 0.1 and 0.5. --------------------------------
      IF (abs(x2 - x0) < half*hmin) THEN
        fracint = abs(x1 - x0)/hmin
        fracsub = tenth
        IF (fracint .LE. five) fracsub = half/fracint
        x2 = x0 + fracsub*(x1 - x0)
      ENDIF
      IF (abs(x1 - x2) < half*hmin) THEN
        fracint = abs(x1 - x0)/hmin
        fracsub = tenth
        IF (fracint .LE. five) fracsub = half/fracint
        x2 = x1 - fracsub*(x1 - x0)
      ENDIF
      jflag = 1
      x = x2
C Return to the calling routine to get a value of GX = g(X). -----------
      RETURN
C Check to see in which interval g changes sign. -----------------------
 200  imxold = imax
      imax = 0
      tmax = zero
      zroot = .false.
      DO 220 i = 1,ng
        IF (abs(gx(i)) .GT. zero) GO TO 210
        zroot = .true.
        GO TO 220
C Neither G0(i) nor GX(i) can be zero at this point. -------------------
 210    IF (sign(1.0d0,g0(i)) .EQ. sign(1.0d0,gx(i))) GO TO 220
          t2 = abs(gx(i)/(gx(i) - g0(i)))
          IF (t2 .LE. tmax) GO TO 220
            tmax = t2
            imax = i
 220    CONTINUE
      IF (imax .GT. 0) GO TO 230
      sgnchg = .false.
      imax = imxold
      GO TO 240
 230  sgnchg = .true.
 240  nxlast = last
      IF (.NOT. sgnchg) GO TO 250
C Sign change between X0 and X2, so replace X1 with X2. ----------------
      x1 = x2
      CALL dcopy (ng, gx, 1, g1, 1)
      last = 1
      xroot = .false.
      GO TO 270
 250  IF (.NOT. zroot) GO TO 260
C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. -----
      x1 = x2
      CALL dcopy (ng, gx, 1, g1, 1)
      xroot = .true.
      GO TO 270
C No sign change between X0 and X2.  Replace X0 with X2. ---------------
 260  CONTINUE
      CALL dcopy (ng, gx, 1, g0, 1)
      x0 = x2
      last = 0
      xroot = .false.
 270  IF (abs(x1-x0) .LE. hmin) xroot = .true.
      GO TO 150
C
C Return with X1 as the root.  Set JROOT.  Set X = X1 and GX = G1. -----
 300  jflag = 2
      x = x1
      CALL dcopy (ng, g1, 1, gx, 1)
      DO 320 i = 1,ng
        jroot(i) = 0
        IF (abs(g1(i)) .GT. zero) GO TO 310
          jroot(i) = 1
          GO TO 320
 310    IF (sign(1.0d0,g0(i)) .NE. sign(1.0d0,g1(i))) jroot(i) = 1
 320    CONTINUE
      RETURN
C
C No sign change in the interval.  Check for zero at right endpoint. ---
 400  IF (.NOT. zroot) GO TO 420
C
C Zero value at X1 and no sign change in (X0,X1).  Return JFLAG = 3. ---
      x = x1
      CALL dcopy (ng, g1, 1, gx, 1)
      DO 410 i = 1,ng
        jroot(i) = 0
        IF (abs(g1(i)) .LE. zero) jroot(i) = 1
 410  CONTINUE
      jflag = 3
      RETURN
C
C No sign changes in this interval.  Set X = X1, return JFLAG = 4. -----
 420  CALL dcopy (ng, g1, 1, gx, 1)
      x = x1
      jflag = 4
      RETURN
C----------------------- End of Subroutine DROOTS ----------------------
      END
*DECK DSRCAR
      SUBROUTINE dsrcar (RSAV, ISAV, JOB)
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of
C the Common blocks DLS001, DLSA01, DLSR01, which are used
C internally by one or more ODEPACK solvers.
C
C RSAV = real array of length 245 or more.
C ISAV = integer array of length 55 or more.
C JOB  = flag indicating to save or restore the Common blocks:
C        JOB  = 1 if Common is to be saved (written to RSAV/ISAV)
C        JOB  = 2 if Common is to be restored (read from RSAV/ISAV)
C        A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
      INTEGER isav, job
      INTEGER ils, ilsa, ilsr
      INTEGER i, ioff, lenrls, lenils, lenrla, lenila, lenrlr, lenilr
      DOUBLE PRECISION rsav
      DOUBLE PRECISION rls, rlsa, rlsr
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils, lenrla, lenila, lenrlr, lenilr
      COMMON /dls001/ rls(218), ils(37)
      COMMON /dlsa01/ rlsa(22), ilsa(9)
      COMMON /dlsr01/ rlsr(5), ilsr(9)
      DATA lenrls/218/, lenils/37/, lenrla/22/, lenila/9/
      DATA lenrlr/5/, lenilr/9/
C
      IF (job .EQ. 2) GO TO 100
      DO 10 i = 1,lenrls
 10     rsav(i) = rls(i)
       DO 15 i = 1,lenrla
 15     rsav(lenrls+i) = rlsa(i)
      ioff = lenrls + lenrla
      DO 20 i = 1,lenrlr
 20     rsav(ioff+i) = rlsr(i)
C
      DO 30 i = 1,lenils
 30     isav(i) = ils(i)
      DO 35 i = 1,lenila
 35     isav(lenils+i) = ilsa(i)
      ioff = lenils + lenila
      DO 40 i = 1,lenilr
 40     isav(ioff+i) = ilsr(i)
C
      RETURN
C
 100  CONTINUE
      DO 110 i = 1,lenrls
 110     rls(i) = rsav(i)
      DO 115 i = 1,lenrla
 115     rlsa(i) = rsav(lenrls+i)
      ioff = lenrls + lenrla
      DO 120 i = 1,lenrlr
 120     rlsr(i) = rsav(ioff+i)
C
      DO 130 i = 1,lenils
 130     ils(i) = isav(i)
      DO 135 i = 1,lenila
 135     ilsa(i) = isav(lenils+i)
      ioff = lenils + lenila
      DO 140 i = 1,lenilr
 140     ilsr(i) = isav(ioff+i)
C
      RETURN
C----------------------- End of Subroutine DSRCAR ----------------------
      END
*DECK DSTODPK
      SUBROUTINE dstodpk (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR,
     1   WM, IWM, F, JAC, PSOL)
      EXTERNAL f, jac, psol
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, yh1, ewt, savf, savx, acor, wm
      dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*),
     1   savx(*), acor(*), wm(*), iwm(*)
      INTEGER iownd, ialth, ipup, lmax, meo, nqnyh, nslp,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     1   nni, nli, nps, ncfn, ncfl
      DOUBLE PRECISION conit, crate, el, elco, hold, rmax, tesco,
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
      COMMON /dls001/ conit, crate, el(13), elco(13,12),
     1   hold, rmax, tesco(3,12),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(6), ialth, ipup, lmax, meo, nqnyh, nslp,
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
     1   jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     2   nni, nli, nps, ncfn, ncfl
C-----------------------------------------------------------------------
C DSTODPK performs one step of the integration of an initial value
C problem for a system of Ordinary Differential Equations.
C-----------------------------------------------------------------------
C The following changes were made to generate Subroutine DSTODPK
C from Subroutine DSTODE:
C 1. The array SAVX was added to the call sequence.
C 2. PJAC and SLVS were replaced by PSOL in the call sequence.
C 3. The Common block /DLPK01/ was added for communication.
C 4. The test constant EPCON is loaded into Common below statement
C    numbers 125 and 155, and used below statement 400.
C 5. The Newton iteration counter MNEWT is set below 220 and 400.
C 6. The call to PJAC was replaced with a call to DPKSET (fixed name),
C    with a longer call sequence, called depending on JACFLG.
C 7. The corrector residual is stored in SAVX (not Y) at 360,
C    and the solution vector is in SAVX in the 380 loop.
C 8. SLVS was renamed DSOLPK and includes NEQ, SAVX, EWT, F, and JAC.
C    SAVX was added because DSOLPK now needs Y and SAVF undisturbed.
C 9. The nonlinear convergence failure count NCFN is set at 430.
C-----------------------------------------------------------------------
C Note: DSTODPK is independent of the value of the iteration method
C indicator MITER, when this is .ne. 0, and hence is independent
C of the type of chord method used, or the Jacobian structure.
C Communication with DSTODPK is done with the following variables:
C
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls to F and JAC.
C Y      = an array of length .ge. N used as the Y argument in
C          all calls to F and JAC.
C YH     = an NYH by LMAX array containing the dependent variables
C          and their approximate scaled derivatives, where
C          LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C          j-th derivative of y(i), scaled by H**j/factorial(j)
C          (j = 0,1,...,NQ).  On entry for the first step, the first
C          two columns of YH must be set from the initial values.
C NYH    = a constant integer .ge. N, the first dimension of YH.
C YH1    = a one-dimensional array occupying the same space as YH.
C EWT    = an array of length N containing multiplicative weights
C          for local error measurements.  Local errors in y(i) are
C          compared to 1.0/EWT(i) in various error tests.
C SAVF   = an array of working storage, of length N.
C          Also used for input of YH(*,MAXORD+2) when JSTART = -1
C          and MAXORD .lt. the current order NQ.
C SAVX   = an array of working storage, of length N.
C ACOR   = a work array of length N, used for the accumulated
C          corrections.  On a successful return, ACOR(i) contains
C          the estimated one-step local error in y(i).
C WM,IWM = real and integer work arrays associated with matrix
C          operations in chord iteration (MITER .ne. 0).
C CCMAX  = maximum relative change in H*EL0 before DPKSET is called.
C H      = the step size to be attempted on the next step.
C          H is altered by the error control algorithm during the
C          problem.  H can be either positive or negative, but its
C          sign must remain constant throughout the problem.
C HMIN   = the minimum absolute value of the step size H to be used.
C HMXI   = inverse of the maximum absolute value of H to be used.
C          HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C          HMIN and HMXI may be changed at any time, but will not
C          take effect until the next change of H is considered.
C TN     = the independent variable. TN is updated on each step taken.
C JSTART = an integer used for input only, with the following
C          values and meanings:
C               0  perform the first step.
C           .gt.0  take a new step continuing from the last.
C              -1  take the next step with a new value of H, MAXORD,
C                    N, METH, MITER, and/or matrix parameters.
C              -2  take the next step with a new value of H,
C                    but with other inputs unchanged.
C          On return, JSTART is set to 1 to facilitate continuation.
C KFLAG  = a completion code with the following meanings:
C               0  the step was succesful.
C              -1  the requested error could not be achieved.
C              -2  corrector convergence could not be achieved.
C              -3  fatal error in DPKSET or DSOLPK.
C          A return with KFLAG = -1 or -2 means either
C          ABS(H) = HMIN or 10 consecutive failures occurred.
C          On a return with KFLAG negative, the values of TN and
C          the YH array are as of the beginning of the last
C          step, and H is the last step size attempted.
C MAXORD = the maximum order of integration method to be allowed.
C MAXCOR = the maximum number of corrector iterations allowed.
C MSBP   = maximum number of steps between DPKSET calls (MITER .gt. 0).
C MXNCF  = maximum number of convergence failures allowed.
C METH/MITER = the method flags.  See description in driver.
C N      = the number of first-order differential equations.
C-----------------------------------------------------------------------
      INTEGER i, i1, iredo, iret, j, jb, m, ncf, newq
      DOUBLE PRECISION dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup,
     1   r, rh, rhdn, rhsm, rhup, told, dvnorm
C
      kflag = 0
      told = tn
      ncf = 0
      ierpj = 0
      iersl = 0
      jcur = 0
      icf = 0
      delp = 0.0d0
      IF (jstart .GT. 0) GO TO 200
      IF (jstart .EQ. -1) GO TO 100
      IF (jstart .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set at 2
C for the next increase.
C-----------------------------------------------------------------------
      lmax = maxord + 1
      nq = 1
      l = 2
      ialth = 2
      rmax = 10000.0d0
      rc = 0.0d0
      el0 = 1.0d0
      crate = 0.7d0
      hold = h
      meo = meth
      nslp = 0
      ipup = miter
      iret = 3
      GO TO 140
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If the caller has changed MAXORD to a value less than the current
C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  ipup = miter
      lmax = maxord + 1
      IF (ialth .EQ. 1) ialth = 2
      IF (meth .EQ. meo) GO TO 110
      CALL dcfode (meth, elco, tesco)
      meo = meth
      IF (nq .GT. maxord) GO TO 120
      ialth = l
      iret = 1
      GO TO 150
 110  IF (nq .LE. maxord) GO TO 160
 120  nq = maxord
      l = lmax
      DO 125 i = 1,l
 125    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      epcon = conit*tesco(2,nq)
      ddn = dvnorm(n, savf, ewt)/tesco(1,l)
      exdn = 1.0d0/l
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
      rh = min(rhdn,1.0d0)
      iredo = 3
      IF (h .EQ. hold) GO TO 170
      rh = min(rh,abs(h/hold))
      h = hold
      GO TO 175
C-----------------------------------------------------------------------
C DCFODE is called to get all the integration coefficients for the
C current METH.  Then the EL vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 140  CALL dcfode (meth, elco, tesco)
 150  DO 155 i = 1,l
 155    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      epcon = conit*tesco(2,nq)
      GO TO (160, 170, 200), iret
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (h .EQ. hold) GO TO 200
      rh = h/hold
      h = hold
      iredo = 3
      GO TO 175
 170  rh = max(rh,hmin/abs(h))
 175  rh = min(rh,rmax)
      rh = rh/max(1.0d0,abs(h)*hmxi*rh)
      r = 1.0d0
      DO 180 j = 2,l
        r = r*rh
        DO 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
      h = h*rh
      rc = rc*rh
      ialth = l
      IF (iredo .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C The flag IPUP is set according to whether matrix data is involved
C (JACFLG .ne. 0) or not (JACFLG = 0), to trigger a call to DPKSET.
C IPUP is set to MITER when RC differs from 1 by more than CCMAX,
C and at least every MSBP steps, when JACFLG = 1.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C-----------------------------------------------------------------------
 200  IF (jacflg .NE. 0) GO TO 202
      ipup = 0
      crate = 0.7d0
      GO TO 205
 202  IF (abs(rc-1.0d0) .GT. ccmax) ipup = miter
      IF (nst .GE. nslp+msbp) ipup = miter
 205  tn = tn + h
      i1 = nqnyh + 1
      DO 215 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 210 i = i1,nqnyh
 210      yh1(i) = yh1(i) + yh1(i+nyh)
 215    CONTINUE
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the RMS-norm of each correction, weighted by the error
C weight vector EWT.  The sum of the corrections is accumulated in the
C vector ACOR(i).  The YH array is not altered in the corrector loop.
C-----------------------------------------------------------------------
 220  m = 0
      mnewt = 0
      DO 230 i = 1,n
 230    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      IF (ipup .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, DPKSET is called to update any matrix data needed,
C before starting the corrector iteration.
C IPUP is set to 0 as an indicator that this has been done.
C-----------------------------------------------------------------------
      CALL dpkset (neq, y, yh1, ewt, acor, savf, wm, iwm, f, jac)
      ipup = 0
      rc = 1.0d0
      nslp = nst
      crate = 0.7d0
      IF (ierpj .NE. 0) GO TO 430
 250  DO 260 i = 1,n
 260    acor(i) = 0.0d0
 270  IF (miter .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation.
C-----------------------------------------------------------------------
      DO 290 i = 1,n
        savf(i) = h*savf(i) - yh(i,2)
 290    y(i) = savf(i) - acor(i)
      del = dvnorm(n, y, ewt)
      DO 300 i = 1,n
        y(i) = yh(i,1) + el(1)*savf(i)
 300    acor(i) = savf(i)
      GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix.
C-----------------------------------------------------------------------
 350  DO 360 i = 1,n
 360    savx(i) = h*savf(i) - (yh(i,2) + acor(i))
      CALL dsolpk (neq, y, savf, savx, ewt, wm, iwm, f, psol)
      IF (iersl .LT. 0) GO TO 430
      IF (iersl .GT. 0) GO TO 410
      del = dvnorm(n, savx, ewt)
      DO 380 i = 1,n
        acor(i) = acor(i) + savx(i)
 380    y(i) = yh(i,1) + el(1)*acor(i)
C-----------------------------------------------------------------------
C Test for convergence.  If M .gt. 0, an estimate of the convergence
C rate constant is stored in CRATE, and this is used in the test.
C-----------------------------------------------------------------------
 400  IF (m .NE. 0) crate = max(0.2d0*crate,del/delp)
      dcon = del*min(1.0d0,1.5d0*crate)/epcon
      IF (dcon .LE. 1.0d0) GO TO 450
      m = m + 1
      IF (m .EQ. maxcor) GO TO 410
      IF (m .GE. 2 .AND. del .GT. 2.0d0*delp) GO TO 410
      mnewt = m
      delp = del
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      GO TO 270
C-----------------------------------------------------------------------
C The corrector iteration failed to converge.
C If MITER .ne. 0 and the Jacobian is out of date, DPKSET is called for
C the next try.  Otherwise the YH array is retracted to its values
C before prediction, and H is reduced, if possible.  If H cannot be
C reduced or MXNCF failures have occurred, exit with KFLAG = -2.
C-----------------------------------------------------------------------
 410  IF (miter.EQ.0 .OR. jcur.EQ.1 .OR. jacflg.EQ.0) GO TO 430
      icf = 1
      ipup = miter
      GO TO 220
 430  icf = 2
      ncf = ncf + 1
      ncfn = ncfn + 1
      rmax = 2.0d0
      tn = told
      i1 = nqnyh + 1
      DO 445 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 440 i = i1,nqnyh
 440      yh1(i) = yh1(i) - yh1(i+nyh)
 445    CONTINUE
      IF (ierpj .LT. 0 .OR. iersl .LT. 0) GO TO 680
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 670
      IF (ncf .EQ. mxncf) GO TO 670
      rh = 0.5d0
      ipup = miter
      iredo = 1
      GO TO 170
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0
C to signal that the Jacobian involved may need updating later.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 450  jcur = 0
      IF (m .EQ. 0) dsm = del/tesco(2,nq)
      IF (m .GT. 0) dsm = dvnorm(n, acor, ewt)/tesco(2,nq)
      IF (dsm .GT. 1.0d0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C Consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      kflag = 0
      iredo = 0
      nst = nst + 1
      hu = h
      nqu = nq
      DO 470 j = 1,l
        DO 470 i = 1,n
 470      yh(i,j) = yh(i,j) + el(j)*acor(i)
      ialth = ialth - 1
      IF (ialth .EQ. 0) GO TO 520
      IF (ialth .GT. 1) GO TO 700
      IF (l .EQ. lmax) GO TO 700
      DO 490 i = 1,n
 490    yh(i,lmax) = acor(i)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.2 or less.
C-----------------------------------------------------------------------
 500  kflag = kflag - 1
      tn = told
      i1 = nqnyh + 1
      DO 515 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 510 i = i1,nqnyh
 510      yh1(i) = yh1(i) - yh1(i+nyh)
 515    CONTINUE
      rmax = 2.0d0
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 660
      IF (kflag .LE. -3) GO TO 640
      iredo = 2
      rhup = 0.0d0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C In the case of failure, RHUP = 0.0 to avoid an order increase.
C the largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  rhup = 0.0d0
      IF (l .EQ. lmax) GO TO 540
      DO 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
      dup = dvnorm(n, savf, ewt)/tesco(3,nq)
      exup = 1.0d0/(l+1)
      rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0)
 540  exsm = 1.0d0/l
      rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rhdn = 0.0d0
      IF (nq .EQ. 1) GO TO 560
      ddn = dvnorm(n, yh(1,l), ewt)/tesco(1,nq)
      exdn = 1.0d0/nq
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
 560  IF (rhsm .GE. rhup) GO TO 570
      IF (rhup .GT. rhdn) GO TO 590
      GO TO 580
 570  IF (rhsm .LT. rhdn) GO TO 580
      newq = nq
      rh = rhsm
      GO TO 620
 580  newq = nq - 1
      rh = rhdn
      IF (kflag .LT. 0 .AND. rh .GT. 1.0d0) rh = 1.0d0
      GO TO 620
 590  newq = l
      rh = rhup
      IF (rh .LT. 1.1d0) GO TO 610
      r = el(l)/l
      DO 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
      GO TO 630
 610  ialth = 3
      GO TO 700
 620  IF ((kflag .EQ. 0) .AND. (rh .LT. 1.1d0)) GO TO 610
      IF (kflag .LE. -2) rh = min(rh,0.2d0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, L, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (newq .EQ. nq) GO TO 170
 630  nq = newq
      l = nq + 1
      iret = 2
      GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more failures have occured.
C If 10 failures have occurred, exit with KFLAG = -1.
C It is assumed that the derivatives that have accumulated in the
C YH array have errors of the wrong order.  Hence the first
C derivative is recomputed, and the order is set to 1.  Then
C H is reduced by a factor of 10, and the step is retried,
C until it succeeds or H reaches HMIN.
C-----------------------------------------------------------------------
 640  IF (kflag .EQ. -10) GO TO 660
      rh = 0.1d0
      rh = max(hmin/abs(h),rh)
      h = h*rh
      DO 645 i = 1,n
 645    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      DO 650 i = 1,n
 650    yh(i,2) = h*savf(i)
      ipup = miter
      ialth = 5
      IF (nq .EQ. 1) GO TO 200
      nq = 1
      l = 2
      iret = 3
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  kflag = -1
      GO TO 720
 670  kflag = -2
      GO TO 720
 680  kflag = -3
      GO TO 720
 690  rmax = 10.0d0
 700  r = 1.0d0/tesco(2,nqu)
      DO 710 i = 1,n
 710    acor(i) = acor(i)*r
 720  hold = h
      jstart = 1
      RETURN
C----------------------- End of Subroutine DSTODPK ---------------------
      END
*DECK DPKSET
      SUBROUTINE dpkset (NEQ, Y, YSV, EWT, FTEM, SAVF, WM, IWM, F, JAC)
      EXTERNAL f, jac
      INTEGER neq, iwm
      DOUBLE PRECISION y, ysv, ewt, ftem, savf, wm
      dimension neq(*), y(*), ysv(*), ewt(*), ftem(*), savf(*),
     1   wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     1   nni, nli, nps, ncfn, ncfl
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
     1   jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     2   nni, nli, nps, ncfn, ncfl
C-----------------------------------------------------------------------
C DPKSET is called by DSTODPK to interface with the user-supplied
C routine JAC, to compute and process relevant parts of
C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy,
C as need for preconditioning matrix operations later.
C
C In addition to variables described previously, communication
C with DPKSET uses the following:
C Y     = array containing predicted values on entry.
C YSV   = array containing predicted y, to be saved (YH1 in DSTODPK).
C FTEM  = work array of length N (ACOR in DSTODPK).
C SAVF  = array containing f evaluated at predicted y.
C WM    = real work space for matrices.
C         Space for preconditioning data starts at WM(LOCWP).
C IWM   = integer work space.
C         Space for preconditioning data starts at IWM(LOCIWP).
C IERPJ = output error flag,  = 0 if no trouble, .gt. 0 if
C         JAC returned an error flag.
C JCUR  = output flag = 1 to indicate that the Jacobian matrix
C         (or approximation) is now current.
C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE.
C-----------------------------------------------------------------------
      INTEGER ier
      DOUBLE PRECISION hl0
C
      ierpj = 0
      jcur = 1
      hl0 = el0*h
      CALL jac (f, neq, tn, y, ysv, ewt, savf, ftem, hl0,
     1   wm(locwp), iwm(lociwp), ier)
      nje = nje + 1
      IF (ier .EQ. 0) RETURN
      ierpj = 1
      RETURN
C----------------------- End of Subroutine DPKSET ----------------------
      END
*DECK DSOLPK
      SUBROUTINE dsolpk (NEQ, Y, SAVF, X, EWT, WM, IWM, F, PSOL)
      EXTERNAL f, psol
      INTEGER neq, iwm
      DOUBLE PRECISION y, savf, x, ewt, wm
      dimension neq(*), y(*), savf(*), x(*), ewt(*), wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     1   nni, nli, nps, ncfn, ncfl
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
     1   jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     2   nni, nli, nps, ncfn, ncfl
C-----------------------------------------------------------------------
C This routine interfaces to one of DSPIOM, DSPIGMR, DPCG, DPCGS, or
C DUSOL, for the solution of the linear system arising from a Newton
C iteration.  It is called if MITER .ne. 0.
C In addition to variables described elsewhere,
C communication with DSOLPK uses the following variables:
C WM    = real work space containing data for the algorithm
C         (Krylov basis vectors, Hessenberg matrix, etc.)
C IWM   = integer work space containing data for the algorithm
C X     = the right-hand side vector on input, and the solution vector
C         on output, of length N.
C IERSL = output flag (in Common):
C         IERSL =  0 means no trouble occurred.
C         IERSL =  1 means the iterative method failed to converge.
C                    If the preconditioner is out of date, the step
C                    is repeated with a new preconditioner.
C                    Otherwise, the stepsize is reduced (forcing a
C                    new evaluation of the preconditioner) and the
C                    step is repeated.
C         IERSL = -1 means there was a nonrecoverable error in the
C                    iterative solver, and an error exit occurs.
C This routine also uses the Common variables TN, EL0, H, N, MITER,
C DELT, EPCON, SQRTN, RSQRTN, MAXL, KMP, MNEWT, NNI, NLI, NPS, NCFL,
C LOCWP, LOCIWP.
C-----------------------------------------------------------------------
      INTEGER iflag, lb, ldl, lhes, liom, lgmr, lpcg, lp, lq, lr,
     1   lv, lw, lwk, lz, maxlp1, npsl
      DOUBLE PRECISION delta, hl0
C
      iersl = 0
      hl0 = h*el0
      delta = delt*epcon
      GO TO (100, 200, 300, 400, 900, 900, 900, 900, 900), miter
C-----------------------------------------------------------------------
C Use the SPIOM algorithm to solve the linear system P*x = -f.
C-----------------------------------------------------------------------
 100  CONTINUE
      lv = 1
      lb = lv + n*maxl
      lhes = lb + n
      lwk = lhes + maxl*maxl
      CALL dcopy (n, x, 1, wm(lb), 1)
      CALL dscal (n, rsqrtn, ewt, 1)
      CALL dspiom (neq, tn, y, savf, wm(lb), ewt, n, maxl, kmp, delta,
     1   hl0, jpre, mnewt, f, psol, npsl, x, wm(lv), wm(lhes), iwm,
     2   liom, wm(locwp), iwm(lociwp), wm(lwk), iflag)
      nni = nni + 1
      nli = nli + liom
      nps = nps + npsl
      CALL dscal (n, sqrtn, ewt, 1)
      IF (iflag .NE. 0) ncfl = ncfl + 1
      IF (iflag .GE. 2) iersl = 1
      IF (iflag .LT. 0) iersl = -1
      RETURN
C-----------------------------------------------------------------------
C Use the SPIGMR algorithm to solve the linear system P*x = -f.
C-----------------------------------------------------------------------
 200  CONTINUE
      maxlp1 = maxl + 1
      lv = 1
      lb = lv + n*maxl
      lhes = lb + n + 1
      lq = lhes + maxl*maxlp1
      lwk = lq + 2*maxl
      ldl = lwk + min(1,maxl-kmp)*n
      CALL dcopy (n, x, 1, wm(lb), 1)
      CALL dscal (n, rsqrtn, ewt, 1)
      CALL dspigmr (neq, tn, y, savf, wm(lb), ewt, n, maxl, maxlp1, kmp,
     1   delta, hl0, jpre, mnewt, f, psol, npsl, x, wm(lv), wm(lhes),
     2   wm(lq), lgmr, wm(locwp), iwm(lociwp), wm(lwk), wm(ldl), iflag)
      nni = nni + 1
      nli = nli + lgmr
      nps = nps + npsl
      CALL dscal (n, sqrtn, ewt, 1)
      IF (iflag .NE. 0) ncfl = ncfl + 1
      IF (iflag .GE. 2) iersl = 1
      IF (iflag .LT. 0) iersl = -1
      RETURN
C-----------------------------------------------------------------------
C Use DPCG to solve the linear system P*x = -f
C-----------------------------------------------------------------------
 300  CONTINUE
      lr = 1
      lp = lr + n
      lw = lp + n
      lz = lw + n
      lwk = lz + n
      CALL dcopy (n, x, 1, wm(lr), 1)
      CALL dpcg (neq, tn, y, savf, wm(lr), ewt, n, maxl, delta, hl0,
     1          jpre, mnewt, f, psol, npsl, x, wm(lp), wm(lw), wm(lz),
     2          lpcg, wm(locwp), iwm(lociwp), wm(lwk), iflag)
      nni = nni + 1
      nli = nli + lpcg
      nps = nps + npsl
      IF (iflag .NE. 0) ncfl = ncfl + 1
      IF (iflag .GE. 2) iersl = 1
      IF (iflag .LT. 0) iersl = -1
      RETURN
C-----------------------------------------------------------------------
C Use DPCGS to solve the linear system P*x = -f
C-----------------------------------------------------------------------
 400  CONTINUE
      lr = 1
      lp = lr + n
      lw = lp + n
      lz = lw + n
      lwk = lz + n
      CALL dcopy (n, x, 1, wm(lr), 1)
      CALL dpcgs (neq, tn, y, savf, wm(lr), ewt, n, maxl, delta, hl0,
     1           jpre, mnewt, f, psol, npsl, x, wm(lp), wm(lw), wm(lz),
     2           lpcg, wm(locwp), iwm(lociwp), wm(lwk), iflag)
      nni = nni + 1
      nli = nli + lpcg
      nps = nps + npsl
      IF (iflag .NE. 0) ncfl = ncfl + 1
      IF (iflag .GE. 2) iersl = 1
      IF (iflag .LT. 0) iersl = -1
      RETURN
C-----------------------------------------------------------------------
C Use DUSOL, which interfaces to PSOL, to solve the linear system
C (no Krylov iteration).
C-----------------------------------------------------------------------
 900  CONTINUE
      lb = 1
      lwk = lb + n
      CALL dcopy (n, x, 1, wm(lb), 1)
      CALL dusol (neq, tn, y, savf, wm(lb), ewt, n, delta, hl0, mnewt,
     1   psol, npsl, x, wm(locwp), iwm(lociwp), wm(lwk), iflag)
      nni = nni + 1
      nps = nps + npsl
      IF (iflag .NE. 0) ncfl = ncfl + 1
      IF (iflag .EQ. 3) iersl = 1
      IF (iflag .LT. 0) iersl = -1
      RETURN
C----------------------- End of Subroutine DSOLPK ----------------------
      END
*DECK DSPIOM
      SUBROUTINE dspiom (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, KMP, DELTA,
     1            HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, IPVT,
     2            LIOM, WP, IWP, WK, IFLAG)
      EXTERNAL f, psol
      INTEGER neq,n,maxl,kmp,jpre,mnewt,npsl,ipvt,liom,iwp,iflag
      DOUBLE PRECISION tn,y,savf,b,wght,delta,hl0,x,v,hes,wp,wk
      dimension neq(*), y(*), savf(*), b(*), wght(*), x(*), v(n,*),
     1   hes(maxl,maxl), ipvt(*), wp(*), iwp(*), wk(*)
C-----------------------------------------------------------------------
C This routine solves the linear system A * x = b using a scaled
C preconditioned version of the Incomplete Orthogonalization Method.
C An initial guess of x = 0 is assumed.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C           TN = current value of t.
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C         B    = the right hand side of the system A*x = b.
C                B is also used as work space when computing the
C                final approximation.
C                (B is the same as V(*,MAXL+1) in the call to DSPIOM.)
C
C         WGHT = array of length N containing scale factors.
C                1/WGHT(i) are the diagonal elements of the diagonal
C                scaling matrix D.
C
C         N    = the order of the matrix A, and the lengths
C                of the vectors Y, SAVF, B, WGHT, and X.
C
C         MAXL = the maximum allowable order of the matrix HES.
C
C          KMP = the number of previous vectors the new vector VNEW
C                must be made orthogonal to.  KMP .le. MAXL.
C
C        DELTA = tolerance on residuals b - A*x in weighted RMS-norm.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C         JPRE = preconditioner type flag.
C
C        MNEWT = Newton iteration counter (.ge. 0).
C
C           WK = real work array of length N used by DATV and PSOL.
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C      On return
C
C         X    = the final computed approximation to the solution
C                of the system A*x = b.
C
C         V    = the N by (LIOM+1) array containing the LIOM
C                orthogonal vectors V(*,1) to V(*,LIOM).
C
C         HES  = the LU factorization of the LIOM by LIOM upper
C                Hessenberg matrix whose entries are the
C                scaled inner products of A*V(*,k) and V(*,i).
C
C         IPVT = an integer array containg pivoting information.
C                It is loaded in DHEFA and used in DHESL.
C
C         LIOM = the number of iterations performed, and current
C                order of the upper Hessenberg matrix HES.
C
C         NPSL = the number of calls to PSOL.
C
C        IFLAG = integer error flag:
C                0 means convergence in LIOM iterations, LIOM.le.MAXL.
C                1 means the convergence test did not pass in MAXL
C                  iterations, but the residual norm is .lt. 1,
C                  or .lt. norm(b) if MNEWT = 0, and so X is computed.
C                2 means the convergence test did not pass in MAXL
C                  iterations, residual .gt. 1, and X is undefined.
C                3 means there was a recoverable error in PSOL
C                  caused by the preconditioner being out of date.
C               -1 means there was a nonrecoverable error in PSOL.
C
C-----------------------------------------------------------------------
      INTEGER i, ier, info, j, k, ll, lm1
      DOUBLE PRECISION bnrm, bnrm0, prod, rho, snormw, dnrm2, tem
C
      iflag = 0
      liom = 0
      npsl = 0
C-----------------------------------------------------------------------
C The initial residual is the vector b.  Apply scaling to b, and test
C for an immediate return with X = 0 or X = b.
C-----------------------------------------------------------------------
      DO 10 i = 1,n
 10     v(i,1) = b(i)*wght(i)
      bnrm0 = dnrm2(n, v, 1)
      bnrm = bnrm0
      IF (bnrm0 .GT. delta) GO TO 30
      IF (mnewt .GT. 0) GO TO 20
      CALL dcopy (n, b, 1, x, 1)
      RETURN
 20   DO 25 i = 1,n
 25     x(i) = 0.0d0
      RETURN
 30   CONTINUE
C Apply inverse of left preconditioner to vector b. --------------------
      ier = 0
      IF (jpre .EQ. 0 .OR. jpre .EQ. 2) GO TO 55
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, b, 1, ier)
      npsl = 1
      IF (ier .NE. 0) GO TO 300
C Calculate norm of scaled vector V(*,1) and normalize it. -------------
      DO 50 i = 1,n
 50     v(i,1) = b(i)*wght(i)
      bnrm = dnrm2(n, v, 1)
      delta = delta*(bnrm/bnrm0)
 55   tem = 1.0d0/bnrm
      CALL dscal (n, tem, v(1,1), 1)
C Zero out the HES array. ----------------------------------------------
      DO 65 j = 1,maxl
        DO 60 i = 1,maxl
 60       hes(i,j) = 0.0d0
 65     CONTINUE
C-----------------------------------------------------------------------
C Main loop on LL = l to compute the vectors V(*,2) to V(*,MAXL).
C The running product PROD is needed for the convergence test.
C-----------------------------------------------------------------------
      prod = 1.0d0
      DO 90 ll = 1,maxl
        liom = ll
C-----------------------------------------------------------------------
C Call routine DATV to compute VNEW = Abar*v(l), where Abar is
C the matrix A with scaling and inverse preconditioner factors applied.
C Call routine DORTHOG to orthogonalize the new vector vnew = V(*,l+1).
C Call routine DHEFA to update the factors of HES.
C-----------------------------------------------------------------------
        CALL datv (neq, y, savf, v(1,ll), wght, x, f, psol, v(1,ll+1),
     1        wk, wp, iwp, hl0, jpre, ier, npsl)
        IF (ier .NE. 0) GO TO 300
        CALL dorthog (v(1,ll+1), v, hes, n, ll, maxl, kmp, snormw)
        CALL dhefa (hes, maxl, ll, ipvt, info, ll)
        lm1 = ll - 1
        IF (ll .GT. 1 .AND. ipvt(lm1) .EQ. lm1) prod = prod*hes(ll,lm1)
        IF (info .NE. ll) GO TO 70
C-----------------------------------------------------------------------
C The last pivot in HES was found to be zero.
C If vnew = 0 or l = MAXL, take an error return with IFLAG = 2.
C otherwise, continue the iteration without a convergence test.
C-----------------------------------------------------------------------
        IF (snormw .EQ. 0.0d0) GO TO 120
        IF (ll .EQ. maxl) GO TO 120
        GO TO 80
C-----------------------------------------------------------------------
C Update RHO, the estimate of the norm of the residual b - A*x(l).
C test for convergence.  If passed, compute approximation x(l).
C If failed and l .lt. MAXL, then continue iterating.
C-----------------------------------------------------------------------
 70     CONTINUE
        rho = bnrm*snormw*abs(prod/hes(ll,ll))
        IF (rho .LE. delta) GO TO 200
        IF (ll .EQ. maxl) GO TO 100
C If l .lt. MAXL, store HES(l+1,l) and normalize the vector v(*,l+1).
 80     CONTINUE
        hes(ll+1,ll) = snormw
        tem = 1.0d0/snormw
        CALL dscal (n, tem, v(1,ll+1), 1)
 90     CONTINUE
C-----------------------------------------------------------------------
C l has reached MAXL without passing the convergence test:
C If RHO is not too large, compute a solution anyway and return with
C IFLAG = 1.  Otherwise return with IFLAG = 2.
C-----------------------------------------------------------------------
 100  CONTINUE
      IF (rho .LE. 1.0d0) GO TO 150
      IF (rho .LE. bnrm .AND. mnewt .EQ. 0) GO TO 150
 120  CONTINUE
      iflag = 2
      RETURN
 150  iflag = 1
C-----------------------------------------------------------------------
C Compute the approximation x(l) to the solution.
C Since the vector X was used as work space, and the initial guess
C of the Newton correction is zero, X must be reset to zero.
C-----------------------------------------------------------------------
 200  CONTINUE
      ll = liom
      DO 210 k = 1,ll
 210    b(k) = 0.0d0
      b(1) = bnrm
      CALL dhesl (hes, maxl, ll, ipvt, b)
      DO 220 k = 1,n
 220    x(k) = 0.0d0
      DO 230 i = 1,ll
        CALL daxpy (n, b(i), v(1,i), 1, x, 1)
 230    CONTINUE
      DO 240 i = 1,n
 240    x(i) = x(i)/wght(i)
      IF (jpre .LE. 1) RETURN
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, x, 2, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) GO TO 300
      RETURN
C-----------------------------------------------------------------------
C This block handles error returns forced by routine PSOL.
C-----------------------------------------------------------------------
 300  CONTINUE
      IF (ier .LT. 0) iflag = -1
      IF (ier .GT. 0) iflag = 3
      RETURN
C----------------------- End of Subroutine DSPIOM ----------------------
      END
*DECK DATV
      SUBROUTINE datv (NEQ, Y, SAVF, V, WGHT, FTEM, F, PSOL, Z, VTEM,
     1                WP, IWP, HL0, JPRE, IER, NPSL)
      EXTERNAL f, psol
      INTEGER neq, iwp, jpre, ier, npsl
      DOUBLE PRECISION y, savf, v, wght, ftem, z, vtem, wp, hl0
      dimension neq(*), y(*), savf(*), v(*), wght(*), ftem(*), z(*),
     1   vtem(*), wp(*), iwp(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
C-----------------------------------------------------------------------
C This routine computes the product
C
C   (D-inverse)*(P1-inverse)*(I - hl0*df/dy)*(P2-inverse)*(D*v),
C
C where D is a diagonal scaling matrix, and P1 and P2 are the
C left and right preconditioning matrices, respectively.
C v is assumed to have WRMS norm equal to 1.
C The product is stored in z.  This is computed by a
C difference quotient, a call to F, and two calls to PSOL.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            V = real array of length N (can be the same array as Z).
C
C         WGHT = array of length N containing scale factors.
C                1/WGHT(i) are the diagonal elements of the matrix D.
C
C         FTEM = work array of length N.
C
C         VTEM = work array of length N used to store the
C                unscaled version of V.
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C         JPRE = preconditioner type flag.
C
C
C      On return
C
C            Z = array of length N containing desired scaled
C                matrix-vector product.
C
C          IER = error flag from PSOL.
C
C         NPSL = the number of calls to PSOL.
C
C In addition, this routine uses the Common variables TN, N, NFE.
C-----------------------------------------------------------------------
      INTEGER i
      DOUBLE PRECISION fac, rnorm, dnrm2, tempn
C
C Set VTEM = D * V.
      DO 10 i = 1,n
 10     vtem(i) = v(i)/wght(i)
      ier = 0
      IF (jpre .GE. 2) GO TO 30
C
C JPRE = 0 or 1.  Save Y in Z and increment Y by VTEM.
      CALL dcopy (n, y, 1, z, 1)
      DO 20 i = 1,n
 20     y(i) = z(i) + vtem(i)
      fac = hl0
      GO TO 60
C
C JPRE = 2 or 3.  Apply inverse of right preconditioner to VTEM.
 30   CONTINUE
      CALL psol (neq, tn, y, savf, ftem, hl0, wp, iwp, vtem, 2, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) RETURN
C Calculate L-2 norm of (D-inverse) * VTEM.
      DO 40 i = 1,n
 40     z(i) = vtem(i)*wght(i)
      tempn = dnrm2(n, z, 1)
      rnorm = 1.0d0/tempn
C Save Y in Z and increment Y by VTEM/norm.
      CALL dcopy (n, y, 1, z, 1)
      DO 50 i = 1,n
 50     y(i) = z(i) + vtem(i)*rnorm
      fac = hl0*tempn
C
C For all JPRE, call F with incremented Y argument, and restore Y.
 60   CONTINUE
      CALL f (neq, tn, y, ftem)
      nfe = nfe + 1
      CALL dcopy (n, z, 1, y, 1)
C Set Z = (identity - hl0*Jacobian) * VTEM, using difference quotient.
      DO 70 i = 1,n
 70     z(i) = ftem(i) - savf(i)
      DO 80 i = 1,n
 80     z(i) = vtem(i) - fac*z(i)
C Apply inverse of left preconditioner to Z, if nontrivial.
      IF (jpre .EQ. 0 .OR. jpre .EQ. 2) GO TO 85
      CALL psol (neq, tn, y, savf, ftem, hl0, wp, iwp, z, 1, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) RETURN
 85   CONTINUE
C Apply D-inverse to Z and return.
      DO 90 i = 1,n
 90     z(i) = z(i)*wght(i)
      RETURN
C----------------------- End of Subroutine DATV ------------------------
      END
*DECK DORTHOG
      SUBROUTINE dorthog (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW)
      INTEGER n, ll, ldhes, kmp
      DOUBLE PRECISION vnew, v, hes, snormw
      dimension vnew(*), v(n,*), hes(ldhes,*)
C-----------------------------------------------------------------------
C This routine orthogonalizes the vector VNEW against the previous
C KMP vectors in the V array.  It uses a modified Gram-Schmidt
C orthogonalization procedure with conditional reorthogonalization.
C This is the version of 28 may 1986.
C-----------------------------------------------------------------------
C
C      On entry
C
C         VNEW = the vector of length N containing a scaled product
C                of the Jacobian and the vector V(*,LL).
C
C         V    = the N x l array containing the previous LL
C                orthogonal vectors v(*,1) to v(*,LL).
C
C         HES  = an LL x LL upper Hessenberg matrix containing,
C                in HES(i,k), k.lt.LL, scaled inner products of
C                A*V(*,k) and V(*,i).
C
C        LDHES = the leading dimension of the HES array.
C
C         N    = the order of the matrix A, and the length of VNEW.
C
C         LL   = the current order of the matrix HES.
C
C          KMP = the number of previous vectors the new vector VNEW
C                must be made orthogonal to (KMP .le. MAXL).
C
C
C      On return
C
C         VNEW = the new vector orthogonal to V(*,i0) to V(*,LL),
C                where i0 = MAX(1, LL-KMP+1).
C
C         HES  = upper Hessenberg matrix with column LL filled in with
C                scaled inner products of A*V(*,LL) and V(*,i).
C
C       SNORMW = L-2 norm of VNEW.
C
C-----------------------------------------------------------------------
      INTEGER i, i0
      DOUBLE PRECISION arg, ddot, dnrm2, sumdsq, tem, vnrm
C
C Get norm of unaltered VNEW for later use. ----------------------------
      vnrm = dnrm2(n, vnew, 1)
C-----------------------------------------------------------------------
C Do modified Gram-Schmidt on VNEW = A*v(LL).
C Scaled inner products give new column of HES.
C Projections of earlier vectors are subtracted from VNEW.
C-----------------------------------------------------------------------
      i0 = max(1,ll-kmp+1)
      DO 10 i = i0,ll
        hes(i,ll) = ddot(n, v(1,i), 1, vnew, 1)
        tem = -hes(i,ll)
        CALL daxpy (n, tem, v(1,i), 1, vnew, 1)
 10     CONTINUE
C-----------------------------------------------------------------------
C Compute SNORMW = norm of VNEW.
C If VNEW is small compared to its input value (in norm), then
C reorthogonalize VNEW to V(*,1) through V(*,LL).
C Correct if relative correction exceeds 1000*(unit roundoff).
C finally, correct SNORMW using the dot products involved.
C-----------------------------------------------------------------------
      snormw = dnrm2(n, vnew, 1)
      IF (vnrm + 0.001d0*snormw .NE. vnrm) RETURN
      sumdsq = 0.0d0
      DO 30 i = i0,ll
        tem = -ddot(n, v(1,i), 1, vnew, 1)
        IF (hes(i,ll) + 0.001d0*tem .EQ. hes(i,ll)) GO TO 30
        hes(i,ll) = hes(i,ll) - tem
        CALL daxpy (n, tem, v(1,i), 1, vnew, 1)
        sumdsq = sumdsq + tem**2
 30     CONTINUE
      IF (sumdsq .EQ. 0.0d0) RETURN
      arg = max(0.0d0,snormw**2 - sumdsq)
      snormw = sqrt(arg)
C
      RETURN
C----------------------- End of Subroutine DORTHOG ---------------------
      END
*DECK DSPIGMR
      SUBROUTINE dspigmr (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, MAXLP1,
     1  KMP, DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, Q,
     2  LGMR, WP, IWP, WK, DL, IFLAG)
      EXTERNAL f, psol
      INTEGER neq,n,maxl,maxlp1,kmp,jpre,mnewt,npsl,lgmr,iwp,iflag
      DOUBLE PRECISION tn,y,savf,b,wght,delta,hl0,x,v,hes,q,wp,wk,dl
      dimension neq(*), y(*), savf(*), b(*), wght(*), x(*), v(n,*),
     1    hes(maxlp1,*), q(*), wp(*), iwp(*), wk(*), dl(*)
C-----------------------------------------------------------------------
C This routine solves the linear system A * x = b using a scaled
C preconditioned version of the Generalized Minimal Residual method.
C An initial guess of x = 0 is assumed.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C           TN = current value of t.
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            B = the right hand side of the system A*x = b.
C                B is also used as work space when computing
C                the final approximation.
C                (B is the same as V(*,MAXL+1) in the call to DSPIGMR.)
C
C         WGHT = the vector of length N containing the nonzero
C                elements of the diagonal scaling matrix.
C
C            N = the order of the matrix A, and the lengths
C                of the vectors WGHT, B and X.
C
C         MAXL = the maximum allowable order of the matrix HES.
C
C       MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES.
C
C          KMP = the number of previous vectors the new vector VNEW
C                must be made orthogonal to.  KMP .le. MAXL.
C
C        DELTA = tolerance on residuals b - A*x in weighted RMS-norm.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C         JPRE = preconditioner type flag.
C
C        MNEWT = Newton iteration counter (.ge. 0).
C
C           WK = real work array used by routine DATV and PSOL.
C
C           DL = real work array used for calculation of the residual
C                norm RHO when the method is incomplete (KMP .lt. MAXL).
C                Not needed or referenced in complete case (KMP = MAXL).
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C      On return
C
C         X    = the final computed approximation to the solution
C                of the system A*x = b.
C
C         LGMR = the number of iterations performed and
C                the current order of the upper Hessenberg
C                matrix HES.
C
C         NPSL = the number of calls to PSOL.
C
C         V    = the N by (LGMR+1) array containing the LGMR
C                orthogonal vectors V(*,1) to V(*,LGMR).
C
C         HES  = the upper triangular factor of the QR decomposition
C                of the (LGMR+1) by lgmr upper Hessenberg matrix whose
C                entries are the scaled inner-products of A*V(*,i)
C                and V(*,k).
C
C         Q    = real array of length 2*MAXL containing the components
C                of the Givens rotations used in the QR decomposition
C                of HES.  It is loaded in DHEQR and used in DHELS.
C
C        IFLAG = integer error flag:
C                0 means convergence in LGMR iterations, LGMR .le. MAXL.
C                1 means the convergence test did not pass in MAXL
C                  iterations, but the residual norm is .lt. 1,
C                  or .lt. norm(b) if MNEWT = 0, and so x is computed.
C                2 means the convergence test did not pass in MAXL
C                  iterations, residual .gt. 1, and X is undefined.
C                3 means there was a recoverable error in PSOL
C                  caused by the preconditioner being out of date.
C               -1 means there was a nonrecoverable error in PSOL.
C
C-----------------------------------------------------------------------
      INTEGER i, ier, info, ip1, i2, j, k, ll, llp1
      DOUBLE PRECISION bnrm,bnrm0,c,dlnrm,prod,rho,s,snormw,dnrm2,tem
C
      iflag = 0
      lgmr = 0
      npsl = 0
C-----------------------------------------------------------------------
C The initial residual is the vector b.  Apply scaling to b, and test
C for an immediate return with X = 0 or X = b.
C-----------------------------------------------------------------------
      DO 10 i = 1,n
 10     v(i,1) = b(i)*wght(i)
      bnrm0 = dnrm2(n, v, 1)
      bnrm = bnrm0
      IF (bnrm0 .GT. delta) GO TO 30
      IF (mnewt .GT. 0) GO TO 20
      CALL dcopy (n, b, 1, x, 1)
      RETURN
 20   DO 25 i = 1,n
 25     x(i) = 0.0d0
      RETURN
 30   CONTINUE
C Apply inverse of left preconditioner to vector b. --------------------
      ier = 0
      IF (jpre .EQ. 0 .OR. jpre .EQ. 2) GO TO 55
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, b, 1, ier)
      npsl = 1
      IF (ier .NE. 0) GO TO 300
C Calculate norm of scaled vector V(*,1) and normalize it. -------------
      DO 50 i = 1,n
 50     v(i,1) = b(i)*wght(i)
      bnrm = dnrm2(n, v, 1)
      delta = delta*(bnrm/bnrm0)
 55   tem = 1.0d0/bnrm
      CALL dscal (n, tem, v(1,1), 1)
C Zero out the HES array. ----------------------------------------------
      DO 65 j = 1,maxl
        DO 60 i = 1,maxlp1
 60       hes(i,j) = 0.0d0
 65     CONTINUE
C-----------------------------------------------------------------------
C Main loop to compute the vectors V(*,2) to V(*,MAXL).
C The running product PROD is needed for the convergence test.
C-----------------------------------------------------------------------
      prod = 1.0d0
      DO 90 ll = 1,maxl
        lgmr = ll
C-----------------------------------------------------------------------
C Call routine DATV to compute VNEW = Abar*v(ll), where Abar is
C the matrix A with scaling and inverse preconditioner factors applied.
C Call routine DORTHOG to orthogonalize the new vector VNEW = V(*,LL+1).
C Call routine DHEQR to update the factors of HES.
C-----------------------------------------------------------------------
        CALL datv (neq, y, savf, v(1,ll), wght, x, f, psol, v(1,ll+1),
     1        wk, wp, iwp, hl0, jpre, ier, npsl)
        IF (ier .NE. 0) GO TO 300
        CALL dorthog (v(1,ll+1), v, hes, n, ll, maxlp1, kmp, snormw)
        hes(ll+1,ll) = snormw
        CALL dheqr (hes, maxlp1, ll, q, info, ll)
        IF (info .EQ. ll) GO TO 120
C-----------------------------------------------------------------------
C Update RHO, the estimate of the norm of the residual b - A*xl.
C If KMP .lt. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not
C necessarily orthogonal for LL .gt. KMP.  The vector DL must then
C be computed, and its norm used in the calculation of RHO.
C-----------------------------------------------------------------------
        prod = prod*q(2*ll)
        rho = abs(prod*bnrm)
        IF ((ll.GT.kmp) .AND. (kmp.LT.maxl)) THEN
          IF (ll .EQ. kmp+1) THEN
            CALL dcopy (n, v(1,1), 1, dl, 1)
            DO 75 i = 1,kmp
              ip1 = i + 1
              i2 = i*2
              s = q(i2)
              c = q(i2-1)
              DO 70 k = 1,n
 70             dl(k) = s*dl(k) + c*v(k,ip1)
 75           CONTINUE
            ENDIF
          s = q(2*ll)
          c = q(2*ll-1)/snormw
          llp1 = ll + 1
          DO 80 k = 1,n
 80         dl(k) = s*dl(k) + c*v(k,llp1)
          dlnrm = dnrm2(n, dl, 1)
          rho = rho*dlnrm
          ENDIF
C-----------------------------------------------------------------------
C Test for convergence.  If passed, compute approximation xl.
C if failed and LL .lt. MAXL, then continue iterating.
C-----------------------------------------------------------------------
        IF (rho .LE. delta) GO TO 200
        IF (ll .EQ. maxl) GO TO 100
C-----------------------------------------------------------------------
C Rescale so that the norm of V(1,LL+1) is one.
C-----------------------------------------------------------------------
        tem = 1.0d0/snormw
        CALL dscal (n, tem, v(1,ll+1), 1)
 90     CONTINUE
 100  CONTINUE
      IF (rho .LE. 1.0d0) GO TO 150
      IF (rho .LE. bnrm .AND. mnewt .EQ. 0) GO TO 150
 120  CONTINUE
      iflag = 2
      RETURN
 150  iflag = 1
C-----------------------------------------------------------------------
C Compute the approximation xl to the solution.
C Since the vector X was used as work space, and the initial guess
C of the Newton correction is zero, X must be reset to zero.
C-----------------------------------------------------------------------
 200  CONTINUE
      ll = lgmr
      llp1 = ll + 1
      DO 210 k = 1,llp1
 210    b(k) = 0.0d0
      b(1) = bnrm
      CALL dhels (hes, maxlp1, ll, q, b)
      DO 220 k = 1,n
 220    x(k) = 0.0d0
      DO 230 i = 1,ll
        CALL daxpy (n, b(i), v(1,i), 1, x, 1)
 230    CONTINUE
      DO 240 i = 1,n
 240    x(i) = x(i)/wght(i)
      IF (jpre .LE. 1) RETURN
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, x, 2, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) GO TO 300
      RETURN
C-----------------------------------------------------------------------
C This block handles error returns forced by routine PSOL.
C-----------------------------------------------------------------------
 300  CONTINUE
      IF (ier .LT. 0) iflag = -1
      IF (ier .GT. 0) iflag = 3
C
      RETURN
C----------------------- End of Subroutine DSPIGMR ---------------------
      END
*DECK DPCG
      SUBROUTINE dpcg (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0,
     1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG)
      EXTERNAL f, psol
      INTEGER neq, n, maxl, jpre, mnewt, npsl, lpcg, iwp, iflag
      DOUBLE PRECISION tn,y,savf,r,wght,delta,hl0,x,p,w,z,wp,wk
      dimension neq(*), y(*), savf(*), r(*), wght(*), x(*), p(*), w(*),
     1   z(*), wp(*), iwp(*), wk(*)
C-----------------------------------------------------------------------
C This routine computes the solution to the system A*x = b using a
C preconditioned version of the Conjugate Gradient algorithm.
C It is assumed here that the matrix A and the preconditioner
C matrix M are symmetric positive definite or nearly so.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C           TN = current value of t.
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            R = the right hand side of the system A*x = b.
C
C         WGHT = array of length N containing scale factors.
C                1/WGHT(i) are the diagonal elements of the diagonal
C                scaling matrix D.
C
C            N = the order of the matrix A, and the lengths
C                of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X.
C
C         MAXL = the maximum allowable number of iterates.
C
C        DELTA = tolerance on residuals b - A*x in weighted RMS-norm.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C         JPRE = preconditioner type flag.
C
C        MNEWT = Newton iteration counter (.ge. 0).
C
C           WK = real work array used by routine DATP.
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C      On return
C
C         X    = the final computed approximation to the solution
C                of the system A*x = b.
C
C         LPCG = the number of iterations performed, and current
C                order of the upper Hessenberg matrix HES.
C
C         NPSL = the number of calls to PSOL.
C
C        IFLAG = integer error flag:
C                0 means convergence in LPCG iterations, LPCG .le. MAXL.
C                1 means the convergence test did not pass in MAXL
C                  iterations, but the residual norm is .lt. 1,
C                  or .lt. norm(b) if MNEWT = 0, and so X is computed.
C                2 means the convergence test did not pass in MAXL
C                  iterations, residual .gt. 1, and X is undefined.
C                3 means there was a recoverable error in PSOL
C                  caused by the preconditioner being out of date.
C                4 means there was a zero denominator in the algorithm.
C                  The system matrix or preconditioner matrix is not
C                  sufficiently close to being symmetric pos. definite.
C               -1 means there was a nonrecoverable error in PSOL.
C
C-----------------------------------------------------------------------
      INTEGER i, ier
      DOUBLE PRECISION alpha,beta,bnrm,ptw,rnrm,ddot,dvnorm,ztr,ztr0
C
      iflag = 0
      npsl = 0
      lpcg = 0
      DO 10 i = 1,n
 10     x(i) = 0.0d0
      bnrm = dvnorm(n, r, wght)
C Test for immediate return with X = 0 or X = b. -----------------------
      IF (bnrm .GT. delta) GO TO 20
      IF (mnewt .GT. 0) RETURN
      CALL dcopy (n, r, 1, x, 1)
      RETURN
C
 20   ztr = 0.0d0
C Loop point for PCG iterations. ---------------------------------------
 30   CONTINUE
      lpcg = lpcg + 1
      CALL dcopy (n, r, 1, z, 1)
      ier = 0
      IF (jpre .EQ. 0) GO TO 40
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, z, 3, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) GO TO 100
 40   CONTINUE
      ztr0 = ztr
      ztr = ddot(n, z, 1, r, 1)
      IF (lpcg .NE. 1) GO TO 50
      CALL dcopy (n, z, 1, p, 1)
      GO TO 70
 50   CONTINUE
      IF (ztr0 .EQ. 0.0d0) GO TO 200
      beta = ztr/ztr0
      DO 60 i = 1,n
 60     p(i) = z(i) + beta*p(i)
 70   CONTINUE
C-----------------------------------------------------------------------
C  Call DATP to compute A*p and return the answer in W.
C-----------------------------------------------------------------------
      CALL datp (neq, y, savf, p, wght, hl0, wk, f, w)
C
      ptw = ddot(n, p, 1, w, 1)
      IF (ptw .EQ. 0.0d0) GO TO 200
      alpha = ztr/ptw
      CALL daxpy (n, alpha, p, 1, x, 1)
      alpha = -alpha
      CALL daxpy (n, alpha, w, 1, r, 1)
      rnrm = dvnorm(n, r, wght)
      IF (rnrm .LE. delta) RETURN
      IF (lpcg .LT. maxl) GO TO 30
      iflag = 2
      IF (rnrm .LE. 1.0d0) iflag = 1
      IF (rnrm .LE. bnrm .AND. mnewt .EQ. 0) iflag = 1
      RETURN
C-----------------------------------------------------------------------
C This block handles error returns from PSOL.
C-----------------------------------------------------------------------
 100  CONTINUE
      IF (ier .LT. 0) iflag = -1
      IF (ier .GT. 0) iflag = 3
      RETURN
C-----------------------------------------------------------------------
C This block handles division by zero errors.
C-----------------------------------------------------------------------
 200  CONTINUE
      iflag = 4
      RETURN
C----------------------- End of Subroutine DPCG ------------------------
      END
*DECK DPCGS
      SUBROUTINE dpcgs (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0,
     1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG)
      EXTERNAL f, psol
      INTEGER neq, n, maxl, jpre, mnewt, npsl, lpcg, iwp, iflag
      DOUBLE PRECISION tn,y,savf,r,wght,delta,hl0,x,p,w,z,wp,wk
      dimension neq(*), y(*), savf(*), r(*), wght(*), x(*), p(*), w(*),
     1   z(*), wp(*), iwp(*), wk(*)
C-----------------------------------------------------------------------
C This routine computes the solution to the system A*x = b using a
C scaled preconditioned version of the Conjugate Gradient algorithm.
C It is assumed here that the scaled matrix D**-1 * A * D and the
C scaled preconditioner D**-1 * M * D are close to being
C symmetric positive definite.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C           TN = current value of t.
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            R = the right hand side of the system A*x = b.
C
C         WGHT = array of length N containing scale factors.
C                1/WGHT(i) are the diagonal elements of the diagonal
C                scaling matrix D.
C
C            N = the order of the matrix A, and the lengths
C                of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X.
C
C         MAXL = the maximum allowable number of iterates.
C
C        DELTA = tolerance on residuals b - A*x in weighted RMS-norm.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C         JPRE = preconditioner type flag.
C
C        MNEWT = Newton iteration counter (.ge. 0).
C
C           WK = real work array used by routine DATP.
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C      On return
C
C         X    = the final computed approximation to the solution
C                of the system A*x = b.
C
C         LPCG = the number of iterations performed, and current
C                order of the upper Hessenberg matrix HES.
C
C         NPSL = the number of calls to PSOL.
C
C        IFLAG = integer error flag:
C                0 means convergence in LPCG iterations, LPCG .le. MAXL.
C                1 means the convergence test did not pass in MAXL
C                  iterations, but the residual norm is .lt. 1,
C                  or .lt. norm(b) if MNEWT = 0, and so X is computed.
C                2 means the convergence test did not pass in MAXL
C                  iterations, residual .gt. 1, and X is undefined.
C                3 means there was a recoverable error in PSOL
C                  caused by the preconditioner being out of date.
C                4 means there was a zero denominator in the algorithm.
C                  the scaled matrix or scaled preconditioner is not
C                  sufficiently close to being symmetric pos. definite.
C               -1 means there was a nonrecoverable error in PSOL.
C
C-----------------------------------------------------------------------
      INTEGER i, ier
      DOUBLE PRECISION alpha, beta, bnrm, ptw, rnrm, dvnorm, ztr, ztr0
C
      iflag = 0
      npsl = 0
      lpcg = 0
      DO 10 i = 1,n
 10     x(i) = 0.0d0
      bnrm = dvnorm(n, r, wght)
C Test for immediate return with X = 0 or X = b. -----------------------
      IF (bnrm .GT. delta) GO TO 20
      IF (mnewt .GT. 0) RETURN
      CALL dcopy (n, r, 1, x, 1)
      RETURN
C
 20   ztr = 0.0d0
C Loop point for PCG iterations. ---------------------------------------
 30   CONTINUE
      lpcg = lpcg + 1
      CALL dcopy (n, r, 1, z, 1)
      ier = 0
      IF (jpre .EQ. 0) GO TO 40
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, z, 3, ier)
      npsl = npsl + 1
      IF (ier .NE. 0) GO TO 100
 40   CONTINUE
      ztr0 = ztr
      ztr = 0.0d0
      DO 45 i = 1,n
 45     ztr = ztr + z(i)*r(i)*wght(i)**2
      IF (lpcg .NE. 1) GO TO 50
      CALL dcopy (n, z, 1, p, 1)
      GO TO 70
 50   CONTINUE
      IF (ztr0 .EQ. 0.0d0) GO TO 200
      beta = ztr/ztr0
      DO 60 i = 1,n
 60     p(i) = z(i) + beta*p(i)
 70   CONTINUE
C-----------------------------------------------------------------------
C  Call DATP to compute A*p and return the answer in W.
C-----------------------------------------------------------------------
      CALL datp (neq, y, savf, p, wght, hl0, wk, f, w)
C
      ptw = 0.0d0
      DO 80 i = 1,n
 80     ptw = ptw + p(i)*w(i)*wght(i)**2
      IF (ptw .EQ. 0.0d0) GO TO 200
      alpha = ztr/ptw
      CALL daxpy (n, alpha, p, 1, x, 1)
      alpha = -alpha
      CALL daxpy (n, alpha, w, 1, r, 1)
      rnrm = dvnorm(n, r, wght)
      IF (rnrm .LE. delta) RETURN
      IF (lpcg .LT. maxl) GO TO 30
      iflag = 2
      IF (rnrm .LE. 1.0d0) iflag = 1
      IF (rnrm .LE. bnrm .AND. mnewt .EQ. 0) iflag = 1
      RETURN
C-----------------------------------------------------------------------
C This block handles error returns from PSOL.
C-----------------------------------------------------------------------
 100  CONTINUE
      IF (ier .LT. 0) iflag = -1
      IF (ier .GT. 0) iflag = 3
      RETURN
C-----------------------------------------------------------------------
C This block handles division by zero errors.
C-----------------------------------------------------------------------
 200  CONTINUE
      iflag = 4
      RETURN
C----------------------- End of Subroutine DPCGS -----------------------
      END
*DECK DATP
      SUBROUTINE datp (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W)
      EXTERNAL f
      INTEGER neq
      DOUBLE PRECISION y, savf, p, wght, hl0, wk, w
      dimension neq(*), y(*), savf(*), p(*), wght(*), wk(*), w(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
C-----------------------------------------------------------------------
C This routine computes the product
C
C              w = (I - hl0*df/dy)*p
C
C This is computed by a call to F and a difference quotient.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            P = real array of length N.
C
C         WGHT = array of length N containing scale factors.
C                1/WGHT(i) are the diagonal elements of the matrix D.
C
C           WK = work array of length N.
C
C      On return
C
C
C            W = array of length N containing desired
C                matrix-vector product.
C
C In addition, this routine uses the Common variables TN, N, NFE.
C-----------------------------------------------------------------------
      INTEGER i
      DOUBLE PRECISION fac, pnrm, rpnrm, dvnorm
C
      pnrm = dvnorm(n, p, wght)
      rpnrm = 1.0d0/pnrm
      CALL dcopy (n, y, 1, w, 1)
      DO 20 i = 1,n
 20     y(i) = w(i) + p(i)*rpnrm
      CALL f (neq, tn, y, wk)
      nfe = nfe + 1
      CALL dcopy (n, w, 1, y, 1)
      fac = hl0*pnrm
      DO 40 i = 1,n
 40     w(i) = p(i) - fac*(wk(i) - savf(i))
      RETURN
C----------------------- End of Subroutine DATP ------------------------
      END
*DECK DUSOL
      SUBROUTINE dusol (NEQ, TN, Y, SAVF, B, WGHT, N, DELTA, HL0, MNEWT,
     1   PSOL, NPSL, X, WP, IWP, WK, IFLAG)
      EXTERNAL psol
      INTEGER neq, n, mnewt, npsl, iwp, iflag
      DOUBLE PRECISION tn, y, savf, b, wght, delta, hl0, x, wp, wk
      dimension neq(*), y(*), savf(*), b(*), wght(*), x(*),
     1   wp(*), iwp(*), wk(*)
C-----------------------------------------------------------------------
C This routine solves the linear system A * x = b using only a call
C to the user-supplied routine PSOL (no Krylov iteration).
C If the norm of the right-hand side vector b is smaller than DELTA,
C the vector X returned is X = b (if MNEWT = 0) or X = 0 otherwise.
C PSOL is called with an LR argument of 0.
C-----------------------------------------------------------------------
C
C      On entry
C
C          NEQ = problem size, passed to F and PSOL (NEQ(1) = N).
C
C           TN = current value of t.
C
C            Y = array containing current dependent variable vector.
C
C         SAVF = array containing current value of f(t,y).
C
C            B = the right hand side of the system A*x = b.
C
C         WGHT = the vector of length N containing the nonzero
C                elements of the diagonal scaling matrix.
C
C            N = the order of the matrix A, and the lengths
C                of the vectors WGHT, B and X.
C
C        DELTA = tolerance on residuals b - A*x in weighted RMS-norm.
C
C          HL0 = current value of (step size h) * (coefficient l0).
C
C        MNEWT = Newton iteration counter (.ge. 0).
C
C           WK = real work array used by PSOL.
C
C           WP = real work array used by preconditioner PSOL.
C
C          IWP = integer work array used by preconditioner PSOL.
C
C      On return
C
C         X    = the final computed approximation to the solution
C                of the system A*x = b.
C
C         NPSL = the number of calls to PSOL.
C
C        IFLAG = integer error flag:
C                0 means no trouble occurred.
C                3 means there was a recoverable error in PSOL
C                  caused by the preconditioner being out of date.
C               -1 means there was a nonrecoverable error in PSOL.
C
C-----------------------------------------------------------------------
      INTEGER i, ier
      DOUBLE PRECISION bnrm, dvnorm
C
      iflag = 0
      npsl = 0
C-----------------------------------------------------------------------
C Test for an immediate return with X = 0 or X = b.
C-----------------------------------------------------------------------
      bnrm = dvnorm(n, b, wght)
      IF (bnrm .GT. delta) GO TO 30
      IF (mnewt .GT. 0) GO TO 10
      CALL dcopy (n, b, 1, x, 1)
      RETURN
 10   DO 20 i = 1,n
 20     x(i) = 0.0d0
      RETURN
C Make call to PSOL and copy result from B to X. -----------------------
 30   ier = 0
      CALL psol (neq, tn, y, savf, wk, hl0, wp, iwp, b, 0, ier)
      npsl = 1
      IF (ier .NE. 0) GO TO 100
      CALL dcopy (n, b, 1, x, 1)
      RETURN
C-----------------------------------------------------------------------
C This block handles error returns forced by routine PSOL.
C-----------------------------------------------------------------------
 100  CONTINUE
      IF (ier .LT. 0) iflag = -1
      IF (ier .GT. 0) iflag = 3
      RETURN
C----------------------- End of Subroutine DUSOL -----------------------
      END
*DECK DSRCPK
      SUBROUTINE dsrcpk (RSAV, ISAV, JOB)
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of
C the Common blocks DLS001, DLPK01, which are used
C internally by the DLSODPK solver.
C
C RSAV = real array of length 222 or more.
C ISAV = integer array of length 50 or more.
C JOB  = flag indicating to save or restore the Common blocks:
C        JOB  = 1 if Common is to be saved (written to RSAV/ISAV)
C        JOB  = 2 if Common is to be restored (read from RSAV/ISAV)
C        A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
      INTEGER isav, job
      INTEGER ils, ilsp
      INTEGER i, lenilp, lenrlp, lenils, lenrls
      DOUBLE PRECISION rsav,   rls, rlsp
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils, lenrlp, lenilp
      COMMON /dls001/ rls(218), ils(37)
      COMMON /dlpk01/ rlsp(4), ilsp(13)
      DATA lenrls/218/, lenils/37/, lenrlp/4/, lenilp/13/
C
      IF (job .EQ. 2) GO TO 100
      CALL dcopy (lenrls, rls, 1, rsav, 1)
      CALL dcopy (lenrlp, rlsp, 1, rsav(lenrls+1), 1)
      DO 20 i = 1,lenils
 20     isav(i) = ils(i)
      DO 40 i = 1,lenilp
 40     isav(lenils+i) = ilsp(i)
      RETURN
C
 100  CONTINUE
      CALL dcopy (lenrls, rsav, 1, rls, 1)
      CALL dcopy (lenrlp, rsav(lenrls+1), 1, rlsp, 1)
      DO 120 i = 1,lenils
 120     ils(i) = isav(i)
      DO 140 i = 1,lenilp
 140     ilsp(i) = isav(lenils+i)
      RETURN
C----------------------- End of Subroutine DSRCPK ----------------------
      END
*DECK DHEFA
      SUBROUTINE dhefa (A, LDA, N, IPVT, INFO, JOB)
      INTEGER lda, n, ipvt(*), info, job
      DOUBLE PRECISION a(lda,*)
C-----------------------------------------------------------------------
C     This routine is a modification of the LINPACK routine DGEFA and
C     performs an LU decomposition of an upper Hessenberg matrix A.
C     There are two options available:
C
C          (1)  performing a fresh factorization
C          (2)  updating the LU factors by adding a row and a
C               column to the matrix A.
C-----------------------------------------------------------------------
C     DHEFA factors an upper Hessenberg matrix by elimination.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                JOB = 1    means that a fresh factorization of the
C                           matrix A is desired.
C                JOB .ge. 2 means that the current factorization of A
C                           will be updated by the addition of a row
C                           and a column.
C
C     On return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = k  if  U(k,k) .eq. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DHESL will divide by zero if called.
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 7/20/83.  This version dated 6/20/01.
C
C     BLAS called: DAXPY, IDAMAX
C-----------------------------------------------------------------------
      INTEGER idamax, j, k, km1, kp1, l, nm1
      DOUBLE PRECISION t
C
      IF (job .GT. 1) GO TO 80
C
C A new facorization is desired.  This is essentially the LINPACK
C code with the exception that we know there is only one nonzero
C element below the main diagonal.
C
C     Gaussian elimination with partial pivoting
C
      info = 0
      nm1 = n - 1
      IF (nm1 .LT. 1) GO TO 70
      DO 60 k = 1, nm1
         kp1 = k + 1
C
C        Find L = pivot index
C
         l = idamax(2, a(k,k), 1) + k - 1
         ipvt(k) = l
C
C        Zero pivot implies this column already triangularized
C
         IF (a(l,k) .EQ. 0.0d0) GO TO 40
C
C           Interchange if necessary
C
            IF (l .EQ. k) GO TO 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       CONTINUE
C
C           Compute multipliers
C
            t = -1.0d0/a(k,k)
            a(k+1,k) = a(k+1,k)*t
C
C           Row elimination with column indexing
C
            DO 30 j = kp1, n
               t = a(l,j)
               IF (l .EQ. k) GO TO 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          CONTINUE
               CALL daxpy (n-k, t, a(k+1,k), 1, a(k+1,j), 1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            info = k
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      ipvt(n) = n
      IF (a(n,n) .EQ. 0.0d0) info = n
      RETURN
C
C The old factorization of A will be updated.  A row and a column
C has been added to the matrix A.
C N-1 is now the old order of the matrix.
C
  80  CONTINUE
      nm1 = n - 1
C
C Perform row interchanges on the elements of the new column, and
C perform elimination operations on the elements using the multipliers.
C
      IF (nm1 .LE. 1) GO TO 105
      DO 100 k = 2,nm1
        km1 = k - 1
        l = ipvt(km1)
        t = a(l,n)
        IF (l .EQ. km1) GO TO 90
          a(l,n) = a(km1,n)
          a(km1,n) = t
  90    CONTINUE
        a(k,n) = a(k,n) + a(k,km1)*t
 100    CONTINUE
 105  CONTINUE
C
C Complete update of factorization by decomposing last 2x2 block.
C
      info = 0
C
C        Find L = pivot index
C
         l = idamax(2, a(nm1,nm1), 1) + nm1 - 1
         ipvt(nm1) = l
C
C        Zero pivot implies this column already triangularized
C
         IF (a(l,nm1) .EQ. 0.0d0) GO TO 140
C
C           Interchange if necessary
C
            IF (l .EQ. nm1) GO TO 110
               t = a(l,nm1)
               a(l,nm1) = a(nm1,nm1)
               a(nm1,nm1) = t
  110       CONTINUE
C
C           Compute multipliers
C
            t = -1.0d0/a(nm1,nm1)
            a(n,nm1) = a(n,nm1)*t
C
C           Row elimination with column indexing
C
               t = a(l,n)
               IF (l .EQ. nm1) GO TO 120
                  a(l,n) = a(nm1,n)
                  a(nm1,n) = t
  120          CONTINUE
               a(n,n) = a(n,n) + t*a(n,nm1)
         GO TO 150
  140    CONTINUE
            info = nm1
  150    CONTINUE
      ipvt(n) = n
      IF (a(n,n) .EQ. 0.0d0) info = n
      RETURN
C----------------------- End of Subroutine DHEFA -----------------------
      END
*DECK DHESL
      SUBROUTINE dhesl (A, LDA, N, IPVT, B)
      INTEGER lda, n, ipvt(*)
      DOUBLE PRECISION a(lda,*), b(*)
C-----------------------------------------------------------------------
C This is essentially the LINPACK routine DGESL except for changes
C due to the fact that A is an upper Hessenberg matrix.
C-----------------------------------------------------------------------
C     DHESL solves the real system A * x = b
C     using the factors computed by DHEFA.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DHEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from DHEFA.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C     On return
C
C        B       the solution vector  x .
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 7/20/83.  This version dated 6/20/01.
C
C     BLAS called: DAXPY
C-----------------------------------------------------------------------
      INTEGER k, kb, l, nm1
      DOUBLE PRECISION t
C
      nm1 = n - 1
C
C        Solve  A * x = b
C        First solve  L*y = b
C
         IF (nm1 .LT. 1) GO TO 30
         DO 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            IF (l .EQ. k) GO TO 10
               b(l) = b(k)
               b(k) = t
   10       CONTINUE
            b(k+1) = b(k+1) + t*a(k+1,k)
   20    CONTINUE
   30    CONTINUE
C
C        Now solve  U*x = y
C
         DO 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            CALL daxpy (k-1, t, a(1,k), 1, b(1), 1)
   40    CONTINUE
      RETURN
C----------------------- End of Subroutine DHESL -----------------------
      END
*DECK DHEQR
      SUBROUTINE dheqr (A, LDA, N, Q, INFO, IJOB)
      INTEGER lda, n, info, ijob
      DOUBLE PRECISION a(lda,*), q(*)
C-----------------------------------------------------------------------
C     This routine performs a QR decomposition of an upper
C     Hessenberg matrix A.  There are two options available:
C
C          (1)  performing a fresh decomposition
C          (2)  updating the QR factors by adding a row and a
C               column to the matrix A.
C-----------------------------------------------------------------------
C     DHEQR decomposes an upper Hessenberg matrix by using Givens
C     rotations.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the matrix to be decomposed.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                A is an (N+1) by N Hessenberg matrix.
C
C        IJOB    INTEGER
C                = 1     means that a fresh decomposition of the
C                        matrix A is desired.
C                .ge. 2  means that the current decomposition of A
C                        will be updated by the addition of a row
C                        and a column.
C     On return
C
C        A       the upper triangular matrix R.
C                The factorization can be written Q*A = R, where
C                Q is a product of Givens rotations and R is upper
C                triangular.
C
C        Q       DOUBLE PRECISION(2*N)
C                the factors c and s of each Givens rotation used
C                in decomposing A.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = k  if  A(k,k) .eq. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DHELS will divide by zero
C                     if called.
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 1/13/86.  This version dated 6/20/01.
C-----------------------------------------------------------------------
      INTEGER i, iq, j, k, km1, kp1, nm1
      DOUBLE PRECISION c, s, t, t1, t2
C
      IF (ijob .GT. 1) GO TO 70
C
C A new facorization is desired.
C
C     QR decomposition without pivoting
C
      info = 0
      DO 60 k = 1, n
         km1 = k - 1
         kp1 = k + 1
C
C           Compute kth column of R.
C           First, multiply the kth column of A by the previous
C           k-1 Givens rotations.
C
            IF (km1 .LT. 1) GO TO 20
            DO 10 j = 1, km1
              i = 2*(j-1) + 1
              t1 = a(j,k)
              t2 = a(j+1,k)
              c = q(i)
              s = q(i+1)
              a(j,k) = c*t1 - s*t2
              a(j+1,k) = s*t1 + c*t2
   10         CONTINUE
C
C           Compute Givens components c and s
C
   20       CONTINUE
            iq = 2*km1 + 1
            t1 = a(k,k)
            t2 = a(kp1,k)
            IF (t2 .NE. 0.0d0) GO TO 30
              c = 1.0d0
              s = 0.0d0
              GO TO 50
   30       CONTINUE
            IF (abs(t2) .LT. abs(t1)) GO TO 40
              t = t1/t2
              s = -1.0d0/sqrt(1.0d0+t*t)
              c = -s*t
              GO TO 50
   40       CONTINUE
              t = t2/t1
              c = 1.0d0/sqrt(1.0d0+t*t)
              s = -c*t
   50       CONTINUE
            q(iq) = c
            q(iq+1) = s
            a(k,k) = c*t1 - s*t2
            IF (a(k,k) .EQ. 0.0d0) info = k
   60 CONTINUE
      RETURN
C
C The old factorization of A will be updated.  A row and a column
C has been added to the matrix A.
C N by N-1 is now the old size of the matrix.
C
  70  CONTINUE
      nm1 = n - 1
C
C Multiply the new column by the N previous Givens rotations.
C
      DO 100 k = 1,nm1
        i = 2*(k-1) + 1
        t1 = a(k,n)
        t2 = a(k+1,n)
        c = q(i)
        s = q(i+1)
        a(k,n) = c*t1 - s*t2
        a(k+1,n) = s*t1 + c*t2
 100    CONTINUE
C
C Complete update of decomposition by forming last Givens rotation,
C and multiplying it times the column vector (A(N,N), A(N+1,N)).
C
      info = 0
      t1 = a(n,n)
      t2 = a(n+1,n)
      IF (t2 .NE. 0.0d0) GO TO 110
        c = 1.0d0
        s = 0.0d0
        GO TO 130
 110  CONTINUE
      IF (abs(t2) .LT. abs(t1)) GO TO 120
        t = t1/t2
        s = -1.0d0/sqrt(1.0d0+t*t)
        c = -s*t
        GO TO 130
 120  CONTINUE
        t = t2/t1
        c = 1.0d0/sqrt(1.0d0+t*t)
        s = -c*t
 130  CONTINUE
      iq = 2*n - 1
      q(iq) = c
      q(iq+1) = s
      a(n,n) = c*t1 - s*t2
      IF (a(n,n) .EQ. 0.0d0) info = n
      RETURN
C----------------------- End of Subroutine DHEQR -----------------------
      END
*DECK DHELS
      SUBROUTINE dhels (A, LDA, N, Q, B)
      INTEGER lda, n
      DOUBLE PRECISION a(lda,*), b(*), q(*)
C-----------------------------------------------------------------------
C This is part of the LINPACK routine DGESL with changes
C due to the fact that A is an upper Hessenberg matrix.
C-----------------------------------------------------------------------
C     DHELS solves the least squares problem
C
C           min (b-A*x, b-A*x)
C
C     using the factors computed by DHEQR.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DHEQR which contains the upper
C                triangular factor R in the QR decomposition of A.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                A is originally an (N+1) by N matrix.
C
C        Q       DOUBLE PRECISION(2*N)
C                The coefficients of the N givens rotations
C                used in the QR factorization of A.
C
C        B       DOUBLE PRECISION(N+1)
C                the right hand side vector.
C
C     On return
C
C        B       the solution vector  x .
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 1/13/86.  This version dated 6/20/01.
C
C     BLAS called: DAXPY
C-----------------------------------------------------------------------
      INTEGER iq, k, kb, kp1
      DOUBLE PRECISION c, s, t, t1, t2
C
C        Minimize (b-A*x, b-A*x)
C        First form Q*b.
C
         DO 20 k = 1, n
            kp1 = k + 1
            iq = 2*(k-1) + 1
            c = q(iq)
            s = q(iq+1)
            t1 = b(k)
            t2 = b(kp1)
            b(k) = c*t1 - s*t2
            b(kp1) = s*t1 + c*t2
   20    CONTINUE
C
C        Now solve  R*x = Q*b.
C
         DO 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            CALL daxpy (k-1, t, a(1,k), 1, b(1), 1)
   40    CONTINUE
      RETURN
C----------------------- End of Subroutine DHELS -----------------------
      END
*DECK DLHIN
      SUBROUTINE dlhin (NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND,
     1   EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER)
      EXTERNAL f
      DOUBLE PRECISION t0, y0, ydot, tout, uround, ewt, atol, y,
     1   temp, h0
      INTEGER neq, n, itol, niter, ier
      dimension neq(*), y0(*), ydot(*), ewt(*), atol(*), y(*), temp(*)
C-----------------------------------------------------------------------
C Call sequence input -- NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND,
C                        EWT, ITOL, ATOL, Y, TEMP
C Call sequence output -- H0, NITER, IER
C Common block variables accessed -- None
C
C Subroutines called by DLHIN: F, DCOPY
C Function routines called by DLHIN: DVNORM
C-----------------------------------------------------------------------
C This routine computes the step size, H0, to be attempted on the
C first step, when the user has not supplied a value for this.
C
C First we check that TOUT - T0 differs significantly from zero.  Then
C an iteration is done to approximate the initial second derivative
C and this is used to define H from WRMS-norm(H**2 * yddot / 2) = 1.
C A bias factor of 1/2 is applied to the resulting h.
C The sign of H0 is inferred from the initial values of TOUT and T0.
C
C Communication with DLHIN is done with the following variables:
C
C NEQ    = NEQ array of solver, passed to F.
C N      = size of ODE system, input.
C T0     = initial value of independent variable, input.
C Y0     = vector of initial conditions, input.
C YDOT   = vector of initial first derivatives, input.
C F      = name of subroutine for right-hand side f(t,y), input.
C TOUT   = first output value of independent variable
C UROUND = machine unit roundoff
C EWT, ITOL, ATOL = error weights and tolerance parameters
C                   as described in the driver routine, input.
C Y, TEMP = work arrays of length N.
C H0     = step size to be attempted, output.
C NITER  = number of iterations (and of f evaluations) to compute H0,
C          output.
C IER    = the error flag, returned with the value
C          IER = 0  if no trouble occurred, or
C          IER = -1 if TOUT and t0 are considered too close to proceed.
C-----------------------------------------------------------------------
C
C Type declarations for local variables --------------------------------
C
      DOUBLE PRECISION afi, atoli, delyi, half, hg, hlb, hnew, hrat,
     1     hub, hun, pt1, t1, tdist, tround, two, dvnorm, yddnrm
      INTEGER i, iter
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
      SAVE half, hun, pt1, two
      DATA half /0.5d0/, hun /100.0d0/, pt1 /0.1d0/, two /2.0d0/
C
      niter = 0
      tdist = abs(tout - t0)
      tround = uround*max(abs(t0),abs(tout))
      IF (tdist .LT. two*tround) GO TO 100
C
C Set a lower bound on H based on the roundoff level in T0 and TOUT. ---
      hlb = hun*tround
C Set an upper bound on H based on TOUT-T0 and the initial Y and YDOT. -
      hub = pt1*tdist
      atoli = atol(1)
      DO 10 i = 1,n
        IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
        delyi = pt1*abs(y0(i)) + atoli
        afi = abs(ydot(i))
        IF (afi*hub .GT. delyi) hub = delyi/afi
 10     CONTINUE
C
C Set initial guess for H as geometric mean of upper and lower bounds. -
      iter = 0
      hg = sqrt(hlb*hub)
C If the bounds have crossed, exit with the mean value. ----------------
      IF (hub .LT. hlb) THEN
        h0 = hg
        GO TO 90
      ENDIF
C
C Looping point for iteration. -----------------------------------------
 50   CONTINUE
C Estimate the second derivative as a difference quotient in f. --------
      t1 = t0 + hg
      DO 60 i = 1,n
 60     y(i) = y0(i) + hg*ydot(i)
      CALL f (neq, t1, y, temp)
      DO 70 i = 1,n
 70     temp(i) = (temp(i) - ydot(i))/hg
      yddnrm = dvnorm(n, temp, ewt)
C Get the corresponding new value of H. --------------------------------
      IF (yddnrm*hub*hub .GT. two) THEN
        hnew = sqrt(two/yddnrm)
      ELSE
        hnew = sqrt(hg*hub)
      ENDIF
      iter = iter + 1
C-----------------------------------------------------------------------
C Test the stopping conditions.
C Stop if the new and previous H values differ by a factor of .lt. 2.
C Stop if four iterations have been done.  Also, stop with previous H
C if hnew/hg .gt. 2 after first iteration, as this probably means that
C the second derivative value is bad because of cancellation error.
C-----------------------------------------------------------------------
      IF (iter .GE. 4) GO TO 80
      hrat = hnew/hg
      IF ( (hrat .GT. half) .AND. (hrat .LT. two) ) GO TO 80
      IF ( (iter .GE. 2) .AND. (hnew .GT. two*hg) ) THEN
        hnew = hg
        GO TO 80
      ENDIF
      hg = hnew
      GO TO 50
C
C Iteration done.  Apply bounds, bias factor, and sign. ----------------
 80   h0 = hnew*half
      IF (h0 .LT. hlb) h0 = hlb
      IF (h0 .GT. hub) h0 = hub
 90   h0 = sign(h0, tout - t0)
C Restore Y array from Y0, then exit. ----------------------------------
      CALL dcopy (n, y0, 1, y, 1)
      niter = iter
      ier = 0
      RETURN
C Error return for TOUT - T0 too small. --------------------------------
 100  ier = -1
      RETURN
C----------------------- End of Subroutine DLHIN -----------------------
      END
*DECK DSTOKA
      SUBROUTINE dstoka (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR,
     1   WM, IWM, F, JAC, PSOL)
      EXTERNAL f, jac, psol
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, yh1, ewt, savf, savx, acor, wm
      dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*),
     1   savx(*), acor(*), wm(*), iwm(*)
      INTEGER iownd, ialth, ipup, lmax, meo, nqnyh, nslp,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER newt, nsfi, nslj, njev
      INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     1   nni, nli, nps, ncfn, ncfl
      DOUBLE PRECISION conit, crate, el, elco, hold, rmax, tesco,
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION stifr
      DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
      COMMON /dls001/ conit, crate, el(13), elco(13,12),
     1   hold, rmax, tesco(3,12),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(6), ialth, ipup, lmax, meo, nqnyh, nslp,
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dls002/ stifr, newt, nsfi, nslj, njev
      COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
     1   jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     2   nni, nli, nps, ncfn, ncfl
C-----------------------------------------------------------------------
C DSTOKA performs one step of the integration of an initial value
C problem for a system of Ordinary Differential Equations.
C
C This routine was derived from Subroutine DSTODPK in the DLSODPK
C package by the addition of automatic functional/Newton iteration
C switching and logic for re-use of Jacobian data.
C-----------------------------------------------------------------------
C Note: DSTOKA is independent of the value of the iteration method
C indicator MITER, when this is .ne. 0, and hence is independent
C of the type of chord method used, or the Jacobian structure.
C Communication with DSTOKA is done with the following variables:
C
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls to F and JAC.
C Y      = an array of length .ge. N used as the Y argument in
C          all calls to F and JAC.
C YH     = an NYH by LMAX array containing the dependent variables
C          and their approximate scaled derivatives, where
C          LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C          j-th derivative of y(i), scaled by H**j/factorial(j)
C          (j = 0,1,...,NQ).  On entry for the first step, the first
C          two columns of YH must be set from the initial values.
C NYH    = a constant integer .ge. N, the first dimension of YH.
C YH1    = a one-dimensional array occupying the same space as YH.
C EWT    = an array of length N containing multiplicative weights
C          for local error measurements.  Local errors in y(i) are
C          compared to 1.0/EWT(i) in various error tests.
C SAVF   = an array of working storage, of length N.
C          Also used for input of YH(*,MAXORD+2) when JSTART = -1
C          and MAXORD .lt. the current order NQ.
C SAVX   = an array of working storage, of length N.
C ACOR   = a work array of length N, used for the accumulated
C          corrections.  On a successful return, ACOR(i) contains
C          the estimated one-step local error in y(i).
C WM,IWM = real and integer work arrays associated with matrix
C          operations in chord iteration (MITER .ne. 0).
C CCMAX  = maximum relative change in H*EL0 before DSETPK is called.
C H      = the step size to be attempted on the next step.
C          H is altered by the error control algorithm during the
C          problem.  H can be either positive or negative, but its
C          sign must remain constant throughout the problem.
C HMIN   = the minimum absolute value of the step size H to be used.
C HMXI   = inverse of the maximum absolute value of H to be used.
C          HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C          HMIN and HMXI may be changed at any time, but will not
C          take effect until the next change of H is considered.
C TN     = the independent variable. TN is updated on each step taken.
C JSTART = an integer used for input only, with the following
C          values and meanings:
C               0  perform the first step.
C           .gt.0  take a new step continuing from the last.
C              -1  take the next step with a new value of H, MAXORD,
C                    N, METH, MITER, and/or matrix parameters.
C              -2  take the next step with a new value of H,
C                    but with other inputs unchanged.
C          On return, JSTART is set to 1 to facilitate continuation.
C KFLAG  = a completion code with the following meanings:
C               0  the step was succesful.
C              -1  the requested error could not be achieved.
C              -2  corrector convergence could not be achieved.
C              -3  fatal error in DSETPK or DSOLPK.
C          A return with KFLAG = -1 or -2 means either
C          ABS(H) = HMIN or 10 consecutive failures occurred.
C          On a return with KFLAG negative, the values of TN and
C          the YH array are as of the beginning of the last
C          step, and H is the last step size attempted.
C MAXORD = the maximum order of integration method to be allowed.
C MAXCOR = the maximum number of corrector iterations allowed.
C MSBP   = maximum number of steps between DSETPK calls (MITER .gt. 0).
C MXNCF  = maximum number of convergence failures allowed.
C METH/MITER = the method flags.  See description in driver.
C N      = the number of first-order differential equations.
C-----------------------------------------------------------------------
      INTEGER i, i1, iredo, iret, j, jb, jok, m, ncf, newq, nslow
      DOUBLE PRECISION dcon, ddn, del, delp, drc, dsm, dup, exdn, exsm,
     1   exup, dfnorm, r, rh, rhdn, rhsm, rhup, roc, stiff, told, dvnorm
C
      kflag = 0
      told = tn
      ncf = 0
      ierpj = 0
      iersl = 0
      jcur = 0
      icf = 0
      delp = 0.0d0
      IF (jstart .GT. 0) GO TO 200
      IF (jstart .EQ. -1) GO TO 100
      IF (jstart .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set at 2
C for the next increase.
C-----------------------------------------------------------------------
      lmax = maxord + 1
      nq = 1
      l = 2
      ialth = 2
      rmax = 10000.0d0
      rc = 0.0d0
      el0 = 1.0d0
      crate = 0.7d0
      hold = h
      meo = meth
      nslp = 0
      nslj = 0
      ipup = 0
      iret = 3
      newt = 0
      stifr = 0.0d0
      GO TO 140
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If the caller has changed MAXORD to a value less than the current
C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  ipup = miter
      lmax = maxord + 1
      IF (ialth .EQ. 1) ialth = 2
      IF (meth .EQ. meo) GO TO 110
      CALL dcfode (meth, elco, tesco)
      meo = meth
      IF (nq .GT. maxord) GO TO 120
      ialth = l
      iret = 1
      GO TO 150
 110  IF (nq .LE. maxord) GO TO 160
 120  nq = maxord
      l = lmax
      DO 125 i = 1,l
 125    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      epcon = conit*tesco(2,nq)
      ddn = dvnorm(n, savf, ewt)/tesco(1,l)
      exdn = 1.0d0/l
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
      rh = min(rhdn,1.0d0)
      iredo = 3
      IF (h .EQ. hold) GO TO 170
      rh = min(rh,abs(h/hold))
      h = hold
      GO TO 175
C-----------------------------------------------------------------------
C DCFODE is called to get all the integration coefficients for the
C current METH.  Then the EL vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 140  CALL dcfode (meth, elco, tesco)
 150  DO 155 i = 1,l
 155    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      epcon = conit*tesco(2,nq)
      GO TO (160, 170, 200), iret
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (h .EQ. hold) GO TO 200
      rh = h/hold
      h = hold
      iredo = 3
      GO TO 175
 170  rh = max(rh,hmin/abs(h))
 175  rh = min(rh,rmax)
      rh = rh/max(1.0d0,abs(h)*hmxi*rh)
      r = 1.0d0
      DO 180 j = 2,l
        r = r*rh
        DO 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
      h = h*rh
      rc = rc*rh
      ialth = l
      IF (iredo .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C The flag IPUP is set according to whether matrix data is involved
C (NEWT .gt. 0 .and. JACFLG .ne. 0) or not, to trigger a call to DSETPK.
C IPUP is set to MITER when RC differs from 1 by more than CCMAX,
C and at least every MSBP steps, when JACFLG = 1.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C-----------------------------------------------------------------------
 200  IF (newt .EQ. 0 .OR. jacflg .EQ. 0) THEN
        drc = 0.0d0
        ipup = 0
        crate = 0.7d0
      ELSE
        drc = abs(rc - 1.0d0)
        IF (drc .GT. ccmax) ipup = miter
        IF (nst .GE. nslp+msbp) ipup = miter
        ENDIF
      tn = tn + h
      i1 = nqnyh + 1
      DO 215 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 210 i = i1,nqnyh
 210      yh1(i) = yh1(i) + yh1(i+nyh)
 215    CONTINUE
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the RMS-norm of each correction, weighted by the error
C weight vector EWT.  The sum of the corrections is accumulated in the
C vector ACOR(i).  The YH array is not altered in the corrector loop.
C Within the corrector loop, an estimated rate of convergence (ROC)
C and a stiffness ratio estimate (STIFF) are kept.  Corresponding
C global estimates are kept as CRATE and stifr.
C-----------------------------------------------------------------------
 220  m = 0
      mnewt = 0
      stiff = 0.0d0
      roc = 0.05d0
      nslow = 0
      DO 230 i = 1,n
 230    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      IF (newt .EQ. 0 .OR. ipup .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, DSETPK is called to update any matrix data needed,
C before starting the corrector iteration.
C JOK is set to indicate if the matrix data need not be recomputed.
C IPUP is set to 0 as an indicator that the matrix data is up to date.
C-----------------------------------------------------------------------
      jok = 1
      IF (nst .EQ. 0 .OR. nst .GT. nslj+50) jok = -1
      IF (icf .EQ. 1 .AND. drc .LT. 0.2d0) jok = -1
      IF (icf .EQ. 2) jok = -1
      IF (jok .EQ. -1) THEN
        nslj = nst
        njev = njev + 1
        ENDIF
      CALL dsetpk (neq, y, yh1, ewt, acor, savf, jok, wm, iwm, f, jac)
      ipup = 0
      rc = 1.0d0
      drc = 0.0d0
      nslp = nst
      crate = 0.7d0
      IF (ierpj .NE. 0) GO TO 430
 250  DO 260 i = 1,n
 260    acor(i) = 0.0d0
 270  IF (newt .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation, and STIFF is set to 1.0.
C-----------------------------------------------------------------------
      DO 290 i = 1,n
        savf(i) = h*savf(i) - yh(i,2)
 290    y(i) = savf(i) - acor(i)
      del = dvnorm(n, y, ewt)
      DO 300 i = 1,n
        y(i) = yh(i,1) + el(1)*savf(i)
 300    acor(i) = savf(i)
      stiff = 1.0d0
      GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix.  STIFF is set to the ratio of the norms
C of the residual and the correction vector.
C-----------------------------------------------------------------------
 350  DO 360 i = 1,n
 360    savx(i) = h*savf(i) - (yh(i,2) + acor(i))
      dfnorm = dvnorm(n, savx, ewt)
      CALL dsolpk (neq, y, savf, savx, ewt, wm, iwm, f, psol)
      IF (iersl .LT. 0) GO TO 430
      IF (iersl .GT. 0) GO TO 410
      del = dvnorm(n, savx, ewt)
      IF (del .GT. 1.0d-8) stiff = max(stiff, dfnorm/del)
      DO 380 i = 1,n
        acor(i) = acor(i) + savx(i)
 380    y(i) = yh(i,1) + el(1)*acor(i)
C-----------------------------------------------------------------------
C Test for convergence.  If M .gt. 0, an estimate of the convergence
C rate constant is made for the iteration switch, and is also used
C in the convergence test.   If the iteration seems to be diverging or
C converging at a slow rate (.gt. 0.8 more than once), it is stopped.
C-----------------------------------------------------------------------
 400  IF (m .NE. 0) THEN
        roc = max(0.05d0, del/delp)
        crate = max(0.2d0*crate,roc)
        ENDIF
      dcon = del*min(1.0d0,1.5d0*crate)/epcon
      IF (dcon .LE. 1.0d0) GO TO 450
      m = m + 1
      IF (m .EQ. maxcor) GO TO 410
      IF (m .GE. 2 .AND. del .GT. 2.0d0*delp) GO TO 410
      IF (roc .GT. 10.0d0) GO TO 410
      IF (roc .GT. 0.8d0) nslow = nslow + 1
      IF (nslow .GE. 2) GO TO 410
      mnewt = m
      delp = del
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      GO TO 270
C-----------------------------------------------------------------------
C The corrector iteration failed to converge.
C If functional iteration is being done (NEWT = 0) and MITER .gt. 0
C (and this is not the first step), then switch to Newton
C (NEWT = MITER), and retry the step.  (Setting STIFR = 1023 insures
C that a switch back will not occur for 10 step attempts.)
C If Newton iteration is being done, but using a preconditioner that
C is out of date (JACFLG .ne. 0 .and. JCUR = 0), then signal for a
C re-evalutation of the preconditioner, and retry the step.
C In all other cases, the YH array is retracted to its values
C before prediction, and H is reduced, if possible.  If H cannot be
C reduced or MXNCF failures have occurred, exit with KFLAG = -2.
C-----------------------------------------------------------------------
 410  icf = 1
      IF (newt .EQ. 0) THEN
        IF (nst .EQ. 0) GO TO 430
        IF (miter .EQ. 0) GO TO 430
        newt = miter
        stifr = 1023.0d0
        ipup = miter
        GO TO 220
        ENDIF
      IF (jcur.EQ.1 .OR. jacflg.EQ.0) GO TO 430
      ipup = miter
      GO TO 220
 430  icf = 2
      ncf = ncf + 1
      ncfn = ncfn + 1
      rmax = 2.0d0
      tn = told
      i1 = nqnyh + 1
      DO 445 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 440 i = i1,nqnyh
 440      yh1(i) = yh1(i) - yh1(i+nyh)
 445    CONTINUE
      IF (ierpj .LT. 0 .OR. iersl .LT. 0) GO TO 680
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 670
      IF (ncf .EQ. mxncf) GO TO 670
      rh = 0.5d0
      ipup = miter
      iredo = 1
      GO TO 170
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0 to signal that the
C preconditioner involved may need updating later.
C The stiffness ratio STIFR is updated using the latest STIFF value.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 450  jcur = 0
      IF (newt .GT. 0) stifr = 0.5d0*(stifr + stiff)
      IF (m .EQ. 0) dsm = del/tesco(2,nq)
      IF (m .GT. 0) dsm = dvnorm(n, acor, ewt)/tesco(2,nq)
      IF (dsm .GT. 1.0d0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C If Newton iteration is being done and STIFR is less than 1.5,
C then switch to functional iteration.
C Consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      kflag = 0
      iredo = 0
      nst = nst + 1
      IF (newt .EQ. 0) nsfi = nsfi + 1
      IF (newt .GT. 0 .AND. stifr .LT. 1.5d0) newt = 0
      hu = h
      nqu = nq
      DO 470 j = 1,l
        DO 470 i = 1,n
 470      yh(i,j) = yh(i,j) + el(j)*acor(i)
      ialth = ialth - 1
      IF (ialth .EQ. 0) GO TO 520
      IF (ialth .GT. 1) GO TO 700
      IF (l .EQ. lmax) GO TO 700
      DO 490 i = 1,n
 490    yh(i,lmax) = acor(i)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.2 or less.
C-----------------------------------------------------------------------
 500  kflag = kflag - 1
      tn = told
      i1 = nqnyh + 1
      DO 515 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 510 i = i1,nqnyh
 510      yh1(i) = yh1(i) - yh1(i+nyh)
 515    CONTINUE
      rmax = 2.0d0
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 660
      IF (kflag .LE. -3) GO TO 640
      iredo = 2
      rhup = 0.0d0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C in the case of failure, RHUP = 0.0 to avoid an order increase.
C the largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  rhup = 0.0d0
      IF (l .EQ. lmax) GO TO 540
      DO 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
      dup = dvnorm(n, savf, ewt)/tesco(3,nq)
      exup = 1.0d0/(l+1)
      rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0)
 540  exsm = 1.0d0/l
      rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rhdn = 0.0d0
      IF (nq .EQ. 1) GO TO 560
      ddn = dvnorm(n, yh(1,l), ewt)/tesco(1,nq)
      exdn = 1.0d0/nq
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
 560  IF (rhsm .GE. rhup) GO TO 570
      IF (rhup .GT. rhdn) GO TO 590
      GO TO 580
 570  IF (rhsm .LT. rhdn) GO TO 580
      newq = nq
      rh = rhsm
      GO TO 620
 580  newq = nq - 1
      rh = rhdn
      IF (kflag .LT. 0 .AND. rh .GT. 1.0d0) rh = 1.0d0
      GO TO 620
 590  newq = l
      rh = rhup
      IF (rh .LT. 1.1d0) GO TO 610
      r = el(l)/l
      DO 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
      GO TO 630
 610  ialth = 3
      GO TO 700
 620  IF ((kflag .EQ. 0) .AND. (rh .LT. 1.1d0)) GO TO 610
      IF (kflag .LE. -2) rh = min(rh,0.2d0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, L, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (newq .EQ. nq) GO TO 170
 630  nq = newq
      l = nq + 1
      iret = 2
      GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more failures have occured.
C If 10 failures have occurred, exit with KFLAG = -1.
C It is assumed that the derivatives that have accumulated in the
C YH array have errors of the wrong order.  Hence the first
C derivative is recomputed, and the order is set to 1.  Then
C H is reduced by a factor of 10, and the step is retried,
C until it succeeds or H reaches HMIN.
C-----------------------------------------------------------------------
 640  IF (kflag .EQ. -10) GO TO 660
      rh = 0.1d0
      rh = max(hmin/abs(h),rh)
      h = h*rh
      DO 645 i = 1,n
 645    y(i) = yh(i,1)
      CALL f (neq, tn, y, savf)
      nfe = nfe + 1
      DO 650 i = 1,n
 650    yh(i,2) = h*savf(i)
      ipup = miter
      ialth = 5
      IF (nq .EQ. 1) GO TO 200
      nq = 1
      l = 2
      iret = 3
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  kflag = -1
      GO TO 720
 670  kflag = -2
      GO TO 720
 680  kflag = -3
      GO TO 720
 690  rmax = 10.0d0
 700  r = 1.0d0/tesco(2,nqu)
      DO 710 i = 1,n
 710    acor(i) = acor(i)*r
 720  hold = h
      jstart = 1
      RETURN
C----------------------- End of Subroutine DSTOKA ----------------------
      END
*DECK DSETPK
      SUBROUTINE dsetpk (NEQ, Y, YSV, EWT, FTEM, SAVF, JOK, WM, IWM,
     1                  F, JAC)
      EXTERNAL f, jac
      INTEGER neq, jok, iwm
      DOUBLE PRECISION y, ysv, ewt, ftem, savf, wm
      dimension neq(*), y(*), ysv(*), ewt(*), ftem(*), savf(*),
     1   wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     1   nni, nli, nps, ncfn, ncfl
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION delt, epcon, sqrtn, rsqrtn
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlpk01/ delt, epcon, sqrtn, rsqrtn,
     1   jpre, jacflg, locwp, lociwp, lsavx, kmp, maxl, mnewt,
     2   nni, nli, nps, ncfn, ncfl
C-----------------------------------------------------------------------
C DSETPK is called by DSTOKA to interface with the user-supplied
C routine JAC, to compute and process relevant parts of
C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy,
C as need for preconditioning matrix operations later.
C
C In addition to variables described previously, communication
C with DSETPK uses the following:
C Y     = array containing predicted values on entry.
C YSV   = array containing predicted y, to be saved (YH1 in DSTOKA).
C FTEM  = work array of length N (ACOR in DSTOKA).
C SAVF  = array containing f evaluated at predicted y.
C JOK   = input flag showing whether it was judged that Jacobian matrix
C         data need not be recomputed (JOK = 1) or needs to be
C         (JOK = -1).
C WM    = real work space for matrices.
C         Space for preconditioning data starts at WM(LOCWP).
C IWM   = integer work space.
C         Space for preconditioning data starts at IWM(LOCIWP).
C IERPJ = output error flag,  = 0 if no trouble, .gt. 0 if
C         JAC returned an error flag.
C JCUR  = output flag to indicate whether the matrix data involved
C         is now current (JCUR = 1) or not (JCUR = 0).
C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE.
C-----------------------------------------------------------------------
      INTEGER ier
      DOUBLE PRECISION hl0
C
      ierpj = 0
      jcur = 0
      IF (jok .EQ. -1) jcur = 1
      hl0 = el0*h
      CALL jac (f, neq, tn, y, ysv, ewt, savf, ftem, hl0, jok,
     1   wm(locwp), iwm(lociwp), ier)
      nje = nje + 1
      IF (ier .EQ. 0) RETURN
      ierpj = 1
      RETURN
C----------------------- End of Subroutine DSETPK ----------------------
      END
*DECK DSRCKR
      SUBROUTINE dsrckr (RSAV, ISAV, JOB)
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of
C the Common blocks DLS001, DLS002, DLSR01, DLPK01, which
C are used internally by the DLSODKR solver.
C
C RSAV = real array of length 228 or more.
C ISAV = integer array of length 63 or more.
C JOB  = flag indicating to save or restore the Common blocks:
C        JOB  = 1 if Common is to be saved (written to RSAV/ISAV)
C        JOB  = 2 if Common is to be restored (read from RSAV/ISAV)
C        A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
      INTEGER isav, job
      INTEGER ils, ils2, ilsr, ilsp
      INTEGER i, ioff, lenilp, lenrlp, lenils, lenrls, lenilr, lenrlr
      DOUBLE PRECISION rsav,   rls, rls2, rlsr, rlsp
      dimension rsav(*), isav(*)
      SAVE lenrls, lenils, lenrlp, lenilp, lenrlr, lenilr
      COMMON /dls001/ rls(218), ils(37)
      COMMON /dls002/ rls2, ils2(4)
      COMMON /dlsr01/ rlsr(5), ilsr(9)
      COMMON /dlpk01/ rlsp(4), ilsp(13)
      DATA lenrls/218/, lenils/37/, lenrlp/4/, lenilp/13/
      DATA lenrlr/5/, lenilr/9/
C
      IF (job .EQ. 2) GO TO 100
      CALL dcopy (lenrls, rls, 1, rsav, 1)
      rsav(lenrls+1) = rls2
      CALL dcopy (lenrlr, rlsr, 1, rsav(lenrls+2), 1)
      CALL dcopy (lenrlp, rlsp, 1, rsav(lenrls+lenrlr+2), 1)
      DO 20 i = 1,lenils
 20     isav(i) = ils(i)
      isav(lenils+1) = ils2(1)
      isav(lenils+2) = ils2(2)
      isav(lenils+3) = ils2(3)
      isav(lenils+4) = ils2(4)
      ioff = lenils + 2
      DO 30 i = 1,lenilr
 30     isav(ioff+i) = ilsr(i)
      ioff = ioff + lenilr
      DO 40 i = 1,lenilp
 40     isav(ioff+i) = ilsp(i)
      RETURN
C
 100  CONTINUE
      CALL dcopy (lenrls, rsav, 1, rls, 1)
      rls2 = rsav(lenrls+1)
      CALL dcopy (lenrlr, rsav(lenrls+2), 1, rlsr, 1)
      CALL dcopy (lenrlp, rsav(lenrls+lenrlr+2), 1, rlsp, 1)
      DO 120 i = 1,lenils
 120    ils(i) = isav(i)
      ils2(1) = isav(lenils+1)
      ils2(2) = isav(lenils+2)
      ils2(3) = isav(lenils+3)
      ils2(4) = isav(lenils+4)
      ioff = lenils + 2
      DO 130 i = 1,lenilr
 130    ilsr(i) = isav(ioff+i)
      ioff = ioff + lenilr
      DO 140 i = 1,lenilp
 140    ilsp(i) = isav(ioff+i)
      RETURN
C----------------------- End of Subroutine DSRCKR ----------------------
      END
*DECK DAINVG
      SUBROUTINE dainvg (RES, ADDA, NEQ, T, Y, YDOT, MITER,
     1                   ML, MU, PW, IPVT, IER )
      EXTERNAL res, adda
      INTEGER neq, miter, ml, mu, ipvt, ier
      INTEGER i, lenpw, mlp1, nrowpw
      DOUBLE PRECISION t, y, ydot, pw
      dimension y(*), ydot(*), pw(*), ipvt(*)
C-----------------------------------------------------------------------
C This subroutine computes the initial value
C of the vector YDOT satisfying
C     A * YDOT = g(t,y)
C when A is nonsingular.  It is called by DLSODI for
C initialization only, when ISTATE = 0 .
C DAINVG returns an error flag IER:
C   IER  =  0  means DAINVG was successful.
C   IER .ge. 2 means RES returned an error flag IRES = IER.
C   IER .lt. 0 means the a-matrix was found to be singular.
C-----------------------------------------------------------------------
C
      IF (miter .GE. 4)  GO TO 100
C
C Full matrix case -----------------------------------------------------
C
      lenpw = neq*neq
      DO 10  i = 1, lenpw
   10    pw(i) = 0.0d0
C
      ier = 1
      CALL res ( neq, t, y, pw, ydot, ier )
      IF (ier .GT. 1) RETURN
C
      CALL adda ( neq, t, y, 0, 0, pw, neq )
      CALL dgefa ( pw, neq, neq, ipvt, ier )
      IF (ier .EQ. 0) GO TO 20
         ier = -ier
         RETURN
   20 CALL dgesl ( pw, neq, neq, ipvt, ydot, 0 )
      RETURN
C
C Band matrix case -----------------------------------------------------
C
  100 CONTINUE
      nrowpw = 2*ml + mu + 1
      lenpw = neq * nrowpw
      DO 110  i = 1, lenpw
  110    pw(i) = 0.0d0
C
      ier = 1
      CALL res ( neq, t, y, pw, ydot, ier )
      IF (ier .GT. 1) RETURN
C
      mlp1 = ml + 1
      CALL adda ( neq, t, y, ml, mu, pw(mlp1), nrowpw )
      CALL dgbfa ( pw, nrowpw, neq, ml, mu, ipvt, ier )
      IF (ier .EQ. 0) GO TO 120
         ier = -ier
         RETURN
  120 CALL dgbsl ( pw, nrowpw, neq, ml, mu, ipvt, ydot, 0 )
      RETURN
C----------------------- End of Subroutine DAINVG ----------------------
      END
*DECK DSTODI
      SUBROUTINE dstodi (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVR,
     1   ACOR, WM, IWM, RES, ADDA, JAC, PJAC, SLVS )
      EXTERNAL res, adda, jac, pjac, slvs
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, yh1, ewt, savf, savr, acor, wm
      dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*),
     1   savr(*), acor(*), wm(*), iwm(*)
      INTEGER iownd, ialth, ipup, lmax, meo, nqnyh, nslp,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION conit, crate, el, elco, hold, rmax, tesco,
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ conit, crate, el(13), elco(13,12),
     1   hold, rmax, tesco(3,12),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(6), ialth, ipup, lmax, meo, nqnyh, nslp,
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, i1, iredo, ires, iret, j, jb, kgo, m, ncf, newq
      DOUBLE PRECISION dcon, ddn, del, delp, dsm, dup,
     1   eljh, el1h, exdn, exsm, exup,
     2   r, rh, rhdn, rhsm, rhup, told, dvnorm
C-----------------------------------------------------------------------
C DSTODI performs one step of the integration of an initial value
C problem for a system of Ordinary Differential Equations.
C Note: DSTODI is independent of the value of the iteration method
C indicator MITER, and hence is independent
C of the type of chord method used, or the Jacobian structure.
C Communication with DSTODI is done with the following variables:
C
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls to RES, ADDA,
C          and JAC.
C Y      = an array of length .ge. N used as the Y argument in
C          all calls to RES, JAC, and ADDA.
C NEQ    = integer array containing problem size in NEQ(1), and
C          passed as the NEQ argument in all calls tO RES, G, ADDA,
C          and JAC.
C YH     = an NYH by LMAX array containing the dependent variables
C          and their approximate scaled derivatives, where
C          LMAX = MAXORD + 1.  YH(i,j+1) contains the approximate
C          j-th derivative of y(i), scaled by H**j/factorial(j)
C          (j = 0,1,...,NQ).  On entry for the first step, the first
C          two columns of YH must be set from the initial values.
C NYH    = a constant integer .ge. N, the first dimension of YH.
C YH1    = a one-dimensional array occupying the same space as YH.
C EWT    = an array of length N containing multiplicative weights
C          for local error measurements.  Local errors in y(i) are
C          compared to 1.0/EWT(i) in various error tests.
C SAVF   = an array of working storage, of length N. also used for
C          input of YH(*,MAXORD+2) when JSTART = -1 and MAXORD is less
C          than the current order NQ.
C          Same as YDOTI in the driver.
C SAVR   = an array of working storage, of length N.
C ACOR   = a work array of length N used for the accumulated
C          corrections. On a succesful return, ACOR(i) contains
C          the estimated one-step local error in y(i).
C WM,IWM = real and integer work arrays associated with matrix
C          operations in chord iteration.
C PJAC   = name of routine to evaluate and preprocess Jacobian matrix.
C SLVS   = name of routine to solve linear system in chord iteration.
C CCMAX  = maximum relative change in H*EL0 before PJAC is called.
C H      = the step size to be attempted on the next step.
C          H is altered by the error control algorithm during the
C          problem.  H can be either positive or negative, but its
C          sign must remain constant throughout the problem.
C HMIN   = the minimum absolute value of the step size H to be used.
C HMXI   = inverse of the maximum absolute value of H to be used.
C          HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C          HMIN and HMXI may be changed at any time, but will not
C          take effect until the next change of H is considered.
C TN     = the independent variable. TN is updated on each step taken.
C JSTART = an integer used for input only, with the following
C          values and meanings:
C               0  perform the first step.
C           .gt.0  take a new step continuing from the last.
C              -1  take the next step with a new value of H, MAXORD,
C                    N, METH, MITER, and/or matrix parameters.
C              -2  take the next step with a new value of H,
C                    but with other inputs unchanged.
C          On return, JSTART is set to 1 to facilitate continuation.
C KFLAG  = a completion code with the following meanings:
C               0  the step was succesful.
C              -1  the requested error could not be achieved.
C              -2  corrector convergence could not be achieved.
C              -3  RES ordered immediate return.
C              -4  error condition from RES could not be avoided.
C              -5  fatal error in PJAC or SLVS.
C          A return with KFLAG = -1, -2, or -4 means either
C          ABS(H) = HMIN or 10 consecutive failures occurred.
C          On a return with KFLAG negative, the values of TN and
C          the YH array are as of the beginning of the last
C          step, and H is the last step size attempted.
C MAXORD = the maximum order of integration method to be allowed.
C MAXCOR = the maximum number of corrector iterations allowed.
C MSBP   = maximum number of steps between PJAC calls.
C MXNCF  = maximum number of convergence failures allowed.
C METH/MITER = the method flags.  See description in driver.
C N      = the number of first-order differential equations.
C-----------------------------------------------------------------------
      kflag = 0
      told = tn
      ncf = 0
      ierpj = 0
      iersl = 0
      jcur = 0
      icf = 0
      delp = 0.0d0
      IF (jstart .GT. 0) GO TO 200
      IF (jstart .EQ. -1) GO TO 100
      IF (jstart .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized.  RMAX is the maximum ratio by which H can be increased
C in a single step.  It is initially 1.E4 to compensate for the small
C initial H, but then is normally equal to 10.  If a failure
C occurs (in corrector convergence or error test), RMAX is set at 2
C for the next increase.
C-----------------------------------------------------------------------
      lmax = maxord + 1
      nq = 1
      l = 2
      ialth = 2
      rmax = 10000.0d0
      rc = 0.0d0
      el0 = 1.0d0
      crate = 0.7d0
      hold = h
      meo = meth
      nslp = 0
      ipup = miter
      iret = 3
      GO TO 140
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C IPUP is set to MITER to force a matrix update.
C If an order increase is about to be considered (IALTH = 1),
C IALTH is reset to 2 to postpone consideration one more step.
C If the caller has changed METH, DCFODE is called to reset
C the coefficients of the method.
C If the caller has changed MAXORD to a value less than the current
C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly.
C If H is to be changed, YH must be rescaled.
C If H or METH is being changed, IALTH is reset to L = NQ + 1
C to prevent further changes in H for that many steps.
C-----------------------------------------------------------------------
 100  ipup = miter
      lmax = maxord + 1
      IF (ialth .EQ. 1) ialth = 2
      IF (meth .EQ. meo) GO TO 110
      CALL dcfode (meth, elco, tesco)
      meo = meth
      IF (nq .GT. maxord) GO TO 120
      ialth = l
      iret = 1
      GO TO 150
 110  IF (nq .LE. maxord) GO TO 160
 120  nq = maxord
      l = lmax
      DO 125 i = 1,l
 125    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      ddn = dvnorm(n, savf, ewt)/tesco(1,l)
      exdn = 1.0d0/l
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
      rh = min(rhdn,1.0d0)
      iredo = 3
      IF (h .EQ. hold) GO TO 170
      rh = min(rh,abs(h/hold))
      h = hold
      GO TO 175
C-----------------------------------------------------------------------
C DCFODE is called to get all the integration coefficients for the
C current METH.  Then the EL vector and related constants are reset
C whenever the order NQ is changed, or at the start of the problem.
C-----------------------------------------------------------------------
 140  CALL dcfode (meth, elco, tesco)
 150  DO 155 i = 1,l
 155    el(i) = elco(i,nq)
      nqnyh = nq*nyh
      rc = rc*el(1)/el0
      el0 = el(1)
      conit = 0.5d0/(nq+2)
      GO TO (160, 170, 200), iret
C-----------------------------------------------------------------------
C If H is being changed, the H ratio RH is checked against
C RMAX, HMIN, and HMXI, and the YH array rescaled.  IALTH is set to
C L = NQ + 1 to prevent a change of H for that many steps, unless
C forced by a convergence or error test failure.
C-----------------------------------------------------------------------
 160  IF (h .EQ. hold) GO TO 200
      rh = h/hold
      h = hold
      iredo = 3
      GO TO 175
 170  rh = max(rh,hmin/abs(h))
 175  rh = min(rh,rmax)
      rh = rh/max(1.0d0,abs(h)*hmxi*rh)
      r = 1.0d0
      DO 180 j = 2,l
        r = r*rh
        DO 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
      h = h*rh
      rc = rc*rh
      ialth = l
      IF (iredo .EQ. 0) GO TO 690
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C RC is the ratio of new to old values of the coefficient  H*EL(1).
C When RC differs from 1 by more than CCMAX, IPUP is set to MITER
C to force PJAC to be called.
C In any case, PJAC is called at least every MSBP steps.
C-----------------------------------------------------------------------
 200  IF (abs(rc-1.0d0) .GT. ccmax) ipup = miter
      IF (nst .GE. nslp+msbp) ipup = miter
      tn = tn + h
      i1 = nqnyh + 1
      DO 215 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 210 i = i1,nqnyh
 210      yh1(i) = yh1(i) + yh1(i+nyh)
 215    CONTINUE
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken.  A convergence test is
C made on the RMS-norm of each correction, weighted by H and the
C error weight vector EWT.  The sum of the corrections is accumulated
C in ACOR(i).  The YH array is not altered in the corrector loop.
C-----------------------------------------------------------------------
 220  m = 0
      DO 230 i = 1,n
        savf(i) = yh(i,2) / h
 230    y(i) = yh(i,1)
      IF (ipup .LE. 0) GO TO 240
C-----------------------------------------------------------------------
C If indicated, the matrix P = A - H*EL(1)*dr/dy is reevaluated and
C preprocessed before starting the corrector iteration.  IPUP is set
C to 0 as an indicator that this has been done.
C-----------------------------------------------------------------------
      CALL pjac (neq, y, yh, nyh, ewt, acor, savr, savf, wm, iwm,
     1   res, jac, adda )
      ipup = 0
      rc = 1.0d0
      nslp = nst
      crate = 0.7d0
      IF (ierpj .EQ. 0) GO TO 250
      IF (ierpj .LT. 0) GO TO 435
      ires = ierpj
      GO TO (430, 435, 430), ires
C Get residual at predicted values, if not already done in PJAC. -------
 240  ires = 1
      CALL res ( neq, tn, y, savf, savr, ires )
      nfe = nfe + 1
      kgo = abs(ires)
      GO TO ( 250, 435, 430 ) , kgo
 250  DO 260 i = 1,n
 260    acor(i) = 0.0d0
C-----------------------------------------------------------------------
C Solve the linear system with the current residual as
C right-hand side and P as coefficient matrix.
C-----------------------------------------------------------------------
 270  CONTINUE
      CALL slvs (wm, iwm, savr, savf)
      IF (iersl .LT. 0) GO TO 430
      IF (iersl .GT. 0) GO TO 410
      el1h = el(1) * h
      del = dvnorm(n, savr, ewt) * abs(h)
      DO 380 i = 1,n
        acor(i) = acor(i) + savr(i)
        savf(i) = acor(i) + yh(i,2)/h
 380    y(i) = yh(i,1) + el1h*acor(i)
C-----------------------------------------------------------------------
C Test for convergence.  If M .gt. 0, an estimate of the convergence
C rate constant is stored in CRATE, and this is used in the test.
C-----------------------------------------------------------------------
      IF (m .NE. 0) crate = max(0.2d0*crate,del/delp)
      dcon = del*min(1.0d0,1.5d0*crate)/(tesco(2,nq)*conit)
      IF (dcon .LE. 1.0d0) GO TO 460
      m = m + 1
      IF (m .EQ. maxcor) GO TO 410
      IF (m .GE. 2 .AND. del .GT. 2.0d0*delp) GO TO 410
      delp = del
      ires = 1
      CALL res ( neq, tn, y, savf, savr, ires )
      nfe = nfe + 1
      kgo = abs(ires)
      GO TO ( 270, 435, 410 ) , kgo
C-----------------------------------------------------------------------
C The correctors failed to converge, or RES has returned abnormally.
C on a convergence failure, if the Jacobian is out of date, PJAC is
C called for the next try.  Otherwise the YH array is retracted to its
C values before prediction, and H is reduced, if possible.
C take an error exit if IRES = 2, or H cannot be reduced, or MXNCF
C failures have occurred, or a fatal error occurred in PJAC or SLVS.
C-----------------------------------------------------------------------
 410  icf = 1
      IF (jcur .EQ. 1) GO TO 430
      ipup = miter
      GO TO 220
 430  icf = 2
      ncf = ncf + 1
      rmax = 2.0d0
 435  tn = told
      i1 = nqnyh + 1
      DO 445 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 440 i = i1,nqnyh
 440      yh1(i) = yh1(i) - yh1(i+nyh)
 445    CONTINUE
      IF (ires .EQ. 2) GO TO 680
      IF (ierpj .LT. 0 .OR. iersl .LT. 0) GO TO 685
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 450
      IF (ncf .EQ. mxncf) GO TO 450
      rh = 0.25d0
      ipup = miter
      iredo = 1
      GO TO 170
 450  IF (ires .EQ. 3) GO TO 680
      GO TO 670
C-----------------------------------------------------------------------
C The corrector has converged.  JCUR is set to 0
C to signal that the Jacobian involved may need updating later.
C The local error test is made and control passes to statement 500
C if it fails.
C-----------------------------------------------------------------------
 460  jcur = 0
      IF (m .EQ. 0) dsm = del/tesco(2,nq)
      IF (m .GT. 0) dsm = abs(h) * dvnorm(n, acor, ewt)/tesco(2,nq)
      IF (dsm .GT. 1.0d0) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH array.
C Consider changing H if IALTH = 1.  Otherwise decrease IALTH by 1.
C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for
C use in a possible order increase on the next step.
C If a change in H is considered, an increase or decrease in order
C by one is considered also.  A change in H is made only if it is by a
C factor of at least 1.1.  If not, IALTH is set to 3 to prevent
C testing for that many steps.
C-----------------------------------------------------------------------
      kflag = 0
      iredo = 0
      nst = nst + 1
      hu = h
      nqu = nq
      DO 470 j = 1,l
        eljh = el(j)*h
        DO 470 i = 1,n
 470      yh(i,j) = yh(i,j) + eljh*acor(i)
      ialth = ialth - 1
      IF (ialth .EQ. 0) GO TO 520
      IF (ialth .GT. 1) GO TO 700
      IF (l .EQ. lmax) GO TO 700
      DO 490 i = 1,n
 490    yh(i,lmax) = acor(i)
      GO TO 700
C-----------------------------------------------------------------------
C The error test failed.  KFLAG keeps track of multiple failures.
C restore TN and the YH array to their previous values, and prepare
C to try the step again.  Compute the optimum step size for this or
C one lower order.  After 2 or more failures, H is forced to decrease
C by a factor of 0.1 or less.
C-----------------------------------------------------------------------
 500  kflag = kflag - 1
      tn = told
      i1 = nqnyh + 1
      DO 515 jb = 1,nq
        i1 = i1 - nyh
CDIR$ IVDEP
        DO 510 i = i1,nqnyh
 510      yh1(i) = yh1(i) - yh1(i+nyh)
 515    CONTINUE
      rmax = 2.0d0
      IF (abs(h) .LE. hmin*1.00001d0) GO TO 660
      IF (kflag .LE. -7) GO TO 660
      iredo = 2
      rhup = 0.0d0
      GO TO 540
C-----------------------------------------------------------------------
C Regardless of the success or failure of the step, factors
C RHDN, RHSM, and RHUP are computed, by which H could be multiplied
C at order NQ - 1, order NQ, or order NQ + 1, respectively.
C In the case of failure, RHUP = 0.0 to avoid an order increase.
C The largest of these is determined and the new order chosen
C accordingly.  If the order is to be increased, we compute one
C additional scaled derivative.
C-----------------------------------------------------------------------
 520  rhup = 0.0d0
      IF (l .EQ. lmax) GO TO 540
      DO 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
      dup = abs(h) * dvnorm(n, savf, ewt)/tesco(3,nq)
      exup = 1.0d0/(l+1)
      rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0)
 540  exsm = 1.0d0/l
      rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0)
      rhdn = 0.0d0
      IF (nq .EQ. 1) GO TO 560
      ddn = dvnorm(n, yh(1,l), ewt)/tesco(1,nq)
      exdn = 1.0d0/nq
      rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0)
 560  IF (rhsm .GE. rhup) GO TO 570
      IF (rhup .GT. rhdn) GO TO 590
      GO TO 580
 570  IF (rhsm .LT. rhdn) GO TO 580
      newq = nq
      rh = rhsm
      GO TO 620
 580  newq = nq - 1
      rh = rhdn
      IF (kflag .LT. 0 .AND. rh .GT. 1.0d0) rh = 1.0d0
      GO TO 620
 590  newq = l
      rh = rhup
      IF (rh .LT. 1.1d0) GO TO 610
      r = h*el(l)/l
      DO 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
      GO TO 630
 610  ialth = 3
      GO TO 700
 620  IF ((kflag .EQ. 0) .AND. (rh .LT. 1.1d0)) GO TO 610
      IF (kflag .LE. -2) rh = min(rh,0.1d0)
C-----------------------------------------------------------------------
C If there is a change of order, reset NQ, L, and the coefficients.
C In any case H is reset according to RH and the YH array is rescaled.
C Then exit from 690 if the step was OK, or redo the step otherwise.
C-----------------------------------------------------------------------
      IF (newq .EQ. nq) GO TO 170
 630  nq = newq
      l = nq + 1
      iret = 2
      GO TO 150
C-----------------------------------------------------------------------
C All returns are made through this section.  H is saved in HOLD
C to allow the caller to change H on the next step.
C-----------------------------------------------------------------------
 660  kflag = -1
      GO TO 720
 670  kflag = -2
      GO TO 720
 680  kflag = -1 - ires
      GO TO 720
 685  kflag = -5
      GO TO 720
 690  rmax = 10.0d0
 700  r = h/tesco(2,nqu)
      DO 710 i = 1,n
 710    acor(i) = acor(i)*r
 720  hold = h
      jstart = 1
      RETURN
C----------------------- End of Subroutine DSTODI ----------------------
      END
*DECK DPREPJI
      SUBROUTINE dprepji (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WM, IWM,
     1   RES, JAC, ADDA)
      EXTERNAL res, jac, adda
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, ewt, rtem, savr, s, wm
      dimension neq(*), y(*), yh(nyh,*), ewt(*), rtem(*),
     1   s(*), savr(*), wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, i1, i2, ier, ii, ires, j, j1, jj, lenp,
     1   mba, mband, meb1, meband, ml, ml3, mu
      DOUBLE PRECISION con, fac, hl0, r, srur, yi, yj, yjj
C-----------------------------------------------------------------------
C DPREPJI is called by DSTODI to compute and process the matrix
C P = A - H*EL(1)*J , where J is an approximation to the Jacobian dr/dy,
C where r = g(t,y) - A(t,y)*s.  Here J is computed by the user-supplied
C routine JAC if MITER = 1 or 4, or by finite differencing if MITER =
C 2 or 5.  J is stored in WM, rescaled, and ADDA is called to generate
C P. P is then subjected to LU decomposition in preparation
C for later solution of linear systems with P as coefficient
C matrix.  This is done by DGEFA if MITER = 1 or 2, and by
C DGBFA if MITER = 4 or 5.
C
C In addition to variables described previously, communication
C with DPREPJI uses the following:
C Y     = array containing predicted values on entry.
C RTEM  = work array of length N (ACOR in DSTODI).
C SAVR  = array used for output only.  On output it contains the
C         residual evaluated at current values of t and y.
C S     = array containing predicted values of dy/dt (SAVF in DSTODI).
C WM    = real work space for matrices.  On output it contains the
C         LU decomposition of P.
C         Storage of matrix elements starts at WM(3).
C         WM also contains the following matrix-related data:
C         WM(1) = SQRT(UROUND), used in numerical Jacobian increments.
C IWM   = integer work space containing pivot information, starting at
C         IWM(21).  IWM also contains the band parameters
C         ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
C EL0   = el(1) (input).
C IERPJ = output error flag.
C         = 0 if no trouble occurred,
C         = 1 if the P matrix was found to be singular,
C         = IRES (= 2 or 3) if RES returned IRES = 2 or 3.
C JCUR  = output flag = 1 to indicate that the Jacobian matrix
C         (or approximation) is now current.
C This routine also uses the Common variables EL0, H, TN, UROUND,
C MITER, N, NFE, and NJE.
C-----------------------------------------------------------------------
      nje = nje + 1
      hl0 = h*el0
      ierpj = 0
      jcur = 1
      GO TO (100, 200, 300, 400, 500), miter
C If MITER = 1, call RES, then JAC, and multiply by scalar. ------------
 100  ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      lenp = n*n
      DO 110 i = 1,lenp
 110    wm(i+2) = 0.0d0
      CALL jac ( neq, tn, y, s, 0, 0, wm(3), n )
      con = -hl0
      DO 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
      GO TO 240
C If MITER = 2, make N + 1 calls to RES to approximate J. --------------
 200  CONTINUE
      ires = -1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      srur = wm(1)
      j1 = 2
      DO 230 j = 1,n
        yj = y(j)
        r = max(srur*abs(yj),0.01d0/ewt(j))
        y(j) = y(j) + r
        fac = -hl0/r
        CALL res ( neq, tn, y, s, rtem, ires )
        nfe = nfe + 1
        IF (ires .GT. 1) GO TO 600
        DO 220 i = 1,n
 220      wm(i+j1) = (rtem(i) - savr(i))*fac
        y(j) = yj
        j1 = j1 + n
 230    CONTINUE
      ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
C Add matrix A. --------------------------------------------------------
 240  CONTINUE
      CALL adda(neq, tn, y, 0, 0, wm(3), n)
C Do LU decomposition on P. --------------------------------------------
      CALL dgefa (wm(3), n, n, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C Dummy section for MITER = 3
 300  RETURN
C If MITER = 4, call RES, then JAC, and multiply by scalar. ------------
 400  ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      ml = iwm(1)
      mu = iwm(2)
      ml3 = ml + 3
      mband = ml + mu + 1
      meband = mband + ml
      lenp = meband*n
      DO 410 i = 1,lenp
 410    wm(i+2) = 0.0d0
      CALL jac ( neq, tn, y, s, ml, mu, wm(ml3), meband)
      con = -hl0
      DO 420 i = 1,lenp
 420    wm(i+2) = wm(i+2)*con
      GO TO 570
C If MITER = 5, make ML + MU + 2 calls to RES to approximate J. --------
 500  CONTINUE
      ires = -1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      ml = iwm(1)
      mu = iwm(2)
      ml3 = ml + 3
      mband = ml + mu + 1
      mba = min(mband,n)
      meband = mband + ml
      meb1 = meband - 1
      srur = wm(1)
      DO 560 j = 1,mba
        DO 530 i = j,n,mband
          yi = y(i)
          r = max(srur*abs(yi),0.01d0/ewt(i))
 530      y(i) = y(i) + r
        CALL res ( neq, tn, y, s, rtem, ires)
        nfe = nfe + 1
        IF (ires .GT. 1) GO TO 600
        DO 550 jj = j,n,mband
          y(jj) = yh(jj,1)
          yjj = y(jj)
          r = max(srur*abs(yjj),0.01d0/ewt(jj))
          fac = -hl0/r
          i1 = max(jj-mu,1)
          i2 = min(jj+ml,n)
          ii = jj*meb1 - ml + 2
          DO 540 i = i1,i2
 540        wm(ii+i) = (rtem(i) - savr(i))*fac
 550      CONTINUE
 560    CONTINUE
      ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
C Add matrix A. --------------------------------------------------------
  570 CONTINUE
      CALL adda(neq, tn, y, ml, mu, wm(ml3), meband)
C Do LU decomposition of P. --------------------------------------------
      CALL dgbfa (wm(3), meband, n, ml, mu, iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C Error return for IRES = 2 or IRES = 3 return from RES. ---------------
 600  ierpj = ires
      RETURN
C----------------------- End of Subroutine DPREPJI ---------------------
      END
*DECK DAIGBT
      SUBROUTINE daigbt (RES, ADDA, NEQ, T, Y, YDOT,
     1                   MB, NB, PW, IPVT, IER )
      EXTERNAL res, adda
      INTEGER neq, mb, nb, ipvt, ier
      INTEGER i, lenpw, lblox, lpb, lpc
      DOUBLE PRECISION t, y, ydot, pw
      dimension y(*), ydot(*), pw(*), ipvt(*), neq(*)
C-----------------------------------------------------------------------
C This subroutine computes the initial value
C of the vector YDOT satisfying
C     A * YDOT = g(t,y)
C when A is nonsingular.  It is called by DLSOIBT for
C initialization only, when ISTATE = 0 .
C DAIGBT returns an error flag IER:
C   IER  =  0  means DAIGBT was successful.
C   IER .ge. 2 means RES returned an error flag IRES = IER.
C   IER .lt. 0 means the A matrix was found to have a singular
C              diagonal block (hence YDOT could not be solved for).
C-----------------------------------------------------------------------
      lblox = mb*mb*nb
      lpb = 1 + lblox
      lpc = lpb + lblox
      lenpw = 3*lblox
      DO 10 i = 1,lenpw
 10     pw(i) = 0.0d0
      ier = 1
      CALL res (neq, t, y, pw, ydot, ier)
      IF (ier .GT. 1) RETURN
      CALL adda (neq, t, y, mb, nb, pw(1), pw(lpb), pw(lpc) )
      CALL ddecbt (mb, nb, pw, pw(lpb), pw(lpc), ipvt, ier)
      IF (ier .EQ. 0) GO TO 20
      ier = -ier
      RETURN
 20   CALL dsolbt (mb, nb, pw, pw(lpb), pw(lpc), ydot, ipvt)
      RETURN
C----------------------- End of Subroutine DAIGBT ----------------------
      END
*DECK DPJIBT
      SUBROUTINE dpjibt (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WM, IWM,
     1   RES, JAC, ADDA)
      EXTERNAL res, jac, adda
      INTEGER neq, nyh, iwm
      DOUBLE PRECISION y, yh, ewt, rtem, savr, s, wm
      dimension neq(*), y(*), yh(nyh,*), ewt(*), rtem(*),
     1   s(*), savr(*), wm(*), iwm(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      INTEGER i, ier, iia, iib, iic, ipa, ipb, ipc, ires, j, j1, j2,
     1   k, k1, lenp, lblox, lpb, lpc, mb, mbsq, mwid, nb
      DOUBLE PRECISION con, fac, hl0, r, srur
C-----------------------------------------------------------------------
C DPJIBT is called by DSTODI to compute and process the matrix
C P = A - H*EL(1)*J , where J is an approximation to the Jacobian dr/dy,
C and r = g(t,y) - A(t,y)*s.  Here J is computed by the user-supplied
C routine JAC if MITER = 1, or by finite differencing if MITER = 2.
C J is stored in WM, rescaled, and ADDA is called to generate P.
C P is then subjected to LU decomposition by DDECBT in preparation
C for later solution of linear systems with P as coefficient matrix.
C
C In addition to variables described previously, communication
C with DPJIBT uses the following:
C Y     = array containing predicted values on entry.
C RTEM  = work array of length N (ACOR in DSTODI).
C SAVR  = array used for output only.  On output it contains the
C         residual evaluated at current values of t and y.
C S     = array containing predicted values of dy/dt (SAVF in DSTODI).
C WM    = real work space for matrices.  On output it contains the
C         LU decomposition of P.
C         Storage of matrix elements starts at WM(3).
C         WM also contains the following matrix-related data:
C         WM(1) = SQRT(UROUND), used in numerical Jacobian increments.
C IWM   = integer work space containing pivot information, starting at
C         IWM(21).  IWM also contains block structure parameters
C         MB = IWM(1) and NB = IWM(2).
C EL0   = EL(1) (input).
C IERPJ = output error flag.
C         = 0 if no trouble occurred,
C         = 1 if the P matrix was found to be unfactorable,
C         = IRES (= 2 or 3) if RES returned IRES = 2 or 3.
C JCUR  = output flag = 1 to indicate that the Jacobian matrix
C         (or approximation) is now current.
C This routine also uses the Common variables EL0, H, TN, UROUND,
C MITER, N, NFE, and NJE.
C-----------------------------------------------------------------------
      nje = nje + 1
      hl0 = h*el0
      ierpj = 0
      jcur = 1
      mb = iwm(1)
      nb = iwm(2)
      mbsq = mb*mb
      lblox = mbsq*nb
      lpb = 3 + lblox
      lpc = lpb + lblox
      lenp = 3*lblox
      GO TO (100, 200), miter
C If MITER = 1, call RES, then JAC, and multiply by scalar. ------------
 100  ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      DO 110 i = 1,lenp
 110    wm(i+2) = 0.0d0
      CALL jac (neq, tn, y, s, mb, nb, wm(3), wm(lpb), wm(lpc))
      con = -hl0
      DO 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
      GO TO 260
C
C If MITER = 2, make 3*MB + 1 calls to RES to approximate J. -----------
 200  CONTINUE
      ires = -1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      mwid = 3*mb
      srur = wm(1)
      DO 205 i = 1,lenp
 205    wm(2+i) = 0.0d0
      DO 250 k = 1,3
        DO 240 j = 1,mb
C         Increment Y(I) for group of column indices, and call RES. ----
          j1 = j+(k-1)*mb
          DO 210 i = j1,n,mwid
            r = max(srur*abs(y(i)),0.01d0/ewt(i))
            y(i) = y(i) + r
 210      CONTINUE
          CALL res (neq, tn, y, s, rtem, ires)
          nfe = nfe + 1
          IF (ires .GT. 1) GO TO 600
          DO 215 i = 1,n
 215        rtem(i) = rtem(i) - savr(i)
          k1 = k
          DO 230 i = j1,n,mwid
C           Get Jacobian elements in column I (block-column K1). -------
            y(i) = yh(i,1)
            r = max(srur*abs(y(i)),0.01d0/ewt(i))
            fac = -hl0/r
C           Compute and load elements PA(*,J,K1). ----------------------
            iia = i - j
            ipa = 2 + (j-1)*mb + (k1-1)*mbsq
            DO 221 j2 = 1,mb
 221          wm(ipa+j2) = rtem(iia+j2)*fac
            IF (k1 .LE. 1) GO TO 223
C           Compute and load elements PB(*,J,K1-1). --------------------
            iib = iia - mb
            ipb = ipa + lblox - mbsq
            DO 222 j2 = 1,mb
 222          wm(ipb+j2) = rtem(iib+j2)*fac
 223        CONTINUE
            IF (k1 .GE. nb) GO TO 225
C           Compute and load elements PC(*,J,K1+1). --------------------
            iic = iia + mb
            ipc = ipa + 2*lblox + mbsq
            DO 224 j2 = 1,mb
 224          wm(ipc+j2) = rtem(iic+j2)*fac
 225        CONTINUE
            IF (k1 .NE. 3) GO TO 227
C           Compute and load elements PC(*,J,1). -----------------------
            ipc = ipa - 2*mbsq + 2*lblox
            DO 226 j2 = 1,mb
 226          wm(ipc+j2) = rtem(j2)*fac
 227        CONTINUE
            IF (k1 .NE. nb-2) GO TO 229
C           Compute and load elements PB(*,J,NB). ----------------------
            iib = n - mb
            ipb = ipa + 2*mbsq + lblox
            DO 228 j2 = 1,mb
 228          wm(ipb+j2) = rtem(iib+j2)*fac
 229      k1 = k1 + 3
 230      CONTINUE
 240    CONTINUE
 250  CONTINUE
C RES call for first corrector iteration. ------------------------------
      ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
C Add matrix A. --------------------------------------------------------
 260  CONTINUE
      CALL adda (neq, tn, y, mb, nb, wm(3), wm(lpb), wm(lpc))
C Do LU decomposition on P. --------------------------------------------
      CALL ddecbt (mb, nb, wm(3), wm(lpb), wm(lpc), iwm(21), ier)
      IF (ier .NE. 0) ierpj = 1
      RETURN
C Error return for IRES = 2 or IRES = 3 return from RES. ---------------
 600  ierpj = ires
      RETURN
C----------------------- End of Subroutine DPJIBT ----------------------
      END
*DECK DSLSBT
      SUBROUTINE dslsbt (WM, IWM, X, TEM)
      INTEGER iwm
      INTEGER lblox, lpb, lpc, mb, nb
      DOUBLE PRECISION wm, x, tem
      dimension wm(*), iwm(*), x(*), tem(*)
C-----------------------------------------------------------------------
C This routine acts as an interface between the core integrator
C routine and the DSOLBT routine for the solution of the linear system
C arising from chord iteration.
C Communication with DSLSBT uses the following variables:
C WM    = real work space containing the LU decomposition,
C         starting at WM(3).
C IWM   = integer work space containing pivot information, starting at
C         IWM(21).  IWM also contains block structure parameters
C         MB = IWM(1) and NB = IWM(2).
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-----------------------------------------------------------------------
      mb = iwm(1)
      nb = iwm(2)
      lblox = mb*mb*nb
      lpb = 3 + lblox
      lpc = lpb + lblox
      CALL dsolbt (mb, nb, wm(3), wm(lpb), wm(lpc), x, iwm(21))
      RETURN
C----------------------- End of Subroutine DSLSBT ----------------------
      END
*DECK DDECBT
      SUBROUTINE ddecbt (M, N, A, B, C, IP, IER)
      INTEGER m, n, ip(m,n), ier
      DOUBLE PRECISION a(m,m,n), b(m,m,n), c(m,m,n)
C-----------------------------------------------------------------------
C Block-tridiagonal matrix decomposition routine.
C Written by A. C. Hindmarsh.
C Latest revision:  November 10, 1983 (ACH)
C Reference:  UCID-30150
C             Solution of Block-Tridiagonal Systems of Linear
C             Algebraic Equations
C             A.C. Hindmarsh
C             February 1977
C The input matrix contains three blocks of elements in each block-row,
C including blocks in the (1,3) and (N,N-2) block positions.
C DDECBT uses block Gauss elimination and Subroutines DGEFA and DGESL
C for solution of blocks.  Partial pivoting is done within
C block-rows only.
C
C Note: this version uses LINPACK routines DGEFA/DGESL instead of
C of dec/sol for solution of blocks, and it uses the BLAS routine DDOT
C for dot product calculations.
C
C Input:
C     M = order of each block.
C     N = number of blocks in each direction of the matrix.
C         N must be 4 or more.  The complete matrix has order M*N.
C     A = M by M by N array containing diagonal blocks.
C         A(i,j,k) contains the (i,j) element of the k-th block.
C     B = M by M by N array containing the super-diagonal blocks
C         (in B(*,*,k) for k = 1,...,N-1) and the block in the (N,N-2)
C         block position (in B(*,*,N)).
C     C = M by M by N array containing the subdiagonal blocks
C         (in C(*,*,k) for k = 2,3,...,N) and the block in the
C         (1,3) block position (in C(*,*,1)).
C    IP = integer array of length M*N for working storage.
C Output:
C A,B,C = M by M by N arrays containing the block-LU decomposition
C         of the input matrix.
C    IP = M by N array of pivot information.  IP(*,k) contains
C         information for the k-th digonal block.
C   IER = 0  if no trouble occurred, or
C       = -1 if the input value of M or N was illegal, or
C       = k  if a singular matrix was found in the k-th diagonal block.
C Use DSOLBT to solve the associated linear system.
C
C External routines required: DGEFA and DGESL (from LINPACK) and
C DDOT (from the BLAS, or Basic Linear Algebra package).
C-----------------------------------------------------------------------
      INTEGER nm1, nm2, km1, i, j, k
      DOUBLE PRECISION dp, ddot
      IF (m .LT. 1 .OR. n .LT. 4) GO TO 210
      nm1 = n - 1
      nm2 = n - 2
C Process the first block-row. -----------------------------------------
      CALL dgefa (a, m, m, ip, ier)
      k = 1
      IF (ier .NE. 0) GO TO 200
      DO 10 j = 1,m
        CALL dgesl (a, m, m, ip, b(1,j,1), 0)
        CALL dgesl (a, m, m, ip, c(1,j,1), 0)
 10     CONTINUE
C Adjust B(*,*,2). -----------------------------------------------------
      DO 40 j = 1,m
        DO 30 i = 1,m
          dp = ddot(m, c(i,1,2), m, c(1,j,1), 1)
          b(i,j,2) = b(i,j,2) - dp
 30       CONTINUE
 40     CONTINUE
C Main loop.  Process block-rows 2 to N-1. -----------------------------
      DO 100 k = 2,nm1
        km1 = k - 1
        DO 70 j = 1,m
          DO 60 i = 1,m
            dp = ddot(m, c(i,1,k), m, b(1,j,km1), 1)
            a(i,j,k) = a(i,j,k) - dp
 60         CONTINUE
 70       CONTINUE
        CALL dgefa (a(1,1,k), m, m, ip(1,k), ier)
        IF (ier .NE. 0) GO TO 200
        DO 80 j = 1,m
 80       CALL dgesl (a(1,1,k), m, m, ip(1,k), b(1,j,k), 0)
 100    CONTINUE
C Process last block-row and return. -----------------------------------
      DO 130 j = 1,m
        DO 120 i = 1,m
          dp = ddot(m, b(i,1,n), m, b(1,j,nm2), 1)
          c(i,j,n) = c(i,j,n) - dp
 120      CONTINUE
 130    CONTINUE
      DO 160 j = 1,m
        DO 150 i = 1,m
          dp = ddot(m, c(i,1,n), m, b(1,j,nm1), 1)
          a(i,j,n) = a(i,j,n) - dp
 150      CONTINUE
 160    CONTINUE
      CALL dgefa (a(1,1,n), m, m, ip(1,n), ier)
      k = n
      IF (ier .NE. 0) GO TO 200
      RETURN
C Error returns. -------------------------------------------------------
 200  ier = k
      RETURN
 210  ier = -1
      RETURN
C----------------------- End of Subroutine DDECBT ----------------------
      END
*DECK DSOLBT
      SUBROUTINE dsolbt (M, N, A, B, C, Y, IP)
      INTEGER m, n, ip(m,n)
      DOUBLE PRECISION a(m,m,n), b(m,m,n), c(m,m,n), y(m,n)
C-----------------------------------------------------------------------
C Solution of block-tridiagonal linear system.
C Coefficient matrix must have been previously processed by DDECBT.
C M, N, A,B,C, and IP  must not have been changed since call to DDECBT.
C Written by A. C. Hindmarsh.
C Input:
C     M = order of each block.
C     N = number of blocks in each direction of matrix.
C A,B,C = M by M by N arrays containing block LU decomposition
C         of coefficient matrix from DDECBT.
C    IP = M by N integer array of pivot information from DDECBT.
C     Y = array of length M*N containg the right-hand side vector
C         (treated as an M by N array here).
C Output:
C     Y = solution vector, of length M*N.
C
C External routines required: DGESL (LINPACK) and DDOT (BLAS).
C-----------------------------------------------------------------------
C
      INTEGER nm1, nm2, i, k, kb, km1, kp1
      DOUBLE PRECISION dp, ddot
      nm1 = n - 1
      nm2 = n - 2
C Forward solution sweep. ----------------------------------------------
      CALL dgesl (a, m, m, ip, y, 0)
      DO 30 k = 2,nm1
        km1 = k - 1
        DO 20 i = 1,m
          dp = ddot(m, c(i,1,k), m, y(1,km1), 1)
          y(i,k) = y(i,k) - dp
 20       CONTINUE
        CALL dgesl (a(1,1,k), m, m, ip(1,k), y(1,k), 0)
 30     CONTINUE
      DO 50 i = 1,m
        dp = ddot(m, c(i,1,n), m, y(1,nm1), 1)
     1     + ddot(m, b(i,1,n), m, y(1,nm2), 1)
        y(i,n) = y(i,n) - dp
 50     CONTINUE
      CALL dgesl (a(1,1,n), m, m, ip(1,n), y(1,n), 0)
C Backward solution sweep. ---------------------------------------------
      DO 80 kb = 1,nm1
        k = n - kb
        kp1 = k + 1
        DO 70 i = 1,m
          dp = ddot(m, b(i,1,k), m, y(1,kp1), 1)
          y(i,k) = y(i,k) - dp
 70       CONTINUE
 80     CONTINUE
      DO 100 i = 1,m
        dp = ddot(m, c(i,1,1), m, y(1,3), 1)
        y(i,1) = y(i,1) - dp
 100    CONTINUE
      RETURN
C----------------------- End of Subroutine DSOLBT ----------------------
      END
*DECK DIPREPI
      SUBROUTINE diprepi (NEQ, Y, S, RWORK, IA, JA, IC, JC, IPFLAG,
     1   RES, JAC, ADDA)
      EXTERNAL res, jac, adda
      INTEGER neq, ia, ja, ic, jc, ipflag
      DOUBLE PRECISION y, s, rwork
      dimension neq(*), y(*), s(*), rwork(*), ia(*), ja(*), ic(*), jc(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rlss
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ 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
      INTEGER i, imax, lewtn, lyhd, lyhn
C-----------------------------------------------------------------------
C This routine serves as an interface between the driver and
C Subroutine DPREPI.  Tasks performed here are:
C  * call DPREPI,
C  * reset the required WM segment length LENWK,
C  * move YH back to its final location (following WM in RWORK),
C  * reset pointers for YH, SAVR, EWT, and ACOR, and
C  * move EWT to its new position if ISTATE = 0 or 1.
C IPFLAG is an output error indication flag.  IPFLAG = 0 if there was
C no trouble, and IPFLAG is the value of the DPREPI error flag IPPER
C if there was trouble in Subroutine DPREPI.
C-----------------------------------------------------------------------
      ipflag = 0
C Call DPREPI to do matrix preprocessing operations. -------------------
      CALL dprepi (neq, y, s, rwork(lyh), rwork(lsavf), rwork(lewt),
     1   rwork(lacor), ia, ja, ic, jc, rwork(lwm), rwork(lwm), ipflag,
     2   res, jac, adda)
      lenwk = max(lreq,lwmin)
      IF (ipflag .LT. 0) RETURN
C If DPREPI was successful, move YH to end of required space for WM. ---
      lyhn = lwm + lenwk
      IF (lyhn .GT. lyh) RETURN
      lyhd = lyh - lyhn
      IF (lyhd .EQ. 0) GO TO 20
      imax = lyhn - 1 + lenyhm
      DO 10 i=lyhn,imax
 10     rwork(i) = rwork(i+lyhd)
      lyh = lyhn
C Reset pointers for SAVR, EWT, and ACOR. ------------------------------
 20   lsavf = lyh + lenyh
      lewtn = lsavf + n
      lacor = lewtn + n
      IF (istatc .EQ. 3) GO TO 40
C If ISTATE = 1, move EWT (left) to its new position. ------------------
      IF (lewtn .GT. lewt) RETURN
      DO 30 i=1,n
 30     rwork(i+lewtn-1) = rwork(i+lewt-1)
 40   lewt = lewtn
      RETURN
C----------------------- End of Subroutine DIPREPI ---------------------
      END
*DECK DPREPI
      SUBROUTINE dprepi (NEQ, Y, S, YH, SAVR, EWT, RTEM, IA, JA, IC, JC,
     1                   WK, IWK, IPPER, RES, JAC, ADDA)
      EXTERNAL res, jac, adda
      INTEGER neq, ia, ja, ic, jc, iwk, ipper
      DOUBLE PRECISION y, s, yh, savr, ewt, rtem, wk
      dimension neq(*), y(*), s(*), yh(*), savr(*), ewt(*), rtem(*),
     1   ia(*), ja(*), ic(*), jc(*), wk(*), iwk(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rlss
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ 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
      INTEGER i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, k, knew, kamax,
     1   kamin, kcmax, kcmin, ldif, lenigp, lenwk1, liwk, ljfo, maxg,
     2   np1, nzsut
      DOUBLE PRECISION erwt, fac, yj
C-----------------------------------------------------------------------
C This routine performs preprocessing related to the sparse linear
C systems that must be solved.
C The operations that are performed here are:
C  * compute sparseness structure of the iteration matrix
C      P = A - con*J  according to MOSS,
C  * compute grouping of column indices (MITER = 2),
C  * compute a new ordering of rows and columns of the matrix,
C  * reorder JA corresponding to the new ordering,
C  * perform a symbolic LU factorization of the matrix, and
C  * set pointers for segments of the IWK/WK array.
C In addition to variables described previously, DPREPI uses the
C following for communication:
C YH     = the history array.  Only the first column, containing the
C          current Y vector, is used.  Used only if MOSS .ne. 0.
C S      = array of length NEQ, identical to YDOTI in the driver, used
C          only if MOSS .ne. 0.
C SAVR   = a work array of length NEQ, used only if MOSS .ne. 0.
C EWT    = array of length NEQ containing (inverted) error weights.
C          Used only if MOSS = 2 or 4 or if ISTATE = MOSS = 1.
C RTEM   = a work array of length NEQ, identical to ACOR in the driver,
C          used only if MOSS = 2 or 4.
C WK     = a real work array of length LENWK, identical to WM in
C          the driver.
C IWK    = integer work array, assumed to occupy the same space as WK.
C LENWK  = the length of the work arrays WK and IWK.
C ISTATC = a copy of the driver input argument ISTATE (= 1 on the
C          first call, = 3 on a continuation call).
C IYS    = flag value from ODRV or CDRV.
C IPPER  = output error flag , with the following values and meanings:
C        =   0  no error.
C        =  -1  insufficient storage for internal structure pointers.
C        =  -2  insufficient storage for JGROUP.
C        =  -3  insufficient storage for ODRV.
C        =  -4  other error flag from ODRV (should never occur).
C        =  -5  insufficient storage for CDRV.
C        =  -6  other error flag from CDRV.
C        =  -7  if the RES routine returned error flag IRES = IER = 2.
C        =  -8  if the RES routine returned error flag IRES = IER = 3.
C-----------------------------------------------------------------------
      ibian = lrat*2
      ipian = ibian + 1
      np1 = n + 1
      ipjan = ipian + np1
      ibjan = ipjan - 1
      lenwk1 = lenwk - n
      liwk = lenwk*lrat
      IF (moss .EQ. 0) liwk = liwk - n
      IF (moss .EQ. 1 .OR. moss .EQ. 2) liwk = lenwk1*lrat
      IF (ipjan+n-1 .GT. liwk) GO TO 310
      IF (moss .EQ. 0) GO TO 30
C
      IF (istatc .EQ. 3) GO TO 20
C ISTATE = 1 and MOSS .ne. 0.  Perturb Y for structure determination.
C Initialize S with random nonzero elements for structure determination.
      DO 10 i=1,n
        erwt = 1.0d0/ewt(i)
        fac = 1.0d0 + 1.0d0/(i + 1.0d0)
        y(i) = y(i) + fac*sign(erwt,y(i))
        s(i) = 1.0d0 + fac*erwt
 10     CONTINUE
      GO TO (70, 100, 150, 200), moss
C
 20   CONTINUE
C ISTATE = 3 and MOSS .ne. 0. Load Y from YH(*,1) and S from YH(*,2). --
      DO 25 i = 1,n
         y(i) = yh(i)
 25      s(i) = yh(n+i)
      GO TO (70, 100, 150, 200), moss
C
C MOSS = 0. Process user's IA,JA and IC,JC. ----------------------------
 30   knew = ipjan
      kamin = ia(1)
      kcmin = ic(1)
      iwk(ipian) = 1
      DO 60 j = 1,n
        DO 35 i = 1,n
 35       iwk(liwk+i) = 0
        kamax = ia(j+1) - 1
        IF (kamin .GT. kamax) GO TO 45
        DO 40 k = kamin,kamax
          i = ja(k)
          iwk(liwk+i) = 1
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 40       CONTINUE
 45     kamin = kamax + 1
        kcmax = ic(j+1) - 1
        IF (kcmin .GT. kcmax) GO TO 55
        DO 50 k = kcmin,kcmax
          i = jc(k)
          IF (iwk(liwk+i) .NE. 0) GO TO 50
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 50       CONTINUE
 55     iwk(ipian+j) = knew + 1 - ipjan
        kcmin = kcmax + 1
 60     CONTINUE
      GO TO 240
C
C MOSS = 1. Compute structure from user-supplied Jacobian routine JAC. -
 70   CONTINUE
C A dummy call to RES allows user to create temporaries for use in JAC.
      ier = 1
      CALL res (neq, tn, y, s, savr, ier)
      IF (ier .GT. 1) GO TO 370
      DO 75 i = 1,n
        savr(i) = 0.0d0
 75     wk(lenwk1+i) = 0.0d0
      k = ipjan
      iwk(ipian) = 1
      DO 95 j = 1,n
        CALL adda (neq, tn, y, j, iwk(ipian), iwk(ipjan), wk(lenwk1+1))
        CALL jac (neq, tn, y, s, j, iwk(ipian), iwk(ipjan), savr)
        DO 90 i = 1,n
          ljfo = lenwk1 + i
          IF (wk(ljfo) .EQ. 0.0d0) GO TO 80
          wk(ljfo) = 0.0d0
          savr(i) = 0.0d0
          GO TO 85
 80       IF (savr(i) .EQ. 0.0d0) GO TO 90
          savr(i) = 0.0d0
 85       IF (k .GT. liwk) GO TO 310
          iwk(k) = i
          k = k+1
 90       CONTINUE
        iwk(ipian+j) = k + 1 - ipjan
 95     CONTINUE
      GO TO 240
C
C MOSS = 2. Compute structure from results of N + 1 calls to RES. ------
 100  DO 105 i = 1,n
 105    wk(lenwk1+i) = 0.0d0
      k = ipjan
      iwk(ipian) = 1
      ier = -1
      IF (miter .EQ. 1) ier = 1
      CALL res (neq, tn, y, s, savr, ier)
      IF (ier .GT. 1) GO TO 370
      DO 130 j = 1,n
        CALL adda (neq, tn, y, j, iwk(ipian), iwk(ipjan), wk(lenwk1+1))
        yj = y(j)
        erwt = 1.0d0/ewt(j)
        y(j) = yj + sign(erwt,yj)
        CALL res (neq, tn, y, s, rtem, ier)
        IF (ier .GT. 1) RETURN
        y(j) = yj
        DO 120 i = 1,n
          ljfo = lenwk1 + i
          IF (wk(ljfo) .EQ. 0.0d0) GO TO 110
          wk(ljfo) = 0.0d0
          GO TO 115
 110      IF (rtem(i) .EQ. savr(i)) GO TO 120
 115      IF (k .GT. liwk) GO TO 310
          iwk(k) = i
          k = k + 1
 120      CONTINUE
        iwk(ipian+j) = k + 1 - ipjan
 130    CONTINUE
      GO TO 240
C
C MOSS = 3. Compute structure from the user's IA/JA and JAC routine. ---
 150  CONTINUE
C A dummy call to RES allows user to create temporaries for use in JAC.
      ier = 1
      CALL res (neq, tn, y, s, savr, ier)
      IF (ier .GT. 1) GO TO 370
      DO 155 i = 1,n
 155    savr(i) = 0.0d0
      knew = ipjan
      kamin = ia(1)
      iwk(ipian) = 1
      DO 190 j = 1,n
        CALL jac (neq, tn, y, s, j, iwk(ipian), iwk(ipjan), savr)
        kamax = ia(j+1) - 1
        IF (kamin .GT. kamax) GO TO 170
        DO 160 k = kamin,kamax
          i = ja(k)
          savr(i) = 0.0d0
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 160      CONTINUE
 170    kamin = kamax + 1
        DO 180 i = 1,n
          IF (savr(i) .EQ. 0.0d0) GO TO 180
          savr(i) = 0.0d0
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 180      CONTINUE
        iwk(ipian+j) = knew + 1 - ipjan
 190    CONTINUE
      GO TO 240
C
C MOSS = 4. Compute structure from user's IA/JA and N + 1 RES calls. ---
 200  knew = ipjan
      kamin = ia(1)
      iwk(ipian) = 1
      ier = -1
      IF (miter .EQ. 1) ier = 1
      CALL res (neq, tn, y, s, savr, ier)
      IF (ier .GT. 1) GO TO 370
      DO 235 j = 1,n
        yj = y(j)
        erwt = 1.0d0/ewt(j)
        y(j) = yj + sign(erwt,yj)
        CALL res (neq, tn, y, s, rtem, ier)
        IF (ier .GT. 1) RETURN
        y(j) = yj
        kamax = ia(j+1) - 1
        IF (kamin .GT. kamax) GO TO 225
        DO 220 k = kamin,kamax
          i = ja(k)
          rtem(i) = savr(i)
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 220      CONTINUE
 225    kamin = kamax + 1
        DO 230 i = 1,n
          IF (rtem(i) .EQ. savr(i)) GO TO 230
          IF (knew .GT. liwk) GO TO 310
          iwk(knew) = i
          knew = knew + 1
 230      CONTINUE
        iwk(ipian+j) = knew + 1 - ipjan
 235    CONTINUE
C
 240  CONTINUE
      IF (moss .EQ. 0 .OR. istatc .EQ. 3) GO TO 250
C If ISTATE = 0 or 1 and MOSS .ne. 0, restore Y from YH. ---------------
      DO 245 i = 1,n
 245    y(i) = yh(i)
 250  nnz = iwk(ipian+n) - 1
      ipper = 0
      ngp = 0
      lenigp = 0
      ipigp = ipjan + nnz
      IF (miter .NE. 2) GO TO 260
C
C Compute grouping of column indices (MITER = 2). ----------------------
C
      maxg = np1
      ipjgp = ipjan + nnz
      ibjgp = ipjgp - 1
      ipigp = ipjgp + n
      iptt1 = ipigp + np1
      iptt2 = iptt1 + n
      lreq = iptt2 + n - 1
      IF (lreq .GT. liwk) GO TO 320
      CALL jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp),
     1   iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier)
      IF (ier .NE. 0) GO TO 320
      lenigp = ngp + 1
C
C Compute new ordering of rows/columns of Jacobian. --------------------
 260  ipr = ipigp + lenigp
      ipc = ipr
      ipic = ipc + n
      ipisp = ipic + n
      iprsp = (ipisp-2)/lrat + 2
      iesp = lenwk + 1 - iprsp
      IF (iesp .LT. 0) GO TO 330
      ibr = ipr - 1
      DO 270 i = 1,n
 270    iwk(ibr+i) = i
      nsp = liwk + 1 - ipisp
      CALL odrv(n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic), nsp,
     1   iwk(ipisp), 1, iys)
      IF (iys .EQ. 11*n+1) GO TO 340
      IF (iys .NE. 0) GO TO 330
C
C Reorder JAN and do symbolic LU factorization of matrix. --------------
      ipa = lenwk + 1 - nnz
      nsp = ipa - iprsp
      lreq = max(12*n/lrat, 6*n/lrat+2*n+nnz) + 3
      lreq = lreq + iprsp - 1 + nnz
      IF (lreq .GT. lenwk) GO TO 350
      iba = ipa - 1
      DO 280 i = 1,nnz
 280    wk(iba+i) = 0.0d0
      ipisp = lrat*(iprsp - 1) + 1
      CALL cdrv(n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys)
      lreq = lenwk - iesp
      IF (iys .EQ. 10*n+1) GO TO 350
      IF (iys .NE. 0) GO TO 360
      ipil = ipisp
      ipiu = ipil + 2*n + 1
      nzu = iwk(ipil+n) - iwk(ipil)
      nzl = iwk(ipiu+n) - iwk(ipiu)
      IF (lrat .GT. 1) GO TO 290
      CALL adjlr (n, iwk(ipisp), ldif)
      lreq = lreq + ldif
 290  CONTINUE
      IF (lrat .EQ. 2 .AND. nnz .EQ. n) lreq = lreq + 1
      nsp = nsp + lreq - lenwk
      ipa = lreq + 1 - nnz
      iba = ipa - 1
      ipper = 0
      RETURN
C
 310  ipper = -1
      lreq = 2 + (2*n + 1)/lrat
      lreq = max(lenwk+1,lreq)
      RETURN
C
 320  ipper = -2
      lreq = (lreq - 1)/lrat + 1
      RETURN
C
 330  ipper = -3
      CALL cntnzu (n, iwk(ipian), iwk(ipjan), nzsut)
      lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1
      RETURN
C
 340  ipper = -4
      RETURN
C
 350  ipper =  -5
      RETURN
C
 360  ipper = -6
      lreq = lenwk
      RETURN
C
 370  ipper = -ier - 5
      lreq = 2 + (2*n + 1)/lrat
      RETURN
C----------------------- End of Subroutine DPREPI ----------------------
      END
*DECK DAINVGS
      SUBROUTINE dainvgs (NEQ, T, Y, WK, IWK, TEM, YDOT, IER, RES, ADDA)
      EXTERNAL res, adda
      INTEGER neq, iwk, ier
      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, imul, j, k, kmin, kmax
      DOUBLE PRECISION t, y, wk, tem, ydot
      DOUBLE PRECISION rlss
      dimension y(*), wk(*), iwk(*), tem(*), ydot(*)
      COMMON /dlss01/ 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 subroutine computes the initial value of the vector YDOT
C satisfying
C     A * YDOT = g(t,y)
C when A is nonsingular.  It is called by DLSODIS for initialization
C only, when ISTATE = 0.  The matrix A is subjected to LU
C decomposition in CDRV.  Then the system A*YDOT = g(t,y) is solved
C in CDRV.
C In addition to variables described previously, communication
C with DAINVGS uses the following:
C Y     = array of initial values.
C WK    = real work space for matrices.  On output it contains A and
C         its LU decomposition.  The LU decomposition is not entirely
C         sparse unless the structure of the matrix A is identical to
C         the structure of the Jacobian matrix dr/dy.
C         Storage of matrix elements starts at WK(3).
C         WK(1) = SQRT(UROUND), not used here.
C IWK   = integer work space for matrix-related data, assumed to
C         be equivalenced to WK.  In addition, WK(IPRSP) and WK(IPISP)
C         are assumed to have identical locations.
C TEM   = vector of work space of length N (ACOR in DSTODI).
C YDOT  = output vector containing the initial dy/dt. YDOT(i) contains
C         dy(i)/dt when the matrix A is non-singular.
C IER   = output error flag with the following values and meanings:
C       = 0  if DAINVGS was successful.
C       = 1  if the A-matrix was found to be singular.
C       = 2  if RES returned an error flag IRES = IER = 2.
C       = 3  if RES returned an error flag IRES = IER = 3.
C       = 4  if insufficient storage for CDRV (should not occur here).
C       = 5  if other error found in CDRV (should not occur here).
C-----------------------------------------------------------------------
C
      DO 10 i = 1,nnz
 10     wk(iba+i) = 0.0d0
C
      ier = 1
      CALL res (neq, t, y, wk(ipa), ydot, ier)
      IF (ier .GT. 1) RETURN
C
      kmin = iwk(ipian)
      DO 30 j = 1,neq
        kmax = iwk(ipian+j) - 1
        DO 15 k = kmin,kmax
          i = iwk(ibjan+k)
 15       tem(i) = 0.0d0
        CALL adda (neq, t, y, j, iwk(ipian), iwk(ipjan), tem)
        DO 20 k = kmin,kmax
          i = iwk(ibjan+k)
 20       wk(iba+k) = tem(i)
        kmin = kmax + 1
 30   CONTINUE
      nlu = nlu + 1
      ier = 0
      DO 40 i = 1,neq
 40     tem(i) = 0.0d0
C
C Numerical factorization of matrix A. ---------------------------------
      CALL cdrv (neq,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1  wk(ipa),tem,tem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys)
      IF (iys .EQ. 0) GO TO 50
      imul = (iys - 1)/neq
      ier = 5
      IF (imul .EQ. 8) ier = 1
      IF (imul .EQ. 10) ier = 4
      RETURN
C
C Solution of the linear system. ---------------------------------------
 50   CALL cdrv (neq,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1  wk(ipa),ydot,ydot,nsp,iwk(ipisp),wk(iprsp),iesp,4,iys)
      IF (iys .NE. 0) ier = 5
      RETURN
C----------------------- End of Subroutine DAINVGS ---------------------
      END
*DECK DPRJIS
      SUBROUTINE dprjis (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WK, IWK,
     1   RES, JAC, ADDA)
      EXTERNAL res, jac, adda
      INTEGER neq, nyh, iwk
      DOUBLE PRECISION y, yh, ewt, rtem, savr, s, wk
      dimension neq(*), y(*), yh(nyh,*), ewt(*), rtem(*),
     1   s(*), savr(*), wk(*), iwk(*)
      INTEGER iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l,
     2   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     3   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
      DOUBLE PRECISION rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      DOUBLE PRECISION rlss
      COMMON /dls001/ rowns(209),
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     2   iownd(6), iowns(6),
     3   icf, ierpj, iersl, jcur, jstart, kflag, l,
     4   lyh, lewt, lacor, lsavf, lwm, liwm, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      COMMON /dlss01/ 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
      INTEGER i, imul, ires, j, jj, jmax, jmin, k, kmax, kmin, ng
      DOUBLE PRECISION con, fac, hl0, r, srur
C-----------------------------------------------------------------------
C DPRJIS is called to compute and process the matrix
C P = A - H*EL(1)*J, where J is an approximation to the Jacobian dr/dy,
C where r = g(t,y) - A(t,y)*s.  J is computed by columns, either by
C the user-supplied routine JAC if MITER = 1, or by finite differencing
C if MITER = 2.  J is stored in WK, rescaled, and ADDA is called to
C generate P.  The matrix P is subjected to LU decomposition in CDRV.
C P and its LU decomposition are stored separately in WK.
C
C In addition to variables described previously, communication
C with DPRJIS uses the following:
C Y     = array containing predicted values on entry.
C RTEM  = work array of length N (ACOR in DSTODI).
C SAVR  = array containing r evaluated at predicted y. On output it
C         contains the residual evaluated at current values of t and y.
C S     = array containing predicted values of dy/dt (SAVF in DSTODI).
C WK    = real work space for matrices.  On output it contains P and
C         its sparse LU decomposition.  Storage of matrix elements
C         starts at WK(3).
C         WK also contains the following matrix-related data.
C         WK(1) = SQRT(UROUND), used in numerical Jacobian increments.
C IWK   = integer work space for matrix-related data, assumed to be
C         equivalenced to WK.  In addition,  WK(IPRSP) and IWK(IPISP)
C         are assumed to have identical locations.
C EL0   = EL(1) (input).
C IERPJ = output error flag (in COMMON).
C         =  0 if no error.
C         =  1 if zero pivot found in CDRV.
C         = IRES (= 2 or 3) if RES returned IRES = 2 or 3.
C         = -1 if insufficient storage for CDRV (should not occur).
C         = -2 if other error found in CDRV (should not occur here).
C JCUR  = output flag = 1 to indicate that the Jacobian matrix
C         (or approximation) is now current.
C This routine also uses other variables in Common.
C-----------------------------------------------------------------------
      hl0 = h*el0
      con = -hl0
      jcur = 1
      nje = nje + 1
      GO TO (100, 200), miter
C
C If MITER = 1, call RES, then call JAC and ADDA for each column. ------
 100  ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      kmin = iwk(ipian)
      DO 130 j = 1,n
        kmax = iwk(ipian+j)-1
        DO 110 i = 1,n
 110      rtem(i) = 0.0d0
        CALL jac (neq, tn, y, s, j, iwk(ipian), iwk(ipjan), rtem)
        DO 120 i = 1,n
 120      rtem(i) = rtem(i)*con
        CALL adda (neq, tn, y, j, iwk(ipian), iwk(ipjan), rtem)
        DO 125 k = kmin,kmax
          i = iwk(ibjan+k)
          wk(iba+k) = rtem(i)
 125      CONTINUE
        kmin = kmax + 1
 130    CONTINUE
      GO TO 290
C
C If MITER = 2, make NGP + 1 calls to RES to approximate J and P. ------
 200  CONTINUE
      ires = -1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
      srur = wk(1)
      jmin = iwk(ipigp)
      DO 240 ng = 1,ngp
        jmax = iwk(ipigp+ng) - 1
        DO 210 j = jmin,jmax
          jj = iwk(ibjgp+j)
          r = max(srur*abs(y(jj)),0.01d0/ewt(jj))
 210      y(jj) = y(jj) + r
        CALL res (neq,tn,y,s,rtem,ires)
        nfe = nfe + 1
        IF (ires .GT. 1) GO TO 600
        DO 230 j = jmin,jmax
          jj = iwk(ibjgp+j)
          y(jj) = yh(jj,1)
          r = max(srur*abs(y(jj)),0.01d0/ewt(jj))
          fac = -hl0/r
          kmin = iwk(ibian+jj)
          kmax = iwk(ibian+jj+1) - 1
          DO 220 k = kmin,kmax
            i = iwk(ibjan+k)
            rtem(i) = (rtem(i) - savr(i))*fac
 220        CONTINUE
        CALL adda (neq, tn, y, jj, iwk(ipian), iwk(ipjan), rtem)
        DO 225 k = kmin,kmax
          i = iwk(ibjan+k)
          wk(iba+k) = rtem(i)
 225      CONTINUE
 230      CONTINUE
        jmin = jmax + 1
 240    CONTINUE
      ires = 1
      CALL res (neq, tn, y, s, savr, ires)
      nfe = nfe + 1
      IF (ires .GT. 1) GO TO 600
C
C Do numerical factorization of P matrix. ------------------------------
 290  nlu = nlu + 1
      ierpj = 0
      DO 295 i = 1,n
 295    rtem(i) = 0.0d0
      CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1  wk(ipa),rtem,rtem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys)
      IF (iys .EQ. 0) RETURN
      imul = (iys - 1)/n
      ierpj = -2
      IF (imul .EQ. 8) ierpj = 1
      IF (imul .EQ. 10) ierpj = -1
      RETURN
C Error return for IRES = 2 or IRES = 3 return from RES. ---------------
 600  ierpj = ires
      RETURN
C----------------------- End of Subroutine DPRJIS ----------------------
      END