      program RysQuad
      implicit real*8(a-h,o-z)
c
      parameter (mxquad=25)
      dimension rts(mxquad),wts(mxquad),wrk(mxquad),
     *          alpha(0:mxquad-1),beta(0:mxquad-1),
     *          xasymp(mxquad)
c
      parameter (mxaux=100)
      dimension rtsaux(mxaux),wtsaux(mxaux),
     *          alpaux(0:mxaux),betaux(0:mxaux),
     *          p0(mxaux),p1(mxaux),p2(mxaux),
     *          rgrid(mxaux),wgrid(mxaux),nauxs(mxaux)
c
      character*10 type,code,auxqd
      logical RPprt
c
c         Rys' RMS agreement between asymptotic code and Gautschi code
c         goes below 1d-13 for both roots and weights above these, as
c         it seems Ishida-san was a bit too conservative about this.
c
      data (xasymp(I),I=1,13)/
     *    29.0d+00,  37.0d+00,  43.0d+00,  49.0d+00,  55.0d+00,
     *    60.0d+00,  65.0d+00,  71.0d+00,  76.0d+00,  81.0d+00,
     *    86.0d+00,  91.0d+00,  96.0d+00/
c
c         Rys auxiliary grid size determined at the xasymp values,
c         eyeballing against using a naux=80 "converged" grid size.
c         It is likely that at lower X values, a smaller auxiliary
c         quadrature would be adequate.
c
      data (nauxs(I),I=1,13)/
     *    20,25,30,30,35,  40,40,40,45,50,  50,55,55/
c
c     Program to develop Gaussian quadrature roots and weights
c       assembled/written by Mike Schmidt in November 2005.
c
c     User can select the type of quadrature here, the choices are
c       Hermite, Laguerre, Legendre, or Rys
c
      type = 'Rys'
c
c     ================================================================
c     for the theory of Orthogonal Polynomials, see the following:
c
c             "Calculation of Gauss Quadrature Rules"
c                 Gene H. Golub, John H. Welsch
c           Mathematics of Computation, 23, 221-230(1969)
c
c     "Algorithm 726: ORTHPOL - A Package of Routines for Generating
c         Orthogonal Polynomials and Gauss-Type Quadrature Rules"
c                         Walter Gautschi
c       ACM Transactions on Mathematical Software  20, 21-62(1994)
c
c         Orthogonal Polynomials: Computation and Approximation
c            W.Gautschi, Oxford University Press, Oxford 2004
c              see Theorem 1.31 and Table 1.1 in this book.
c
c     The orthogonal polynomial family is defined on an interval [a,b]
c     with respect to a weight function, w(t),
c         integral p (t) * p (t) * w(t) = delta(i,j) == <p |p >
c           a->b    i       j                             i  j
c     The inner product notation <|> implies the use of the weight
c     function (metric) in the integration.  Any such family will
c     obey the same recursion formula, namely,
c        p   (t) = (t-a )p (t) - b p   (t)      k=0,1,2,...
c         k+1          k  k       k k-1
c     where a and b are called alpha,beta in this program, and are
c                <t*p |p >               <p |p >
c                    k  k                  k  k
c           a  = -----------      b  = -----------
c            k    <p |p >          k   <p   |p   >
c                   k  k                 k-1  k-1
c     We must define the first two members in each family as
c        p  (t) = 0    p (t) = 1
c         -1            0
c     and state that k >= 0 in the a-k formula, while k >=1 in the b-k
c     formula.  Then, stating that b-0 = <p-0|p-0>, e.g. the integral
c     of the weight function only, completes the definition of the
c     orthogonal polynomial.
c
c     Thus, forming alpha,beta recurrence coefficients is tantamount
c     to forming the orthogonal polynomial.  Furthermore, use of the
c     Golub-Walsh library routine 'gauss' will give the roots as the
c     eigenvalues of a tridiagonal matrix (alpha=diagonal, beta=next
c     to diag), and the weights are the first element of each vector.
c     ================================================================
c
      if(type.eq.'Rys') then
         write(6,900)
         read(5,*) NROOTS,XX
      else
         write(6,910) type
         read(5,*) NROOTS
      end if
      if(NROOTS.gt.mxquad) stop 'fix maximum quadrature dimension'
c
      PI=3.14159265358979323846264338327950288419716939937510D+00
      zero= 0.0D+00
      one = 1.0D+00
      two = 2.0D+00
      four= 4.0D+00
c          epsilon is a relative error tolerance in the QL routine
      eps = 1.0D-14
c
      if(type.eq.'Rys') then
         do i=14,mxquad
            xasymp(i) = 1.0d+05
            nauxs(i) = mxaux
         enddo
      end if
c
c        Gauss-Hermite quadrature
c        interval (-inf,+inf)    weight exp(-t*t)
c
      if(type.eq.'Hermite') then
         do i=0,NROOTS-1
            alpha(i) = zero
         enddo
         beta(0)=sqrt(pi)
         do i=1,NROOTS-1
            beta(i) = i/two
         end do
         call gauss(NROOTS,alpha,beta,eps,rts,wts,ierr,wrk)
      end if
c
c        Gauss-Laguerre quadrature
c        interval [0,+inf)       weight exp(-t)
c
      if(type.eq.'Laguerre') then
         do i=0,NROOTS-1
            alpha(i) = two*i + one
         enddo
         beta(0)= one
         do i=1,NROOTS-1
            beta(i) = i*i
         end do
         call gauss(NROOTS,alpha,beta,eps,rts,wts,ierr,wrk)
      end if
c
c        Gauss-Legendre quadrature
c        interval [-1,+1]        weight unity
c
      if(type.eq.'Legendre') then
         do i=0,NROOTS-1
            alpha(i) = zero
         enddo
         beta(0)= two
         do i=1,NROOTS-1
            beta(i) = one/(four-(one/(i*i)))
         end do
         call gauss(NROOTS,alpha,beta,eps,rts,wts,ierr,wrk)
      end if
c
c        Gauss-Rys quadrature
c        interval [0,+1]         weight exp(-XX*t*t)
c        Introduced by John Rys, Michel Dupuis, Harry King in 1976,
c        to evaluate Cartesian Gaussian integrals in quantum chemistry:
c           M.Dupuis, J.Rys, H.F.King  J.Chem.Phys. 65, 111-116(1976)
c           J.Rys, M.Dupuis, H.F.King  J.Comput.Chem. 4, 154-157(1983)
c        The numerical parameter XX appearing in the weight function
c        depends on the distance between basis function centers, and
c        the exponents in the four Gaussians, 0 <= XX < infinite.
c
c        Rys polynomial computation was first discussed by
c          1. H.F.King, M.Dupuis  J.Comput.Phys. 21, 144-165(1976)
c        Other papers about the computation of Rys polynomials:
c          2. J.D.Augspurger, D.E.Bernholdt, C.E.Dykstra
c                J.Comput.Chem. 11, 972-977(1990)
c          3. K.Ishida  J.Chem.Phys. 95, 5198-5205(1991)
c                       J.Chem.Phys. 98, 2176-2181(1993)
c          4. R.B.Sagar, V.H.Smith Int.J.Quantum Chem. 42, 827-836(1992)
c          5. R.C.Y.Chin  J.Comput.Phys. 99, 321-336(1992)
c          6. P.Carsky, M.Polasek  J.Comput.Phys. 143, 266-277(1998)
c          7. B.I.Schneider, N.Nygaard J.Phys.Chem.A 106, 10773-6(2002)
c        of which, Sagar and Smith's is particularly illuminating.
c
c        It is known from paper 1 that in the large XX limit, the
c        Rys polynomial approaches a scaled Hermite polynomial.
c        See the 2nd paper by Ishida for more information on the
c        large XX limit.
c        The limit XX=0 is manifestly the shifted Legendre case.
c
c        The approach here is to provide a number of different
c        implementations, allowing convenient testing of their
c        speed and numerical accuracy.
c
c        Sample numerical results can be found in references
c        1, 4, and 7, for NROOTS=5, 13, and 20.  Pictures in 1.
c
c        Using the Golub-Walsh procedure to obtain the roots and
c        weights, from recurrence coefficients -alpha- and -beta-
c        that are generated by the so-called "bootstrap method",
c        using a Stieltjes discretization of the Rys polynomial on
c        an auxiliary grid, is considered the "correct answer":
c                     code=Gautschi.
c
      if(type.eq.'Rys') then
c
c        Choose code from: Dupuis, Sierra, Schmidt, or Gautschi.
c            The last two can print the Rys polynomial, see RPprt.
c            The last two codes need an auxiliary quadrature on
c               our interval [0,1], select from: Fejer or ShiftLeg.
c            The first two codes are dimension limited to NROOTS=13.
c
         code='Gautschi'
         RPprt=.false.
c
         call rysset
         call setRaiz128
         call setPeso128
c
         if(XX.ge.xasymp(NROOTS)) then
            code='Asymptotic'
            call rysasy(NROOTS,XX,rts,wts)
         end if
c
c            For the standard test case, namely NROOTS=13 and XX=10.0,
c            ShiftLeg is much more accurate than Fejer around naux=25,
c            and converges to 14 significant digits about naux=30.
c            Fejer converges to 14 figures only near naux=60 or so.
c            The auxiliary grid must be denser for larger XX, and the
c            values stored in -nauxs- were determined at the XX for
c            which we are able to shift to the asymptotic code.
c            These are therefore overly accurate for smaller XX!
c
         if(code.eq.'Schmidt'  .or.  code.eq.'Gautschi') then
            auxqd = 'ShiftLeg'
            naux = nauxs(NROOTS)
         else
            auxqd = 'none'
            naux = 0
            if(NROOTS.gt.13) stop 'chosen Rys code stops at NROOTS=13'
         end if
         if(naux.gt.mxaux) stop 'fix dimension for auxiliary quad.'
c
         if(code.eq.'Schmidt'  .or.  code.eq.'Gautschi') then
c
c              Set up auxiliary "shifted Legendre quadrature",
c              which is weight function 1, on interval [0,1].
c              Note that choosing naux=20 exactly reproduces
c              the slightly wrong values in the first column
c              of Tables 3 and 4 given by Schneider/Nygaard,
c              and using naux=40 will give their Tables 1 and 2.
c
            if(auxqd.eq.'ShiftLeg') then
               do i=0,naux-1
                  alpaux(i) = one/two
               enddo
               betaux(0)= one
               quart = one/four
               do i=1,naux-1
                  betaux(i) = quart/(four-(one/(i*i)))
               end do
               call gauss(naux,alpaux,betaux,eps,rtsaux,wtsaux,ierr,p0)
            end if
c
c              Set up auxiliary "Fejer quadrature", which is a
c              generic choice for roots and weights.
c              naux=40 gives about 9 significant figure agreement to
c              Sagar/Smith's table IV, and naux=80 is almost perfect.
c
            if(auxqd.eq.'Fejer') then
               call fejer(naux,rtsaux,wtsaux)
            end if
         end if
c
c
c            This is the original HONDO routine, which loses
c            accuracy rapidly with NROOTS, even if run in the
c            quadruple precision.  In double precision, the
c            RMS error compared to the Gautschi code is largest
c            at small XX, and gradually decreases with XX:
c                         XX=0    XX=xasymp
c                    6    1d-11    1d-14
c                    7    1d-09    1d-12
c                    8    5d-08    1d-12
c                    9    2d-06    1d-10
c                   10    5d-05    1d-10
c                   11    3d-03    1d-7
c
         if(code.eq.'Dupuis') then
            call dupuis(NROOTS,XX,rts,wts)
         end if
c
c            Jose Sierra's arbitrary precision fitting method.
c            Note that m2dR=32 and m2dW=128 handle NROOTS=13, XX=10.0
c            but that serious numerical problems turn up at larger XX.
c
         if(code.eq.'Sierra') then
            m2dR= 128
            m2dW= 128
            do i=1,NROOTS
               if(m2dR.eq.128) call Raiz128(rts(i),i,NROOTS,XX,m2dR-2)
               if(m2dW.eq.128) call Peso128(wts(i),i,NROOTS,XX,m2dW-2)
            enddo
         end if
c
c           Generate alpha,beta recurrence coefficients, as well
c           as the Rys Polynomials, by Stieltjes "bootstrapping".
c           This code choice will also print the Rys polynomial.
c           The only thing "Schmidt" about this is the programming,
c           and it is accurate if executed in quadruple precision.
c
         if(code.eq.'Schmidt') then
            call RPboot(rtsaux,wtsaux,naux,NROOTS,XX,alpha,beta,RPprt)
            call gauss(NROOTS,alpha,beta,eps,rts,wts,ierr,wrk)
         end if
c
c           Gautschi's discretized Stieltjes "bootstrapping", which
c           bootstraps the numerical values of the Rys polynomials on
c           the grid, yielding numerically stable alpha,beta values.
c           Of course, the Rys polynomial can be generated using the
c           final alpha,beta values in the recurrence.  If you
c           want to be sure about having the polynomial exactly,
c           run in quadruple precision, at least in RysGen.
c
         if(code.eq.'Gautschi') then
            do i=1,naux
               t2 = rtsaux(i)*rtsaux(i)
               rgrid(i) = t2
               wgrid(i) = wtsaux(i)*exp(-XX*t2)
            enddo
            call sti(NROOTS,naux,rgrid,wgrid,alpha,beta,ierr,p0,p1,p2)
            if(ierr.ne.0) stop 'discretized Stieltjes failed'
            if(RPprt) call RysGen(alpha,beta,NROOTS)
            call gauss(NROOTS,alpha,beta,eps,rts,wts,ierr,wrk)
         end if
      end if
c
c     the following converts to everyone's convention for Tables.
c
      if(type.eq.'Rys') then
         do i=1,NROOTS
            rts(i) = sqrt(rts(i))
         enddo
      end if
c
      if(type.eq.'Rys') then
         write(6,920) XX
      else
         write(6,930) type
      end if
      do i=1,NROOTS
         write(6,940) i,rts(i),wts(i)
      enddo
      if(type.eq.'Rys') then
         if(code.eq.'Asymptotic') write(6,950) code
         if(code.eq.'Dupuis')     write(6,950) code
         if(code.eq.'Sierra')     write(6,960) code,m2dR,m2dW
         if(code.eq.'Schmidt')    write(6,970) code,auxqd,naux
         if(code.eq.'Gautschi')   write(6,970) code,auxqd,naux
      end if
      stop
c
  900 format('Enter desired Gauss-Rys NROOTS and X: ',$)
  910 format('Enter desired order of Gauss-',a,' quadrature: ',$)
  920 format('Roots and Weights for Gauss-Rys quadrature, at X=',f8.3)
  930 format('Roots and Weights for Gauss-',a,' quadrature.')
  940 format(1x,'i=',i4,1P,' root=',e21.14,' weight=',e21.14)
  950 format('using Code=',a)
  960 format('using Code=',a,' m2dR=',i5,'   m2dW=',i5)
  970 format('using Code=',a,' AuxQd=',a,'   Naux=',i4)
      end
c
      subroutine gauss(n,alpha,beta,eps,zero,weight,ierr,wrk)
      implicit real*8(a-h,o-z)
      dimension alpha(n),beta(n),zero(n),weight(n),wrk(n)
c
c         this routine is a supplement to the journal article,
c      Algorithm 726: ORTHPOL - A Package of Routines for Generating
c        Orthogonal Polynomials and Gauss-Type Quadrature Rules.
c                         Walter Gautschi,
c      ACM Transactions on Mathematical Software, 20, 21-62(1994)
c
c            A footnote in Gautschi's article reveals that
c            this particular routine came from Gene Golub.
c
c Given  n  and a measure  dlambda, this routine generates the n-point
c Gaussian quadrature formula
c
c     integral over supp(dlambda) of f(x)dlambda(x)
c
c        = sum from k=1 to k=n of w(k)f(x(k)) + R(n;f).
c
c The nodes are returned as  zero(k)=x(k) and the weights as
c weight(k)=w(k), k=1,2,...,n. The user has to supply the recursion
c coefficients  alpha(k), beta(k), k=0,1,2,...,n-1, for the measure
c dlambda. The routine computes the nodes as eigenvalues, and the
c weights in term of the first component of the respective normalized
c eigenvectors of the n-th order Jacobi matrix associated with  dlambda.
c It uses a translation and adaptation of the algol procedure  imtql2,
c Numer. Math. 12, 1968, 377-383, by Martin and Wilkinson, as modified
c by Dubrulle, Numer. Math. 15, 1970, 450. See also Handbook for
c Autom. Comput., vol. 2 - Linear Algebra, pp.241-248, and the eispack
c routine  imtql2.
c
c        Input:  n - - the number of points in the Gaussian quadrature
c                      formula; type integer
c                alpha,beta - - arrays of dimension  n  to be filled
c                      with the values of  alpha(k-1), beta(k-1), k=1,2,
c                      ...,n
c                eps - the relative accuracy desired in the nodes
c                      and weights
c
c        Output: zero- array of dimension  n  containing the Gaussian
c                      nodes (in increasing order)  zero(k)=x(k), k=1,2,
c                      ...,n
c                weight - array of dimension  n  containing the
c                      Gaussian weights  weight(k)=w(k), k=1,2,...,n
c                ierr- an error flag equal to  0  on normal return,
c                      equal to  i  if the QR algorithm does not
c                      converge within 30 iterations on evaluating the
c                      i-th eigenvalue, equal to  -1  if  n  is not in
c                      range, and equal to  -2  if one of the beta's is
c                      negative.
c
c The array  wrk  is needed for working space.
c
      if(n.lt.1) then
        ierr=-1
        return
      end if
c
      ierr=0
      zero(1)=alpha(1)
      if(beta(1).lt.0.0D+00) then
        ierr=-2
        return
      end if
      weight(1)=beta(1)
      if (n.eq.1) return
c
      weight(1)=1.0D+00
      wrk(n)=0.0D+00
      do 100 k=2,n
        zero(k)=alpha(k)
        if(beta(k).lt.0.0D+00) then
          ierr=-2
          return
        end if
        wrk(k-1)=sqrt(beta(k))
        weight(k)=0.0D+00
  100 continue
c
      do 240 l=1,n
        j=0
c
c Look for a small subdiagonal element.
c
  105   do 110 m=l,n
          if(m.eq.n) go to 120
          if(abs(wrk(m)).le.eps*(abs(zero(m))+abs(zero(m+1))))
     *      go to 120
  110   continue
  120   dp=zero(l)
        if(m.eq.l) go to 240
        if(j.eq.30) go to 400
        j=j+1
c
c Form shift.
c
        dg=(zero(l+1)-dp)/(2.0D+00*wrk(l))
        dr=sqrt(dg*dg+1.0D+00)
        dg=zero(m)-dp+wrk(l)/(dg+sign(dr,dg))
        ds=1.0D+00
        dc=1.0D+00
        dp=0.0D+00
        mml=m-l
c
c For i=m-1 step -1 until l do ...
c
        do 200 ii=1,mml
          i=m-ii
          df=ds*wrk(i)
          db=dc*wrk(i)
          if(abs(df).lt.abs(dg)) go to 150
          dc=dg/df
          dr=sqrt(dc*dc+1.0D+00)
          wrk(i+1)=df*dr
          ds=1.0D+00/dr
          dc=dc*ds
          go to 160
  150     ds=df/dg
          dr=sqrt(ds*ds+1.0D+00)
          wrk(i+1)=dg*dr
          dc=1.0D+00/dr
          ds=ds*dc
  160     dg=zero(i+1)-dp
          dr=(zero(i)-dg)*ds+2.0D+00*dc*db
          dp=ds*dr
          zero(i+1)=dg+dp
          dg=dc*dr-db
c
c Form first component of vector.
c
          df=weight(i+1)
          weight(i+1)=ds*weight(i)+dc*df
          weight(i)=dc*weight(i)-ds*df
  200   continue
        zero(l)=zero(l)-dp
        wrk(l)=dg
        wrk(m)=0.0D+00
        go to 105
  240 continue
c
c Order eigenvalues and eigenvectors.
c
      do 300 ii=2,n
        i=ii-1
        k=i
        dp=zero(i)
        do 260 j=ii,n
          if(zero(j).ge.dp) go to 260
          k=j
          dp=zero(j)
  260   continue
        if(k.eq.i) go to 300
        zero(k)=zero(i)
        zero(i)=dp
        dp=weight(i)
        weight(i)=weight(k)
        weight(k)=dp
  300 continue
      do 310 k=1,n
        weight(k)=beta(1)*weight(k)*weight(k)
  310 continue
      return
c
c Set error - no convergence to an eigenvalue after 30 iterations.
c
  400 ierr=l
      return
      end
c
      subroutine sti(n,ncap,x,w,alpha,beta,ierr,p0,p1,p2)
      implicit real*8(a-h,o-z)
      dimension x(ncap),w(ncap),alpha(n),beta(n),
     *          p0(ncap),p1(ncap),p2(ncap)
c
c         this routine is a supplement to the journal article,
c      Algorithm 726: ORTHPOL - A Package of Routines for Generating
c        Orthogonal Polynomials and Gauss-Type Quadrature Rules.
c                         Walter Gautschi,
c      ACM Transactions on Mathematical Software, 20, 21-62(1994)
c
c This routine applies Stieltjes's procedure (cf. Section 2.1 of
c W. Gautschi,On generating orthogonal polynomials'', SIAM J. Sci.
c Statist. Comput. 3, 1982, 289-317) to generate the recursion
c coefficients  alpha(k), beta(k) , k=0,1,...,n-1, for the discrete
c (monic) orthogonal polynomials associated with the inner product
c
c     (f,g)=sum over k from 1 to ncap of w(k)*f(x(k))*g(x(k)).
c
c The integer  n  must be between  1  and  ncap, inclusive; otherwise,
c there is an error exit with  ierr=1. The results are stored in the
c arrays  alpha, beta; the arrays  p0, p1, p2  are working arrays.
c
c If there is a threat of underflow or overflow in the calculation
c of the coefficients  alpha(k)  and  beta(k), the routine exits with
c the error flag  ierr  set equal to  -k  (in the case of underflow)
c or  +k  (in the case of overflow), where  k  is the recursion index
c for which the problem occurs. The former [latter] can often be avoided
c by multiplying all weights  w(k)  by a sufficiently large [small]
c scaling factor prior to entering the routine, and, upon exit, divide
c the coefficient  beta(0)  by the same factor.
c
c This routine should be used with caution if  n  is relatively close
c to  ncap, since there is a distinct possibility of numerical
c instability developing. (See W. Gautschi,Is the recurrence relation
c for orthogonal polynomials always stable?'', BIT, 1993, to appear.)
c In that case, the routine  lancz  should be used.
c
      tiny = 1.0d-40
      huge = 1.0d+40
c
      ierr=0
      if(n.le.0 .or. n.gt.ncap) then
        ierr=1
        return
      end if
      nm1=n-1
c
c Compute the first alpha- and beta-coefficient.
c
      sum0=0.0d+00
      sum1=0.0d+00
      do 10 m=1,ncap
        sum0=sum0+w(m)
        sum1=sum1+w(m)*x(m)
   10 continue
      alpha(1)=sum1/sum0
      beta(1)=sum0
      if(n.eq.1) return
c
c Compute the remaining alpha- and beta-coefficients.
c
      do 20 m=1,ncap
        p1(m)=0.0d+00
        p2(m)=1.0d+00
   20 continue
      do 40 k=1,nm1
        sum1=0.0d+00
        sum2=0.0d+00
        do 30 m=1,ncap
c
c The following statement is designed to avoid an overflow condition
c in the computation of  p2(m)  when the weights  w(m)  go to zero
c faster (and underflow) than the  p2(m)  grow.
c
          if(w(m).eq.0.0d+00) goto 30
          p0(m)=p1(m)
          p1(m)=p2(m)
          p2(m)=(x(m)-alpha(k))*p1(m)-beta(k)*p0(m)
c
c Check for impending overflow.
c
          if(abs(p2(m)).gt.huge .or. abs(sum2).gt.huge) then
            ierr=k
            return
          end if
          t=w(m)*p2(m)*p2(m)
          sum1=sum1+t
          sum2=sum2+t*x(m)
   30   continue
c
c Check for impending underflow.
c
        if(abs(sum1).lt.tiny) then
          ierr=-k
          return
        end if
        alpha(k+1)=sum2/sum1
        beta(k+1)=sum1/sum0
        sum0=sum1
   40 continue
c
      return
      end
C
      subroutine fejer(nh,x,w)
      implicit real*8(a-h,o-z)
      dimension x(nh),w(nh)
c
c This routine generates the n-point Fejer quadrature rule.
c Again, this came from Walter Gautschi's package, but was
c modified by MWS to store only the quadrature points on
c the positive half of the usual interval, which is [-1,+1].
c
c         input:   nh  - the number of quadrature nodes at positive x.
c         output:  x,w - arrays of dimension -nh- holding the quadrature
c                        nodes and weights, respectively; the nodes
c                        are ordered increasingly
c
      n=nh+nh
      pi=4.0d+00*atan(1.0d+00)
      np1h=(n+1)/2
      fn=n
      do 10 k=1,nh
        x(nh+1-k)=cos(0.5d+00*(2*k-1)*pi/fn)
   10 continue
c     if(2*nh.ne.n) x(np1h)=0.0d+00
      do 30 k=1,np1h
        c1=1.0d+00
        c0=2.0d+00*x(k)*x(k)-1.0d+00
        t=2.0d+00*c0
        sum=c0/3.0d+00
        do 20 m=2,nh
          c2=c1
          c1=c0
          c0=t*c1-c2
          sum=sum+c0/(4*m*m-1)
   20   continue
        w(k)=2.0d+00*(1.0d+00-2.0d+00*sum)/fn
   30 continue
      return
      end
c
      subroutine RPboot(rtsaux,wtsaux,naux,NROOTS,XX,alpha,beta,RPprt)
      implicit real*8(a-h,o-z)
      dimension rtsaux(naux),wtsaux(naux),
     *          alpha(0:NROOTS-1),beta(0:NROOTS-1)
      parameter (mxquad=25)
      dimension t2exp(0:2*mxquad),RP(0:mxquad,0:mxquad),rpint(0:mxquad)
      logical RPprt
      parameter (zero=0.0d+00, one=1.0d+00)
c
c        This routine written by Mike Schmidt, Department of Chemistry,
c        Iowa State University, November 2005.  It does not control
c        the errors in alpha,beta recurrence coefficients well enough.
c        Running in Q.P. is decent, however, for NROOTS=13, XX=10.0.
c
c        Integrate all even powers of t times the Rys weight function,
c        using our auxiliary quadrature.
c
      do k=0,2*NROOTS
         t2exp(k) = zero
      enddo
      do i=1,naux
         t   = rtsaux(i)
         t2  = t*t
         dum = wtsaux(i)*exp(-XX*t2)
	 fac = one
	 do k=0,2*NROOTS
            t2exp(k) = t2exp(k) + fac*dum
            fac = fac*t2
         enddo
      enddo
c
      do k=0,NROOTS
         do j=0,NROOTS
            RP(j,k) = zero
         enddo
      enddo
c
c        by definition, the zero-th Rys Polynomial is unity
c
      RP(0,0) = one
c
c        generate the first Rys polynomial as a special case.
c          note: beta(0) = sqrt(pi/4*x) * derf(sqrt(x))
c
      rpint(0)= t2exp(0)
      alpha(0)= t2exp(1)/rpint(0)
      beta(0) = rpint(0)
      RP(0,1) = -alpha(0)
      RP(1,1) = one
      if(NROOTS.eq.1) return
c
      do k=1,NROOTS-1
c            numerical integration gives the recursion coefficients
         suma = zero
         sumb = zero
c            the multiplications and additions of alternating
c            signs in the loop below must be the roundoff problem.
         do i=0,k
            do j=0,k
               suma = suma + RP(i,k) * RP(j,k) * t2exp(i+j+1)
               sumb = sumb + RP(i,k) * RP(j,k) * t2exp(i+j)
            enddo
         enddo
         rpint(k) = sumb
         alpha(k) = suma/rpint(k)
         beta(k)  = rpint(k)/rpint(k-1)
c            upward recurrence generates the next Rys Polynomial
         do j=0,k
            RP(j,k+1) = -alpha(k)*RP(j,k) - beta(k)*RP(j,k-1)
         enddo
         do j=0,k
            RP(j+1,k+1) = RP(j+1,k+1) + RP(j,k)
         enddo
      enddo
c
c        print the Rys Polynomial coefficients
c
      if(RPprt) write(6,900) RP(0,NROOTS),(RP(j,NROOTS),2*j,j=1,NROOTS)
  900 format(1P,e15.7,7x,2(e15.7,'*t**',i2,1x)/
     *               (1P,3(e15.7,'*t**',i2,1x)))
c
      return
      end
c
      subroutine RysGen(alpha,beta,NROOTS)
      implicit real*8(a-h,o-z)
      dimension alpha(0:*),beta(0:*)
      parameter (mxquad=25)
      dimension RP(0:mxquad,0:mxquad)
      parameter (zero=0.0d+00, one=1.0d+00)
c
      do k=0,NROOTS
         do j=0,NROOTS
            RP(j,k) = zero
         enddo
      enddo
c
c        by definition, the zero-th Rys Polynomial is unity
c
      RP(0,0) = one
c
c        then set the first Rys Polynomial
c
      RP(0,1) = -alpha(0)
      RP(1,1) = one
      if(NROOTS.eq.1) go to 200
c
c        upward recurrence generates the next Rys Polynomial, at k+1
c
      do k=1,NROOTS-1
         do j=0,k
            RP(j,k+1) = -alpha(k)*RP(j,k) - beta(k)*RP(j,k-1)
         enddo
         do j=0,k
            RP(j+1,k+1) = RP(j+1,k+1) + RP(j,k)
         enddo
      enddo
c
  200 continue
      write(6,900) RP(0,NROOTS),(RP(j,NROOTS),2*j,j=1,NROOTS)
      return
  900 format(1P,e15.7,7x,2(e15.7,'*t**',i2,1x)/
     *               (1P,3(e15.7,'*t**',i2,1x)))
      end
c
      subroutine dupuis(NROOTS,XX,rts,wts)
      implicit real*8(a-h,o-z)
      dimension rts(NROOTS),wts(NROOTS)
      COMMON /ROOT  / x,uf(13),wf(13),n
c
c        compute Rys Polynomial roots and weights,
c        using the original method of Michel Dupuis
c
      n= NROOTS
      x= XX
      if(n.gt.13) stop 'exceeded dimension limit for Dupuis code'
c
      call root6
      do i=1,NROOTS
         rts(i) = uf(i)
         wts(i) = wf(i)
      enddo
      return
      end
C*MODULE RYSPOL  *DECK ROOT6
      SUBROUTINE ROOT6
C
      implicit real*8(a-h,o-z)
C
      DIMENSION C(14,14),S(14,14),A(14),RT(14),R(13,13),W(13,13),FF(27)
C
      COMMON /ROOT  / XX,UF(13),WF(13),NROOTS
C
      PARAMETER (PT5=0.5D+00, ZERO=0.0D+00, ONE=1.0D+00, FOUR=4.0D+00)
C
C     I-TH ROOT OF THE J-TH RYS POLYNOMIAL IS RETURNED IN R(I,J)
C     WITH THE CORRESPONDING WEIGHT FACTOR IN W(I,J).   J=1,2,...,N
C     THIS VERSION USES CHRISTOFFEL FORMULA FOR WEIGHTS, AND IT IS
C     COMPLETELY GENERAL UP TO NROOTS=9.  SEE THE REFERENCE
C        "NUMERICAL INTEGRATION USING RYS POLYNOMIALS"
C                   H.F.KING AND M.DUPUIS
C              J.COMPUT.PHYS. 21, 144-165(1976)
C
      N=NROOTS
      X=XX
C
C     X LARGE (ASYMPTOTIC SOLUTION)              NROOTS=6,7,8,9
c     MWS: November 2005, I no longer think the asymptotic
c                         routines are very accurate!
C
c---  IF(X.GT.64.0D+00) THEN
      IF(X.GT.1000.0D+00) THEN
         CALL ROOTSA
         RETURN
      ENDIF
C
      IF(N.LT.2) N=2
      N1=N+1
      NN=N+N
      CALL RYSFUN(X,NN,FF)
C
      DO 11 I=1,N1
         DO 10 J=1,N1
            S(I,J)=FF(I+J-1)
   10    CONTINUE
   11 CONTINUE
      CALL RYSSMT(C,S,N1)
C
      DO 21 I=1,N
         DO 20 J=1,I
            W(I,J)= ZERO
            R(I,J)= ZERO
   20    CONTINUE
   21 CONTINUE
C
      WSUM=FF(1)
      W(1,1)=WSUM
      R(1,1)=FF(2)/WSUM
      DUM= SQRT(C(2,3)**2-FOUR *C(1,3)*C(3,3))
      R(1,2)= PT5*(-C(2,3)-DUM)/C(3,3)
      R(2,2)= PT5*(-C(2,3)+DUM)/C(3,3)
      IF(N.EQ.2) GO TO 70
      DO 25 I=3,N1
   25 RT(I)= ONE
      RT(1)=R(1,2)
      RT(2)=R(2,2)
C
      DO 60 K=3,N
         K1=K+1
         DO 30 I=1,K1
            A(I)=C(I,K1)
   30    CONTINUE
         CALL RYSNOD(A,RT,K)
         DO 50 I=1,K
            R(I,K)=RT(I)
   50    CONTINUE
   60 CONTINUE
C
   70 CONTINUE
      DO 150 K=2,N
         JMAX=K-1
         DO 140 I=1,K
            ROOT=R(I,K)
            DUM = ONE/FF(1)
            DO 110 J=1,JMAX
               J1=J+1
               POLY=C(J1,J1)
               DO 100 M=1,J
                  POLY=POLY*ROOT+C(J1-M,J1)
  100          CONTINUE
               DUM=DUM+POLY*POLY
  110       CONTINUE
            W(I,K) = ONE/DUM
  140    CONTINUE
  150 CONTINUE
C
C       GAMESS normally wants the reciprocal form to do an
C       actual integral, but here we want the root directly.
C
      DO 160 K=1,NROOTS
C--      DUM=R(K,NROOTS)
C--      UF(K)=DUM/(ONE-DUM)
         uf(k)=r(k,nroots)
         WF(K)=W(K,NROOTS)
  160 CONTINUE
      RETURN
      END
C*MODULE RYSPOL  *DECK RYSFUN
      SUBROUTINE RYSFUN(X,N,FF)
      implicit real*8(a-h,o-z)
      DIMENSION FF(27)
      DIMENSION XMAX(13)
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00, ONE=1.0D+00, TWO=2.0D+00)
C          THE FIRST FIVE ROOTS ARE DONE IN SPECIALIZED ROUTINES.
      DATA XMAX/5*0.0D+00,
     *          9000000.0D+00, 750000.0D+00, 150000.0D+00, 50000.0D+00,
     *           4*40000.0D+00/
C
      TOL   = 1.0D-14
      XX    = X+X
      FACMIN= XX
C
C        NOTE ADDED BY MWS, SEPTEMBER 1990:
C        VALUES X.GT.3200 AND NROOTS.EQ.6 GENERATE NEGATIVE ARGUMENTS
C        TO THE SQRT FUNCTION IN RYSSMT WHEN ONE USES E=10**(-35).
C        THE PROBLEM GOES AWAY, AND THE ROOTS AND WEIGHTS STABILIZE
C        FOR X OUT TO 5000 WHEN 10**(-40) TO 10**(-60) IS USED.
C        SINCE VAX UNDERFLOWS AT AROUND 10**(-38) WE HAVE TO BE MORE
C        CAREFUL THAN JUST SETTING E A FEW POWERS OF TEN DOWNWARD.
C        MICHEL'S ORIGINAL CODE IS SHOWN FIRST.   THE VALUE OF 360
C        IS WHERE IBMS GET INTO UNDERFLOWS (ABOUT 10**(-78)).  THE
C        1990 CHANGES INCLUDE THE COMPUTATION OF E IN THE ASYMPTOTIC
C        CODE A FEW LINES DOWN.
C
C--   E     = 1.0D-35
C--   IF(FACMIN.LT.360.0D+00) E=EXP(-X)
C--   IF(FACMIN.GT.80.0D+00) GO TO 100
C
      E = ZERO
      IF(FACMIN.LT.360.0D+00) E=EXP(-X)
      IF(FACMIN.GT.80.0D+00) GO TO 100
C
      TERM= ONE
      SUM = ONE
      FAC = N
      FAC = FAC+PT5
C
   10 FAC = FAC+ONE
      TERM= TERM*X/FAC
      SUM = SUM+TERM
      IF(FAC.LE.FACMIN) GO TO 10
      T=TERM
      S=SUM
      IF(T.GT.S*TOL) GO TO 10
C
      FAC=N+N+1
      FF(N+1)=SUM*E/FAC
      M=N-1
      FAC=M+M+1
C
   20 IF(M.LT.0) RETURN
      FF(M+1)=(E+XX*FF(M+2))/FAC
      M=M-1
      FAC=FAC-TWO
      GO TO 20
C
C     NOTE BY MWS, NOVEMBER 1997:  THIS CODE HAD BEEN SETTING -E- TO
C     1.0D-35 WITH DOWNWARDS ADJUSTMENTS TO 1.0D-45 ON MOST MACHINES.
C     MICHEL USUALLY USES A VALUE OF 1.0D-78 HERE, WHERE THE LOWER
C     END OF THE IBM MAINFRAME'S DYNAMIC RANGE LIES.  MIKE'S HACK AT
C     TRYING TO ACCOMODATE BOTH THE VAX, AND THE NEED FOR A LOWER GUESS
C     AT E IS SHOWN COMMENTED OUT.  INSTEAD WE WILL NOW TEST FOR THE
C     MAXIMUM X FOR WHICH 1D-78 WILL RETURN 9 DIGIT ACCURACY ROOTS AND
C     WEIGHTS FOR.  ANYONE WHO FINDS THEMSELVES HERE MIGHT BE ABLE TO
C     INTEGRATE ACCURATELY BY CHOOSING A STILL SMALLER VALUE OF -E-,
C     BUT SHOULD BE CAREFUL TO TEST THE NUMERICS OF THE SITUATION
C     INSTEAD OF JUST BLINDLY LOWERING THE THRESHHOLD FURTHER.
C
C  TO CONVERGE 9 SIGNIFICANT DIGITS (IS THIS ENOUGH???) FOR NROOTS=6
C          X    ROOT CONV.  WEIGHT CONV
C        5,000      -43        -45       (NUMBER IS POWER OF TEN FOR E)
C       10,000      -47        -48
C       20,000      -49        -50
C       50,000      -54        -54
C      100,000      -57        -58
C      200,000      -60        -61
C    1,000,000      -67        -69
C    9,000,000      -76        -78
C   10,000,000      -79        -79
C     SIMILAR TESTS SHOW THAT HIGHER POLYNOMIALS GO TO SMALLER X VALS
C
C     NO. OF SIGNIFICANT DIGITS ACCURACY USING E=1.0D-45 FOR NROOTS=6
C          X       ROOTS    WEIGHTS
C        5,000        9         9
C       10,000        8         8
C       15,000        7         5
C       20,000        4         4
C       30,000        3         2
C       40,000        2         2
C       50,000        1         0
C    THAT IS, FOR X=40000, ROOT 1 IS 2.442D-6 BUT SHOULD BE 2.469D-6,
C    SO ONLY TWO DIGITS OF ACCURACY IS ATTAINED.  AT X=58000, THE
C    GUESS OF 1D-45 FOR -E- FAILS TO FIND THE ROOTS AT ALL.
C
C     --- USE ASYMPTOTIC EXPANSION FOR LARGE ARGUMENTS ---
C
  100 CONTINUE
C---      IF(E.EQ.ZERO) THEN
C---         ESAVE = 1.0D-35
C---         DO 5 I=1,10
C---            E = ESAVE*0.1D+00
C---            IF(E.EQ.ZERO) GO TO 6
C---            ESAVE = E
C---    5    CONTINUE
C---    6    CONTINUE
C---         E = ESAVE
C---      END IF
C
      IF(E.EQ.ZERO) THEN
         NROOTS = N/2
         IF(X.GT.XMAX(NROOTS)) THEN
            WRITE(6,9010) NROOTS,X,XMAX(NROOTS)
            STOP 'error termination in RYSFUN'
         END IF
         E = 1.0D-78
      END IF
C
      A= SQRT(0.7853981633974483096156608D+00/X)
      TMAX= A*TOL/E
      TERM= ONE/XX
      SUM = TERM
      FAC = ONE
C
  110 FAC = FAC-TWO
      TERM= FAC*TERM/XX
      SUM = TERM+SUM
      T   = TERM
      IF(ABS(T).GT.TMAX) GO TO 110
C
      FF(1)= A-E*SUM
      FAC  = -ONE
      M    = 0
C
  120 IF(M.EQ.N) RETURN
      M      = M+1
      FAC    = FAC+TWO
      FF(M+1)= (FAC*FF(M)-E)/XX
      GO TO 120
C
 9010 FORMAT(1X,'RYSFUN: UNABLE TO FIND ROOTS OF RYS POLYNOMIAL.'/
     *       1X,'NROOTS=',I4,' X=',F20.5,' XMAX=',F20.5)
      END
C*MODULE RYSPOL  *DECK RYSNOD
      SUBROUTINE RYSNOD(A,RT,K)
      implicit real*8(a-h,o-z)
      DIMENSION A(14),RT(14)
      PARAMETER (ZERO=0.0D+00)
C
C     RETURNS IN RT(I) THE ITH ROOT OF A POLYNOMIAL OF ORDER K
C     WHOSE MTH COEFFICIENT IS STORED IN A(M+1).  IT IS ASSUMED
C     THAT THE INITIAL VALUES IN RT BRACKET THE FINAL VALUES.
C
      TOL=1.0D-11
      K1=K+1
      R2= ZERO
      P2=A(1)
      DO 100 M=1,K
         R1=R2
         P1=P2
         R2=RT(M)
         P2=A(K1)
         DO 10 I=1,K
            P2=P2*R2+A(K1-I)
   10    CONTINUE
         PROD=P1*P2
         IF(PROD.GE.ZERO) THEN
            WRITE(6,15) M,K
            STOP 'error termination in RYSNOD'
         END IF
         R5=R1
         P5=P1
         R6=R2
         P6=P2
   30    CONTINUE
         R3=R5
         P3=P5
         R4=R6
         P4=P6
         R =(R3*P4-R4*P3)/(P4-P3)
         DR=R4-R3
         DELTA=DR
         IF(ABS(DELTA).LT.TOL) GO TO 90
         DR=0.0625D+00*DR
         R5=R-DR
         IF(R5.LT.R3) R5=R3
         R6=R+DR
         IF(R6.GT.R4) R6=R4
         P5=A(K1)
         P6=P5
         DO 40 I=1,K
            P5=P5*R5+A(K1-I)
            P6=P6*R6+A(K1-I)
   40    CONTINUE
   45    CONTINUE
         PROD=P5*P6
         IF(PROD.LT. ZERO) GO TO 30
         PROD=P3*P5
         IF(PROD.GT. ZERO) GO TO 60
         R5=0.25D+00*R3+0.75D+00*R5
         P5=A(K1)
         DO 50 I=1,K
            P5=P5*R5 + A(K1-I)
   50    CONTINUE
         GO TO 45
C
   60    CONTINUE
         R6=0.25D+00*R4 + 0.75D+00*R6
         P6=A(K1)
         DO 70 I=1,K
            P6=P6*R6 + A(K1-I)
   70    CONTINUE
         GO TO 45
C
   90    CONTINUE
         RT(M)=R
  100 CONTINUE
      RETURN
C
   15 FORMAT(//1X,'RYSNOD: ROOT NUMBER ',I3,
     *            ' WAS NOT FOUND FOR POLYNOMIAL OF ORDER ',I3,
     *            ' ON NODE',I4//)
      END
C*MODULE RYSPOL  *DECK RYSSMT
      SUBROUTINE RYSSMT(C,S,N)
      implicit real*8(a-h,o-z)
      DIMENSION C(14,14),S(14,14),V(14),Y(14)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
C     ROUTINE RETURNS AN N BY N TRIANGULAR MATRIX C SUCH THAT
C     C(TRANSPOSE)SC=I,  WHERE I IS AN N BY N IDENTITY MATRIX.
C
      DO 10 I=1,N
      DO 10 J=1,I
   10 C(I,J)= ZERO
C
      DO 100 J=1,N
         KMAX=J-1
         FAC=S(J,J)
         IF(KMAX.EQ.0) GO TO 60
C
         DO 20 K=1,KMAX
            V(K)= ZERO
            Y(K)=S(K,J)
   20    CONTINUE
         DO 50 K=1,KMAX
            DOT= ZERO
            DO 30 I=1,K
               DOT=C(I,K)*Y(I)+DOT
   30       CONTINUE
            DO 40 I=1,K
               V(I)=V(I)-DOT*C(I,K)
   40       CONTINUE
            FAC=FAC-DOT*DOT
   50    CONTINUE
C
   60    CONTINUE
C
C               THE ORIGINAL CODE LEADS TO DIVIDE BY
C               ZERO ON VAX COMPUTERS FOR X>3100 OR SO.
C--      FAC=ONE/SQRT(FAC)
C
         IF(FAC.GT.ZERO) THEN
            FAC=  ONE/SQRT(FAC)
         ELSE
            FAC = 1.0D+25
         END IF
C
         C(J,J)=FAC
         IF(KMAX.EQ.0) GO TO 100
         DO 70 K=1,KMAX
            C(K,J)=FAC*V(K)
   70    CONTINUE
  100 CONTINUE
      RETURN
      END
C*MODULE RYSPOL  *DECK ROOTSA
      SUBROUTINE ROOTSA
C
      implicit real*8(a-h,o-z)
C
      COMMON /ROOT  / X,U(13),W(13),NROOTS
C
C     COMPUTE THE ROOTS AND WEIGHTS OF THE RYS POLYNOMIALS OF ORDER
C     NROOTS=1 UP TO NROOTS=13 FOR ASYMPTOTICALLY LARGE -X- VALUES.
C
C     AUTHOR: JOSE M. SIERRA, SYNSTAR CORPORATION, SEPTEMBER 2004
C
C     THE CODE IS CORRECT FOR ANY NROOTS, BUT MAY BE A LITTLE BIT SLOWER
C     THAN THE ORIGINAL SMALL NROOTS VALUE EXPANSIONS OF DUPUIS AND RYS.
C
      PARAMETER (MR=13, MX=(MR*(MR+1))/2)
      DIMENSION AR(MX),AW(MX)
C
      PARAMETER (ONE=1.0D+00, PI4=7.85398163397448D-01)
C
C    NEW VALUES (OBTAINED FROM 'ANALYTICAL' POLYNOMIALS)
C
C NROOTS=1
      DATA (AR(I),I= 1, 1)/  5.00000000000000D-01/
C NROOTS=2
      DATA (AR(I),I= 2, 3)/  2.75255128608411D-01, 2.72474487139159D+00/
C NROOTS=3
      DATA (AR(I),I= 4, 6)/  1.90163509193488D-01, 1.78449274854325D+00,
     3 5.52534374226326D+00/
C NROOTS=4
      DATA (AR(I),I= 7,10)/  1.45303521503317D-01, 1.33909728812636D+00,
     4 3.92696350135829D+00, 8.58863568901203D+00/
C NROOTS=5
      DATA (AR(I),I=11,15)/  1.17581320211778D-01, 1.07456201243690D+00,
     5 3.08593744371755D+00, 6.41472973366203D+00, 1.18071894899717D+01/
C NROOTS=6
      DATA (AR(I),I=16,21)/  9.87470140684812D-02, 8.98302834569617D-01,
     6 2.55258980266817D+00, 5.19615253005447D+00, 9.12424803753117D+00,
     6 1.51299597811081D+01/
C NROOTS=7
      DATA (AR(I),I=22,28)/  8.51154429975940D-02, 7.72137920042777D-01,
     7 2.18059188845046D+00, 4.38979288673077D+00, 7.55409132610392D+00,
     7 1.19899930398239D+01, 1.852827749585248D+01/
C NROOTS=8
      DATA (AR(I),I=29,36)/  7.47918825968183D-02, 6.77249087649289D-01,
     8 1.90511363503143D+00, 3.80947636148493D+00, 6.48314542862698D+00,
     8 1.00933236752216D+01, 1.49726270884262D+01, 2.19842728409627D+01/
C NROOTS=9
      DATA (AR(I),I=37,45)/  6.67022309581943D-02, 6.03236357081748D-01,
     9 1.69239507979318D+00, 3.36917627024335D+00, 5.69442334295712D+00,
     9 8.76975673027048D+00, 1.27718253548667D+01, 1.80465054677307D+01,
     9 2.54859791660990D+01/
C NROOTS=10
      DATA (AR(I),I=46,55)/  6.01920631495866D-02, 5.43867500294645D-01,
     A 1.52294410540445D+00, 3.02251337645400D+00, 5.08490775008944D+00,
     A 7.77743923154111D+00, 1.12081302043343D+01, 1.55611633321971D+01,
     A 2.11938920962985D+01, 2.90249503402365D+01/
C NROOTS=11
      DATA (AR(I),I=56,66)/  5.48398695788185D-02, 4.95174123350356D-01,
     B 1.38465574008460D+00, 2.74191994010634D+00, 4.59773770048869D+00,
     B 6.99939746952188D+00, 1.00189082759681D+01, 1.37693058660907D+01,
     B 1.84411196809850D+01, 2.44019612423853D+01, 3.25949800914407D+01/
C NROOTS=12
      DATA (AR(I),I=67,78)/  5.03618891172940D-02, 4.54506681563779D-01,
     C 1.26958994010396D+00, 2.50984809722837D+00, 4.19841564490072D+00,
     C 6.36997538792228D+00, 9.07543423132649D+00, 1.23904479630736D+01,
     C 1.64321950885250D+01, 2.13967559356126D+01, 2.76611087800458D+01,
     C 3.61913603605784D+01/
C NROOTS=13
      DATA (AR(I),I=79,91)/  4.65600832450248D-02, 4.20027406401213D-01,
     D 1.17231077327777D+00, 2.31454086434948D+00, 3.86458503822818D+00,
     D 5.84873481130518D+00, 8.30455348999401D+00, 1.12857509934872D+01,
     D 1.48709603775928D+01, 1.91809194854928D+01, 2.44166923332210D+01,
     D 3.09639382746126D+01, 3.98104260687924D+01/
C
C    VALUES (OBTAINED USING GAMESS FOR X=128)
C
C NROOTS=1
      DATA (AW(I),I= 1, 1)/  1.00000000000000D+00/
C NROOTS=2
      DATA (AW(I),I= 2, 3)/  1.00000000000000D+00, 9.17517095361369D-02/
C NROOTS=3
      DATA (AW(I),I= 4, 6)/  1.00000000000000D+00, 1.77231492083829D-01,
     3 5.11156880411248D-03/
C NROOTS=4
      DATA (AW(I),I= 7,10)/  1.00000000000000D+00, 2.34479815323517D-01,
     4 1.92704402415764D-02, 2.25229076750736D-04/
C NROOTS=5
      DATA (AW(I),I=11,15)/  1.00000000000000D+00, 2.70967405960535D-01,
     5 3.82231610015404D-02, 1.51614186862443D-03, 8.62130526143657D-06/
C NROOTS=6
      DATA (AW(I),I=16,21)/  1.00000000000000D+00, 2.93934096090658D-01,
     6 5.82333758247259D-02, 4.40676137506590D-03, 9.67436984518118D-05,
     6 2.99985433527357D-07/
C NROOTS=7
      DATA (AW(I),I=22,28)/  1.00000000000000D+00, 3.08166679684882D-01,
     7 7.73002176482838D-02, 8.85783821383684D-03, 4.00679107517203D-04,
     7 5.32198268804275D-06, 9.73632251525836D-09/
C NROOTS=8
      DATA (AW(I),I=29,36)/  1.00000000000000D+00, 3.16676745499791D-01,
     8 9.45695047037012D-02, 1.45338752009040D-02, 1.05196985297312D-03,
     8 3.06000643175543D-05, 2.61894643174802D-07, 2.99562944518145D-10/
C NROOTS=9
      DATA (AW(I),I=37,45)/  1.00000000000000D+00, 3.21370607772183D-01,
     9 1.09793264917933D-01, 2.10330354860907D-02, 2.13096958967959D-03,
     9 1.03597922686261D-04, 2.04310479048232D-06, 1.18109769258849D-08,
     9 8.83317751281791D-12/
C
C     X LARGE (ASYMPTOTIC SOLUTION)              NROOTS=1,..,13
C
      N0=(NROOTS*NROOTS-NROOTS)/2
      R = ONE/X
      FW= SQRT(PI4*R)
      SW=-FW
      DO 110 M=1,NROOTS
         TMS = AR(N0+M)*R
         U(M)= TMS/(ONE-TMS)
         W(M)= AW(N0+M)*FW
         SW= SW+W(M)
  110 CONTINUE
      W(1)= FW-SW
      RETURN
      END
c
      subroutine rysset
      implicit real*8(a-h,o-z)
      PARAMETER (MR=13, MR2=2*MR)
      dimension rts(MR2),wts(MR2),wrk(MR2),
     *          alpha(0:MR2-1),beta(0:MR2-1)
      common /ryspar/ rtsasy(MR,MR),wtsasy(MR,MR)
c
      PI=3.14159265358979323846264338327950288419716939937510D+00
      zero= 0.0D+00
      two = 2.0D+00
      eps = 1.0d-14
c
c     set up asymptotic root computation, by generating
c     the roots of Hermite polynomials of order 2N.
c
      do i=1,MR
         n=i+i
         do j=0,n-1
            alpha(j) = zero
         enddo
         beta(0)=sqrt(pi)
         do j=1,n-1
            beta(j) = j/two
         end do
         call gauss(n,alpha,beta,eps,rts,wts,ierr,wrk)
         do j=1,i
            rtsasy(j,i) = rts(i+j)*rts(i+j)
            wtsasy(j,i) = wts(i+j)
         enddo
      enddo
      return
      end
c
      subroutine rysasy(NROOTS,XX,rts,wts)
      implicit real*8(a-h,o-z)
      dimension rts(NROOTS),wts(NROOTS)
      PARAMETER (MR=13)
      common /ryspar/ rtsasy(MR,MR),wtsasy(MR,MR)
      parameter (one=1.0d+00)
C
C     The roots and weights for X = big are given by:
c       t*t = s*s/XX    w = v/sqrt(XX)
c     where s and v are roots and weights of the
c     Hermite polynomials of order 2*NROOTS.
c     See Ishida-san's second paper for details, although he appears
c     to have been a bit too conservative about when to go asymptotic.
C
      factr = one/XX
      factw = sqrt(factr)
      DO I=1,NROOTS
         rts(I)= factr * rtsasy(I,NROOTS)
         wts(I)= factw * wtsasy(I,NROOTS)
      enddo
      RETURN
      END
c
      subroutine Raiz128(S,I,N,X,M)
      implicit real*8(a-h,o-z)
      PARAMETER (MPO=13, M2D=128, M2L=M2D-1)
      common /jms128/ rtsexp(0:M2L,MPO,MPO),wtsexp(0:M2L,MPO,MPO)
c
C                     2       m             k
C Calculate  S (x) = t (x) = Sum [sin(k) * x ]
C             in      in     k=0
C
      if(M.gt.0) stop "Sierra code is truncated"
c
      L= MIN(M,M2D)-1
      S= rtsexp(L,I,N)
      DO K=L-1, 0,-1
         S= S*X+rtsexp(K,I,N)
      ENDDO
C
      RETURN
      END
c
      subroutine Peso128(W,I,N,X,M)
      implicit real*8(a-h,o-z)
      PARAMETER (MPO=13, M2D=128, M2L=M2D-1)
      common /jms128/ rtsexp(0:M2L,MPO,MPO),wtsexp(0:M2L,MPO,MPO)
C
C                     m             k
C Calculate  W (x) = Sum [win(k) * x ]
C             in     k=0
C
      L= MIN(M,M2D)-1
      W= wtsexp(L,I,N)
      DO K=L-1, 0,-1
         W= W*X+wtsexp(K,I,N)
      ENDDO
C
      RETURN
      END
      subroutine setRaiz128
      return
      end
      subroutine setPeso128
      return
      end


      FUNCTION BESSY1(X)
      REAL*8 Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5,R6,
     *    S1,S2,S3,S4,S5,S6,S7
      DATA P1,P2,P3,P4,P5/1.D0,.183105D-2,-.3516396496D-4,.2457520174D-5
     *,
     *    -.240337019D-6/, Q1,Q2,Q3,Q4,Q5/.04687499995D0,-.2002690873D-3
     *,
     *    .8449199096D-5,-.88228987D-6,.105787412D-6/
      DATA R1,R2,R3,R4,R5,R6/-.4900604943D13,.1275274390D13,-.5153438139
     *D11,
     *    .7349264551D9,-.4237922726D7,.8511937935D4/,
     *    S1,S2,S3,S4,S5,S6,S7/.2499580570D14,.4244419664D12,
     *    .3733650367D10,.2245904002D8,.1020426050D6,.3549632885D3,1.D0/
      IF(X.LT.8.)THEN
        Y=X**2
        BESSY1=X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))))/(S1+Y*(S2+Y*
     *      (S3+Y*(S4+Y*(S5+Y*(S6+Y*S7))))))+.636619772
     *      *(BESSJ1(X)*LOG(X)-1./X)
      ELSE
        Z=8./X
        Y=Z**2
        XX=X-2.356194491
        BESSY1=SQRT(.636619772/X)*(SIN(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y
     *      *P5))))+Z*COS(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))))
      ENDIF
      RETURN
      END


	SUBROUTINE GG_ARC ( sys, xcent, ycent, xcrm, ycrm, npts,
     +			    ang1, ang2, iaccf, xout, yout, iret )
C************************************************************************
C* GG_ARC								*
C*									*
C* This routine computes the points around an arc. The center and the	*
C* point on the radius can be any coordinate system. The output points	*
C* will be in the same coordinates. If the points are in Map		*
C* coordinates, then the angles are degrees from North. For all other	*
C* coordinates, the angles are oriented with 0 degrees along the	*
C* X axis. The accuracy factor controls the amount of "course		*
C* correction" that is applied to the lat/lon point calculation. A	*
C* value of 0 means that the true great arc calculation is performed.	*
C* A value larger than 0 is the number of intermediary points to 	*
C* compute along the radial distance.					*
C*									*
C* GG_ARC ( SYS, XCENT, YCENT, XCRM, YCRM, NPTS, ANG1, ANG2, IACCF,	*
C*	    XOUT, YOUT,	IRET )						*
C*									*
C* Input parameters:							*
C*	SYS		CHAR*		Coordinate system		*
C*					  'S' = screen coordinates	*
C*					  'D' = device coordinates	*
C*					  'N' = normalized coordinates	*
C*					  'V' = view coordinates	*
C*					  'P' = plot coordinates	*
C*					  'M' = map coordinates		*
C*					  'G' = grid coordinates	*
C*	XCENT		REAL		X / Lat of center point		*
C*	YCENT		REAL		Y / Lon of center point		*
C*	XCRM		REAL		X / Lat of radius point		*
C*	YCRM		REAL		Y / Lon of radius point		*
C*	NPTS		INTEGER		Number of points on arc		*
C*	ANG1		REAL		Start angle			*
C*					  North relative for M coord	*
C*	ANG2		REAL		End angle			*
C*					  North relative for M coord	*
C*	IACCF		INTEGER		Accuracy factor for M coord	*
C*									*
C* Output parameters:							*
C*	XOUT(*)		REAL		X / Lat of output points	*
C*	YOUT(*)		REAL		Y / Lon of output points	*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* S. Jacobs/NCEP	 5/01	Created					*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	sys
	REAL		xout (*), yout (*)
C*
	CHARACTER	sysuc*1
C------------------------------------------------------------------------
	iret = 0
C*
	np = npts
	IF  ( np .lt. 2 )  np = 2
C
C*	Compute the arc in Map coordinates.
C
	CALL ST_LCUC ( sys, sysuc, ier )
	IF  ( sysuc .eq. 'M' )  THEN
	    dtheta = ang2 - ang1
	    IF  ( ABS (dtheta) .gt. 360. )  dtheta = 360.
C
	    thta = dtheta / FLOAT ( np - 1 )
C
	    nn = 1
	    CALL CLO_DIST ( xcent, ycent, nn, xcrm, ycrm, dist, ier )
C
	    IF  ( iaccf .gt. 100 )  THEN
	    	jaccf = 100
	      ELSE IF  ( iaccf .lt. 0 )  THEN
	    	jaccf = 1
	      ELSE
		jaccf = iaccf + 1
	    END IF
C
	    DO  i = 1, np
	    	dir = ang1 + thta * (i-1)
		xx = xcent
		yy = ycent
		dst = dist / FLOAT (jaccf)
		DO  j = 1, jaccf
		    CALL CLO_DLTLN ( xx, yy, dst, dir,
     +				     xout(i), yout(i), ier )
		    xx = xout(i)
		    yy = yout(i)
		END DO
	    END DO
	  ELSE
C
C*	    Compute the arc in all other coordinates, by tranforming
C*	    to Normal coordinates.
C
	    CALL GTRANS ( sysuc, 'N', 1, xcent, ycent, xc, yc, ier )
	    CALL GTRANS ( sysuc, 'N', 1, xcrm, ycrm, xr, yr, ier )
C
	    theta1 = ang1 * DTR
	    theta2 = ang2 * DTR
	    dtheta = theta2 - theta1
	    IF  ( ABS (dtheta) .gt. TWOPI )  dtheta = TWOPI
C
	    thta = dtheta / FLOAT ( np - 1 )
C
	    dist = SQRT ( (xc-xr)**2 + (yc-yr)**2 )
C
	    DO  i = 1, np
	    	dir = theta1 + thta * (i-1)
	    	xout (i) = xc + dist * COS ( theta1 + dir )
	    	yout (i) = yc + dist * SIN ( theta1 + dir )
	    END DO
C
	    CALL GTRANS ( 'N', sysuc, np, xout, yout, xout, yout, ier )
	END IF
C*
	RETURN
	END


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes the mean yaw moment using the far-field momentum formulation for a finite depth
!   case according to equation 4.9 of R1
!
!  R1 Computation of Higher-Order Hydrodynamic Forces on Ships and Offshore Structures in Waves
!             http://dspace.mit.edu/bitstream/handle/1721.1/79979/42664020.pdf?sequence=1
!
! Contest Drift forces and QTF Implementation of Nemoh
!
!
! Changes in version 1.1 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency
!
! Changes in version 1.2 (Dipoles Implementation in NEMOH)
!       Switch from ParamsCommon to ParamsCommonInf
!
!   @author yedtoss
!   @version 1.2

module COMPUTE_YAW_MOMENT_FIN

    USE COMMON_TYPE
    USE COM_VAR
    USE UTILITY
    USE KOCHIN

    implicit none

contains

    complex function diff_func_yaw_finite(theta, param)
        ! Simple wrapper to the kochin function
        USE KOCHIN

        REAL, INTENT(IN) :: theta
        COMPLEX:: fx
        TYPE(ParamsCommonInf) :: param

        CALL COMPUTE_KOCHIN(param%kwave, theta, fx, param%SolverVar)
        diff_func_yaw_finite = fx

    end function diff_func_yaw_finite

    complex function yawintegralfin_mz(theta, param)
        ! Derivative of the kochin function multiplied the the conjugate of the value of kochin function at theta

        USE KOCHIN
        REAL, INTENT(IN) :: theta
        COMPLEX :: yawintegral_mz
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        yawintegralfin_mz = CONJG(HKochin)*deriv_richardson_complex(diff_func_yaw_finite,theta, 1, 1e-3, param)

    end function yawintegralfin_mz

    subroutine compute_yaw_moment_finite(param, yaw_moment)
        ! This is the main subrouting computing the yaw moment
        ! It use romberg_trap_complex to integrate the function yawintegralfin_mz
        ! and deriv_richardson_complex to find the derivative of the diff_func_yaw_finite

        REAL :: PI
        TYPE(ParamsCommonInf) :: param ! input parameter
        REAL :: yaw_moment ! output
        REAL :: const
        REAL :: m0
        REAL :: CgC
        REAL:: Z
        REAL:: tmp

        PI=4.*ATAN(1.)

        m0 = param%AMH

        Cgc = 0.5*(1 + 2*m0*Depth/sinh(2*m0*Depth))

        Z = (m0**2-param%kwave**2)/(param%kwave**2*Depth-m0**2*Depth-param%kwave)*cosh(m0*Depth)**2

        const = -(RHO*G*param%AKH**2/m0)*CgC

        yaw_moment = const*(Z**2/(4*PI)*AIMAG(romberg_trap_complex(yawintegralfin_mz, 0., 2*PI, 1e-3, 2, param)))

        tmp = const*(-0.5*REAL(deriv_richardson_complex(diff_func_yaw_finite,PI+param%beta, 1, 1e-3, param)))

        yaw_moment = yaw_moment + tmp

    end subroutine compute_yaw_moment_finite
end module COMPUTE_YAW_MOMENT_FIN


      SUBROUTINE SEULEX(N,FCN,IFCN,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JAC ,IJAC,MLJAC,MUJAC,
     &                  MAS ,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C ----------------------------------------------------------
C     NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC)
C     SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS  MY'=F(X,Y).
C     THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE
C     LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL
C     AND ORDER SELECTION).
C
C     AUTHORS: E. HAIRER AND G. WANNER
C              UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
C              CH-1211 GENEVE 24, SWITZERLAND
C              E-MAIL:  Ernst.Hairer@math.unige.ch
C                       Gerhard.Wanner@math.unige.ch
C              INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN
C
C     THIS CODE IS PART OF THE BOOK:
C         E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
C         EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
C         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14,
C         SPRINGER-VERLAG 1991, SECOND EDITION 1996.
C
C     VERSION OF SEPTEMBER 30, 1995
C         SMALL CORRECTIONS ON JUNE 11, 1999
C
C     INPUT PARAMETERS
C     ----------------
C     N           DIMENSION OF THE SYSTEM
C
C     FCN         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
C                 VALUE OF F(X,Y):
C                    SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
C                    DOUBLE PRECISION X,Y(N),F(N)
C                    F(1)=...   ETC.
C                 RPAR, IPAR (SEE BELOW)
C
C     IFCN        GIVES INFORMATION ON FCN:
C                    IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS)
C                    IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS)
C
C     X           INITIAL X-VALUE
C
C     Y(N)        INITIAL VALUES FOR Y
C
C     XEND        FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
C
C     H           INITIAL STEP SIZE GUESS;
C                 FOR STIFF EQUATIONS WITH INITIAL TRANSIENT,
C                 H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD.
C                 THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY
C                 ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6).
C
C     RTOL,ATOL   RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
C                 CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
C
C     ITOL        SWITCH FOR RTOL AND ATOL:
C                   ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
C                     THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
C                     Y(I) BELOW RTOL*ABS(Y(I))+ATOL
C                   ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
C                     THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
C                     RTOL(I)*ABS(Y(I))+ATOL(I).
C
C     JAC         NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
C                 THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y
C                 (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY
C                 A DUMMY SUBROUTINE IN THE CASE IJAC=0).
C                 FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM
C                    SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR)
C                    DOUBLE PRECISION X,Y(N),DFY(LDFY,N)
C                    DFY(1,1)= ...
C                 LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS
C                 FURNISHED BY THE CALLING PROGRAM.
C                 IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO
C                    BE FULL AND THE PARTIAL DERIVATIVES ARE
C                    STORED IN DFY AS
C                       DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J)
C                 ELSE, THE JACOBIAN IS TAKEN AS BANDED AND
C                    THE PARTIAL DERIVATIVES ARE STORED
C                    DIAGONAL-WISE AS
C                       DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J).
C
C     IJAC        SWITCH FOR THE COMPUTATION OF THE JACOBIAN:
C                    IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE
C                       DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED.
C                    IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC.
C
C     MLJAC       SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN:
C                    MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR
C                       ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
C                    0<=MLJAC<N: MLJAC IS THE LOWER BANDWITH OF JACOBIAN
C                       MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
C                       THE MAIN DIAGONAL).
C
C     MUJAC       UPPER BANDWITH OF JACOBIAN  MATRIX (>= NUMBER OF NON-
C                 ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
C                 NEED NOT BE DEFINED IF MLJAC=N.
C
C     ----   MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS      -----
C     ----   FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): -
C
C     MAS         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS-
C                 MATRIX M.
C                 IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY
C                 MATRIX AND NEEDS NOT TO BE DEFINED;
C                 SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
C                 IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM
C                    SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR)
C                    DOUBLE PRECISION AM(LMAS,N)
C                    AM(1,1)= ....
C                    IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED
C                    AS FULL MATRIX LIKE
C                         AM(I,J) = M(I,J)
C                    ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED
C                    DIAGONAL-WISE AS
C                         AM(I-J+MUMAS+1,J) = M(I,J).
C
C     IMAS       GIVES INFORMATION ON THE MASS-MATRIX:
C                    IMAS=0: M IS SUPPOSED TO BE THE IDENTITY
C                       MATRIX, MAS IS NEVER CALLED.
C                    IMAS=1: MASS-MATRIX  IS SUPPLIED.
C
C     MLMAS       SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX:
C                    MLMAS=N: THE FULL MATRIX CASE. THE LINEAR
C                       ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
C                    0<=MLMAS<N: MLMAS IS THE LOWER BANDWITH OF THE
C                       MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
C                       THE MAIN DIAGONAL).
C                 MLMAS IS SUPPOSED TO BE .LE. MLJAC.
C
C     MUMAS       UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON-
C                 ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
C                 NEED NOT BE DEFINED IF MLMAS=N.
C                 MUMAS IS SUPPOSED TO BE .LE. MUJAC.
C
C     SOLOUT      NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
C                 NUMERICAL SOLUTION DURING INTEGRATION.
C                 IF IOUT>=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
C                 SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
C                 IT MUST HAVE THE FORM
C                    SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N,
C                                       RPAR,IPAR,IRTRN)
C                    DOUBLE PRECISION X,Y(N),RC(LRC),IC(LIC)
C                    ....
C                 SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
C                    GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
C                    THE FIRST GRID-POINT).
C                 "XOLD" IS THE PRECEEDING GRID-POINT.
C                 "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
C                    IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM.
C                 DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)!
C
C          -----  CONTINUOUS OUTPUT (IF IOUT=2): -----
C                 DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION
C                 FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH
C                 THE DOUBLE PRECISION FUNCTION
C                        >>>   SCONTEX(I,S,RC,LRC,IC,LIC)   <<<
C                 WHICH PROVIDES AN APPROXIMATION TO THE I-TH
C                 COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE
C                 S SHOULD LIE IN THE INTERVAL [XOLD,X].
C
C     IOUT        GIVES INFORMATION ON THE SUBROUTINE SOLOUT:
C                    IOUT=0: SUBROUTINE IS NEVER CALLED
C                    IOUT=1: SUBROUTINE IS USED FOR OUTPUT
C                    IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT
C
C     WORK        ARRAY OF WORKING SPACE OF LENGTH "LWORK".
C                 SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES.
C                 "LWORK" MUST BE AT LEAST
C                        N*(LJAC+LMAS+LE1+KM+8)+4*KM+20+KM2*NRDENS
C                 WHERE
C                    KM2=2+KM*(KM+3)/2  AND  NRDENS=IWORK(6) (SEE BELOW)
C                 AND
C                    LJAC=N              IF MLJAC=N (FULL JACOBIAN)
C                    LJAC=MLJAC+MUJAC+1  IF MLJAC<N (BANDED JAC.)
C                 AND
C                    LMAS=0              IF IMAS=0
C                    LMAS=N              IF IMAS=1 AND MLMAS=N (FULL)
C                    LMAS=MLMAS+MUMAS+1  IF MLMAS<N (BANDED MASS-M.)
C                 AND
C                    LE1=N               IF MLJAC=N (FULL JACOBIAN)
C                    LE1=2*MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.).
C                 AND
C                    KM=12               IF IWORK(3)=0
C                    KM=IWORK(3)         IF IWORK(3).GT.0
C
C                 IN THE USUAL CASE WHERE THE JACOBIAN IS FULL AND THE
C                 MASS-MATRIX IS THE INDENTITY (IMAS=0), THE MINIMUM
C                 STORAGE REQUIREMENT IS
C                         LWORK = 2*N*N+(KM+8)*N+4*KM+13+KM2*NRDENS.
C                 IF IWORK(9)=M1>0 THEN "LWORK" MUST BE AT LEAST
C                    N*(LJAC+KM+8)+(N-M1)*(LMAS+LE1)+4*KM+20+KM2*NRDENS
C                 WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE1 THE
C                 NUMBER N CAN BE REPLACED BY N-M1.
C
C     LWORK       DECLARED LENGTH OF ARRAY "WORK".
C
C     IWORK       INTEGER WORKING SPACE OF LENGTH "LIWORK".
C                 "LIWORK" MUST BE AT LEAST  2*N+KM+20+NRDENS.
C
C     LIWORK      DECLARED LENGTH OF ARRAY "IWORK".
C
C     RPAR, IPAR  REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH
C                 CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING
C                 PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES.
C
C ----------------------------------------------------------------------
C
C     SOPHISTICATED SETTING OF PARAMETERS
C     -----------------------------------
C              SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK
C              WELL. THEY MAY BE DEFINED BY SETTING WORK(1),..,WORK(13)
C              AS WELL AS IWORK(1),..,IWORK(4) DIFFERENT FROM ZERO.
C              FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES:
C
C    IWORK(1)  IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN
C              MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY
C              ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN.
C              IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC<N)
C              AND NOT FOR IMPLICIT SYSTEMS (IMAS=1).
C
C    IWORK(2)  THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
C              THE DEFAULT VALUE (FOR IWORK(2)=0) IS 100000.
C
C    IWORK(3)  THE MAXIMUM NUMBER OF COLUMNS IN THE EXTRAPOLATION
C              TABLE. THE DEFAULT VALUE (FOR IWORK(3)=0) IS 12.
C              IF IWORK(3).NE.0 THEN IWORK(3) SHOULD BE .GE.3.
C
C    IWORK(4)  SWITCH FOR THE STEP SIZE SEQUENCE
C              IF IWORK(4).EQ.1 THEN 1,2,3,4,6,8,12,16,24,32,48,...
C              IF IWORK(4).EQ.2 THEN 2,3,4,6,8,12,16,24,32,48,64,...
C              IF IWORK(4).EQ.3 THEN 1,2,3,4,5,6,7,8,9,10,...
C              IF IWORK(4).EQ.4 THEN 2,3,4,5,6,7,8,9,10,11,...
C              THE DEFAULT VALUE (FOR IWORK(4)=0) IS IWORK(4)=2.
C
C    IWORK(5)  PARAMETER "LAMBDA" OF DENSE OUTPUT; POSSIBLE VALUES
C              ARE 0 AND 1; DEFAULT IWORK(5)=0.
C
C    IWORK(6)  = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT
C              IS REQUIRED
C
C    IWORK(21),...,IWORK(NRDENS+20) INDICATE THE COMPONENTS, FOR WHICH
C              DENSE OUTPUT IS REQUIRED
C
C       IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT
C            Y(I)' = Y(I+M2)   FOR  I=1,...,M1,
C       WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME
C       CAN BE ACHIEVED BY SETTING THE PARAMETERS IWORK(9) AND IWORK(10).
C       E.G., FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE
C       VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2.
C       FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS:
C       - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE
C              JACOBIAN HAVE TO BE STORED
C              IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL
C                 DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J)
C                FOR I=1,N-M1 AND J=1,N.
C              ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM )
C                 DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2)
C                FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM.
C       - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL
C                0<=MLJAC<N-M1: IF THE (MM+1) SUBMATRICES (FOR K=0,MM)
C                     PARTIAL F(I+M1) / PARTIAL Y(J+K*M2),  I,J=1,M2
C                    ARE BANDED, MLJAC IS THE MAXIMAL LOWER BANDWIDTH
C                    OF THESE MM+1 SUBMATRICES
C       - MUJAC: MAXIMAL UPPER BANDWIDTH OF THESE MM+1 SUBMATRICES
C                NEED NOT BE DEFINED IF MLJAC=N-M1
C       - MAS: IF IMAS=0 THIS MATRIX IS ASSUMED TO BE THE IDENTITY AND
C              NEED NOT BE DEFINED. SUPPLY A DUMMY SUBROUTINE IN THIS CASE.
C              IT IS ASSUMED THAT ONLY THE ELEMENTS OF RIGHT LOWER BLOCK OF
C              DIMENSION N-M1 DIFFER FROM THAT OF THE IDENTITY MATRIX.
C              IF (MLMAS.EQ.N-M1) THIS SUBMATRIX IS SUPPOSED TO BE FULL
C                 AM(I,J) = M(I+M1,J+M1)     FOR I=1,N-M1 AND J=1,N-M1.
C              ELSE, THE MASS MATRIX IS BANDED
C                 AM(I-J+MUMAS+1,J) = M(I+M1,J+M1)
C       - MLMAS: MLMAS=N-M1: IF THE NON-TRIVIAL PART OF M IS FULL
C                0<=MLMAS<N-M1: LOWER BANDWIDTH OF THE MASS MATRIX
C       - MUMAS: UPPER BANDWIDTH OF THE MASS MATRIX
C                NEED NOT BE DEFINED IF MLMAS=N-M1
C
C    IWORK(9)  THE VALUE OF M1.  DEFAULT M1=0.
C
C    IWORK(10) THE VALUE OF M2.  DEFAULT M2=M1.
C
C    WORK(1)   UROUND, THE ROUNDING UNIT, DEFAULT 1.D-16.
C
C    WORK(2)   MAXIMAL STEP SIZE, DEFAULT XEND-X.
C
C    WORK(3)   DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED;
C              INCREASE WORK(3), TO 0.01 SAY, WHEN JACOBIAN EVALUATIONS
C              ARE COSTLY. FOR SMALL SYSTEMS WORK(3) SHOULD BE SMALLER.
C              DEFAULT MIN(1.0D-4,RTOL(1))
C
C    WORK(4), WORK(5)   PARAMETERS FOR STEP SIZE SELECTION
C              THE NEW STEP SIZE FOR THE J-TH DIAGONAL ENTRY IS
C              CHOSEN SUBJECT TO THE RESTRICTION
C                 FACMIN/WORK(5) <= HNEW(J)/HOLD <= 1/FACMIN
C              WHERE FACMIN=WORK(4)**(1/(J-1))
C              DEFAULT VALUES: WORK(4)=0.1D0, WORK(5)=4.D0
C
C    WORK(6), WORK(7)   PARAMETERS FOR THE ORDER SELECTION
C              ORDER IS DECREASED IF    W(K-1) <= W(K)*WORK(6)
C              ORDER IS INCREASED IF    W(K) <= W(K-1)*WORK(7)
C              DEFAULT VALUES: WORK(6)=0.7D0, WORK(7)=0.9D0
C
C    WORK(8), WORK(9)   SAFETY FACTORS FOR STEP CONTROL ALGORITHM
C             HNEW=H*WORK(9)*(WORK(8)*TOL/ERR)**(1/(J-1))
C              DEFAULT VALUES: WORK(8)=0.8D0, WORK(9)=0.93D0
C
C    WORK(10), WORK(11), WORK(12), WORK(13)   ESTIMATED WORKS FOR
C             A CALL TO  FCN, JAC, DEC, SOL, RESPECTIVELY.
C             DEFAULT VALUES ARE: WORK(10)=1.D0, WORK(11)=5.D0,
C             WORK(12)=1.D0, WORK(13)=1.D0.
C
C-----------------------------------------------------------------------
C
C     OUTPUT PARAMETERS
C     -----------------
C     X           X-VALUE WHERE THE SOLUTION IS COMPUTED
C                 (AFTER SUCCESSFUL RETURN X=XEND)
C
C     Y(N)        SOLUTION AT X
C
C     H           PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
C
C     IDID        REPORTS ON SUCCESSFULNESS UPON RETURN:
C                   IDID=1  COMPUTATION SUCCESSFUL,
C                   IDID=-1 COMPUTATION UNSUCCESSFUL.
C
C   IWORK(14)  NFCN    NUMBER OF FUNCTION EVALUATIONS (THOSE FOR NUMERICAL
C                      EVALUATION OF THE JACOBIAN ARE NOT COUNTED)
C   IWORK(15)  NJAC    NUMBER OF JACOBIAN EVALUATIONS (EITHER ANALYTICALLY
C                      OR NUMERICALLY)
C   IWORK(16)  NSTEP   NUMBER OF COMPUTED STEPS
C   IWORK(17)  NACCPT  NUMBER OF ACCEPTED STEPS
C   IWORK(18)  NREJCT  NUMBER OF REJECTED STEPS (AFTER AT LEAST ONE STEP
C                      HAS BEEN ACCEPTED)
C   IWORK(19)  NDEC    NUMBER OF LU-DECOMPOSITIONS (N-DIMENSIONAL MATRIX)
C   IWORK(20)  NSOL    NUMBER OF FORWARD-BACKWARD SUBSTITUTIONS
C-----------------------------------------------------------------------
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C          DECLARATIONS
C *** *** *** *** *** *** *** *** *** *** *** *** ***
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),ATOL(*),RTOL(*),WORK(LWORK),IWORK(LIWORK)
      DIMENSION RPAR(*),IPAR(*)
      LOGICAL AUTNMS,IMPLCT,ARRET,JBAND
      EXTERNAL FCN,JAC,MAS,SOLOUT
C *** *** *** *** *** *** ***
C        SETTING THE PARAMETERS
C *** *** *** *** *** *** ***
      NFCN=0
      NJAC=0
      NSTEP=0
      NACCPT=0
      NREJCT=0
      NDEC=0
      NSOL=0
      ARRET=.FALSE.
C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
      IF(IWORK(2).EQ.0)THEN
         NMAX=100000
      ELSE
         NMAX=IWORK(2)
         IF(NMAX.LE.0)THEN
            WRITE(6,*)' WRONG INPUT IWORK(2)=',IWORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------- KM     MAXIMUM NUMBER OF COLUMNS IN THE EXTRAPOLATION
      IF(IWORK(3).EQ.0)THEN
         KM=12
      ELSE
         KM=IWORK(3)
         IF(KM.LE.2)THEN
            WRITE(6,*)' CURIOUS INPUT IWORK(3)=',IWORK(3)
            ARRET=.TRUE.
         END IF
      END IF
C -------- NSEQU     CHOICE OF STEP SIZE SEQUENCE
      NSEQU=IWORK(4)
      IF(IWORK(4).EQ.0) NSEQU=2
      IF(NSEQU.LE.0.OR.NSEQU.GE.5)THEN
         WRITE(6,*)' CURIOUS INPUT IWORK(4)=',IWORK(4)
         ARRET=.TRUE.
      END IF
C -------- LAMBDA   PARAMETER FOR DENSE OUTPUT
      LAMBDA=IWORK(5)
      IF(LAMBDA.LT.0.OR.LAMBDA.GE.2)THEN
         WRITE(6,*)' CURIOUS INPUT IWORK(5)=',IWORK(5)
         ARRET=.TRUE.
      END IF
C -------- NRDENS   NUMBER OF DENSE OUTPUT COMPONENTS
      NRDENS=IWORK(6)
      IF(NRDENS.LT.0.OR.NRDENS.GT.N)THEN
         WRITE(6,*)' CURIOUS INPUT IWORK(6)=',IWORK(6)
         ARRET=.TRUE.
      END IF
C -------- PARAMETER FOR SECOND ORDER EQUATIONS
      M1=IWORK(9)
      M2=IWORK(10)
      NM1=N-M1
      IF (M1.EQ.0) M2=N
      IF (M2.EQ.0) M2=M1
      IF (M1.LT.0.OR.M2.LT.0.OR.M1+M2.GT.N) THEN
       WRITE(6,*)' CURIOUS INPUT FOR IWORK(9,10)=',M1,M2
       ARRET=.TRUE.
      END IF
C -------- UROUND   SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0
      IF(WORK(1).EQ.0.D0)THEN
         UROUND=1.D-16
      ELSE
         UROUND=WORK(1)
         IF(UROUND.LE.0.D0.OR.UROUND.GE.1.D0)THEN
            WRITE(6,*)'  UROUND=',WORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- MAXIMAL STEP SIZE
      IF(WORK(2).EQ.0.D0)THEN
         HMAX=XEND-X
      ELSE
         HMAX=WORK(2)
      END IF
C ------ THET     DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED;
      IF(WORK(3).EQ.0.D0)THEN
         THET=MIN(1.0D-4,RTOL(1))
      ELSE
         THET=WORK(3)
      END IF
C -------  FAC1,FAC2     PARAMETERS FOR STEP SIZE SELECTION
      IF(WORK(4).EQ.0.D0)THEN
         FAC1=0.1D0
      ELSE
         FAC1=WORK(4)
      END IF
      IF(WORK(5).EQ.0.D0)THEN
         FAC2=4.0D0
      ELSE
         FAC2=WORK(5)
      END IF
C -------  FAC3, FAC4   PARAMETERS FOR THE ORDER SELECTION
      IF(WORK(6).EQ.0.D0)THEN
         FAC3=0.7D0
      ELSE
         FAC3=WORK(6)
      END IF
      IF(WORK(7).EQ.0.D0)THEN
         FAC4=0.9D0
      ELSE
         FAC4=WORK(7)
      END IF
C ------- SAFE1, SAFE2 SAFETY FACTORS FOR STEP SIZE PREDICTION
      IF(WORK(8).EQ.0.D0)THEN
         SAFE1=0.6D0
      ELSE
         SAFE1=WORK(8)
      END IF
      IF(WORK(9).EQ.0.D0)THEN
         SAFE2=0.93D0
      ELSE
         SAFE2=WORK(9)
      END IF
C ------- WKFCN,WKJAC,WKDEC,WKSOL  ESTIMATED WORK FOR  FCN,JAC,DEC,SOL
      IF(WORK(10).EQ.0.D0)THEN
         WKFCN=1.D0
      ELSE
         WKFCN=WORK(10)
      END IF
      IF(WORK(11).EQ.0.D0)THEN
         WKJAC=5.D0
      ELSE
         WKJAC=WORK(11)
      END IF
      IF(WORK(12).EQ.0.D0)THEN
         WKDEC=1.D0
      ELSE
         WKDEC=WORK(12)
      END IF
      IF(WORK(13).EQ.0.D0)THEN
         WKSOL=1.D0
      ELSE
         WKSOL=WORK(13)
      END IF
      WKROW=WKFCN+WKSOL
C --------- CHECK IF TOLERANCES ARE O.K.
      IF (ITOL.EQ.0) THEN
          IF (ATOL(1).LE.0.D0.OR.RTOL(1).LE.10.D0*UROUND) THEN
              WRITE (6,*) ' TOLERANCES ARE TOO SMALL'
              ARRET=.TRUE.
          END IF
      ELSE
        DO I=1,N
          IF (ATOL(I).LE.0.D0.OR.RTOL(I).LE.10.D0*UROUND) THEN
              WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL'
              ARRET=.TRUE.
          END IF
        END DO
      END IF
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C         COMPUTATION OF ARRAY ENTRIES
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C ---- AUTONOMOUS, IMPLICIT, BANDED OR NOT ?
      AUTNMS=IFCN.EQ.0
      IMPLCT=IMAS.NE.0
      JBAND=MLJAC.LT.NM1
C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS ---
C -- JACOBIAN AND MATRIX E
      IF(JBAND)THEN
         LDJAC=MLJAC+MUJAC+1
         LDE=MLJAC+LDJAC
      ELSE
         MLJAC=NM1
         MUJAC=NM1
         LDJAC=NM1
         LDE=NM1
      END IF
C -- MASS MATRIX
      IF (IMPLCT) THEN
          IF (MLMAS.NE.NM1) THEN
              LDMAS=MLMAS+MUMAS+1
              IF (JBAND) THEN
                 IJOB=4
              ELSE
                 IJOB=3
              END IF
          ELSE
              LDMAS=NM1
              IJOB=5
          END IF
C ------ BANDWITH OF "MAS" NOT LARGER THAN BANDWITH OF "JAC"
          IF (MLMAS.GT.MLJAC.OR.MUMAS.GT.MUJAC) THEN
              WRITE (6,*) 'BANDWITH OF "MAS" NOT LARGER THAN BANDWITH OF
     & "JAC"'
            ARRET=.TRUE.
          END IF
      ELSE
          LDMAS=0
          IF (JBAND) THEN
             IJOB=2
          ELSE
             IJOB=1
             IF (N.GT.2.AND.IWORK(1).NE.0) IJOB=7
          END IF
      END IF
      LDMAS2=MAX(1,LDMAS)
C ------ HESSENBERG OPTION ONLY FOR EXPLICIT EQU. WITH FULL JACOBIAN
      IF ((IMPLCT.OR.JBAND).AND.IJOB.EQ.7) THEN
         WRITE(6,*)' HESSENBERG OPTION ONLY FOR EXPLICIT EQUATIONS WITH
     &FULL JACOBIAN'
         ARRET=.TRUE.
      END IF
C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
      KM2=(KM*(KM+1))/2
      IEYH=21
      IEDY=IEYH+N
      IEFX=IEDY+N
      IEYHH=IEFX+N
      IEDYH=IEYHH+N
      IEDEL=IEDYH+N
      IEWH =IEDEL+N
      IESCAL=IEWH+N
      IEHH =IESCAL+N
      IEW  =IEHH+KM
      IEA  =IEW+KM
      IEJAC =IEA+KM
      IEE  =IEJAC+N*LDJAC
      IEMAS=IEE+NM1*LDE
      IET=IEMAS+NM1*LDMAS
      IFAC=IET+N*KM
      IEDE=IFAC+KM
      IFSAFE=IEDE+(KM+2)*NRDENS
C ------ TOTAL STORAGE REQUIREMENT -----------
      ISTORE=IFSAFE+KM2*NRDENS-1
      IF(ISTORE.GT.LWORK)THEN
         WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE
         ARRET=.TRUE.
      END IF
C ------- ENTRY POINTS FOR INTEGER WORKSPACE -----
      IECO=21
      IEIP=21+NRDENS
      IENJ=IEIP+N
      IEIPH=IENJ+KM
C --------- TOTAL REQUIREMENT ---------------
      ISTORE=IECO+KM-1
      IF(ISTORE.GT.LIWORK)THEN
         WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE
         ARRET=.TRUE.
      END IF
C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1
      IF (ARRET) THEN
         IDID=-1
         RETURN
      END IF
      NRD=MAX(1,NRDENS)
C -------- CALL TO CORE INTEGRATOR ------------
      CALL SEUCOR(N,FCN,X,Y,XEND,HMAX,H,KM,RTOL,ATOL,ITOL,JAC,IJAC,
     &   MLJAC,MUJAC,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID,IJOB,M1,M2,NM1,
     &   NMAX,UROUND,NSEQU,AUTNMS,IMPLCT,JBAND,LDJAC,LDE,LDMAS2,
     &   WORK(IEYH),WORK(IEDY),WORK(IEFX),WORK(IEYHH),WORK(IEDYH),
     &   WORK(IEDEL),WORK(IEWH),WORK(IESCAL),WORK(IEHH),
     &   WORK(IEW),WORK(IEA),WORK(IEJAC),WORK(IEE),WORK(IEMAS),
     &   WORK(IET),IWORK(IEIP),IWORK(IENJ),IWORK(IEIPH),FAC1,FAC2,FAC3,
     &   FAC4,THET,SAFE1,SAFE2,WKJAC,WKDEC,WKROW,KM2,NRD,WORK(IFAC),
     &   WORK(IFSAFE),LAMBDA,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL,
     &   RPAR,IPAR,WORK(IEDE),IWORK(IECO))
      IWORK(14)=NFCN
      IWORK(15)=NJAC
      IWORK(16)=NSTEP
      IWORK(17)=NACCPT
      IWORK(18)=NREJCT
      IWORK(19)=NDEC
      IWORK(20)=NSOL
C ----------- RETURN -----------
      RETURN
      END
C
C
C  ----- ... AND HERE IS THE CORE INTEGRATOR  ----------
C
      SUBROUTINE SEUCOR(N,FCN,X,Y,XEND,HMAX,H,KM,RTOL,ATOL,ITOL,
     &  JAC,IJAC,MLJAC,MUJAC,MAS,MLB,MUB,SOLOUT,IOUT,IDID,IJOB,M1,M2,
     &  NM1,NMAX,UROUND,NSEQU,AUTNMS,IMPLCT,BANDED,LFJAC,LE,
     &  LDMAS,YH,DY,FX,YHH,DYH,DEL,WH,SCAL,HH,W,A,FJAC,E,FMAS,T,IP,
     &  NJ,IPHES,FAC1,FAC2,FAC3,FAC4,THET,SAFE1,SAFE2,WKJAC,WKDEC,WKROW,
     &  KM2,NRD,FACUL,FSAFE,LAMBDA,NFCN,NJAC,NSTEP,NACCPT,NREJCT,
     &  NDEC,NSOL,RPAR,IPAR,DENS,ICOMP)
C ----------------------------------------------------------
C     CORE INTEGRATOR FOR SEULEX
C     PARAMETERS SAME AS IN SEULEX WITH WORKSPACE ADDED
C ----------------------------------------------------------
C         DECLARATIONS
C ----------------------------------------------------------
       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
       DIMENSION Y(N),YH(N),DY(N),FX(N),YHH(N),DYH(N),DEL(N)
       DIMENSION WH(N),SCAL(N),HH(KM),W(KM),A(KM),FJAC(LFJAC,N)
       DIMENSION FMAS(LDMAS,NM1),T(KM,N),IP(NM1),NJ(KM),RTOL(*),ATOL(*)
       DIMENSION IPHES(N),FSAFE(KM2,NRD),FACUL(KM),E(LE,NM1)
       DIMENSION DENS((KM+2)*NRD),ICOMP(NRD),RPAR(*),IPAR(*)
       LOGICAL REJECT,LAST,ATOV,CALJAC,CALHES,AUTNMS,IMPLCT,BANDED
       EXTERNAL FCN
       COMMON /COSEU/XOLDD,HHH,NNRD,KRIGHT
       COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG
C --- COMPUTE COEFFICIENTS FOR DENSE OUTPUT
       IF (IOUT.EQ.2) THEN
          NNRD=NRD
C --- COMPUTE THE FACTORIALS --------
          FACUL(1)=1.D0
          DO I=1,KM-1
             FACUL(I+1)=I*FACUL(I)
          END DO
       END IF
C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ----------
      IF (IMPLCT) CALL MAS(NM1,FMAS,LDMAS,RPAR,IPAR)
C *** *** *** *** *** *** ***
C  INITIALISATIONS
C *** *** *** *** *** *** ***
       LRDE=(KM+2)*NRD
       MLE=MLJAC
       MUE=MUJAC
       MBJAC=MLJAC+MUJAC+1
       MBB=MLB+MUB+1
       MDIAG=MLE+MUE+1
       MDIFF=MLE+MUE-MUB
       MBDIAG=MUB+1
       IF (M1.GT.0) IJOB=IJOB+10
C --- DEFINE THE STEP SIZE SEQUENCE
       IF (NSEQU.EQ.1) THEN
           NJ(1)=1
           NJ(2)=2
           NJ(3)=3
           DO I=4,KM
              NJ(I)=2*NJ(I-2)
           END DO
       END IF
       IF (NSEQU.EQ.2) THEN
           NJ(1)=2
           NJ(2)=3
           DO I=3,KM
              NJ(I)=2*NJ(I-2)
           END DO
       END IF
       DO I=1,KM
          IF (NSEQU.EQ.3) NJ(I)=I
          IF (NSEQU.EQ.4) NJ(I)=I+1
       END DO
       A(1)=WKJAC+NJ(1)*WKROW+WKDEC
       DO I=2,KM
          A(I)=A(I-1)+(NJ(I)-1)*WKROW+WKDEC
       END DO
       POSNEG=SIGN(1.D0,XEND-X)
       K=MAX0(2,MIN0(KM-2,INT(-DLOG10(RTOL(1)+ATOL(1))*.6D0+1.5D0)))
       HMAXN=MIN(ABS(HMAX),ABS(XEND-X))
       H=MAX(ABS(H),1.D-6)
       H=POSNEG*MIN(H,HMAXN)
       THETA=2*ABS(THET)
       IF (IOUT.NE.0) THEN
          IRTRN=1
          NRSOL=1
          XSOL=X
          DO I=1,N
            YH(I)=Y(I)
          END DO
          NSOLU=N
          XOLD=X
         CALL SOLOUT(NRSOL,XOLD,XSOL,YH,DENS,LRDE,ICOMP,NRD,NSOLU,
     &               RPAR,IPAR,IRTRN)
          IF (IRTRN.LT.0) GOTO 120
          IPT=0
       END IF
       ERR=0.D0
       W(1)=1.D30
       DO I=1,N
          IF (ITOL.EQ.0) THEN
            SCAL(I)=ATOL(1)+RTOL(1)*DABS(Y(I))
          ELSE
            SCAL(I)=ATOL(I)+RTOL(I)*DABS(Y(I))
          END IF
       END DO
       CALJAC=.FALSE.
       REJECT=.FALSE.
       LAST=.FALSE.
  10   CONTINUE
       IF (REJECT) THETA=2*ABS(THET)
       ATOV=.FALSE.
C *** *** *** *** *** *** ***
C --- IS XEND REACHED IN THE NEXT STEP?
C *** *** *** *** *** *** ***
       IF (0.1D0*ABS(XEND-X).LE.ABS(X)*UROUND) GO TO 110
       HOPT=H
       H=POSNEG*MIN(ABS(H),ABS(XEND-X),HMAXN)
       IF ((X+1.01D0*H-XEND)*POSNEG.GT.0.D0) THEN
          H=XEND-X
          LAST=.TRUE.
       END IF
       IF (AUTNMS) THEN
          CALL FCN(N,X,Y,DY,RPAR,IPAR)
          NFCN=NFCN+1
       END IF
       IF (THETA.GT.THET.AND..NOT.CALJAC) THEN
C *** *** *** *** *** *** ***
C  COMPUTATION OF THE JACOBIAN
C *** *** *** *** *** *** ***
          NJAC=NJAC+1
          IF (IJAC.EQ.0) THEN
C --- COMPUTE JACOBIAN MATRIX NUMERICALLY
              IF (.NOT.AUTNMS) CALL FCN(N,X,Y,DY,RPAR,IPAR)
              IF (BANDED) THEN
C --- JACOBIAN IS BANDED
                  MUJACP=MUJAC+1
                  MD=MIN(MBJAC,N)
                  DO MM=1,M1/M2+1
                     DO KX=1,MD
                        J=KX+(MM-1)*M2
 12                     YHH(J)=Y(J)
                        DEL(J)=DSQRT(UROUND*MAX(1.D-5,ABS(Y(J))))
                        Y(J)=Y(J)+DEL(J)
                        J=J+MD
                        IF (J.LE.MM*M2) GOTO 12
                        CALL FCN(N,X,Y,YH,RPAR,IPAR)
                        J=KX+(MM-1)*M2
                        J1=KX
                        LBEG=MAX(1,J1-MUJAC)+M1
 14                     LEND=MIN(M2,J1+MLJAC)+M1
                        Y(J)=YHH(J)
                        MUJACJ=MUJACP-J1-M1
                        DO L=LBEG,LEND
                           FJAC(L+MUJACJ,J)=(YH(L)-DY(L))/DEL(J)
                        END DO
                        J=J+MD
                        J1=J1+MD
                        LBEG=LEND+1
                        IF (J.LE.MM*M2) GOTO 14
                     END DO
                  END DO
               ELSE
C --- JACOBIAN IS FULL
                  DO I=1,N
                     YSAFE=Y(I)
                     DELT=DSQRT(UROUND*MAX(1.D-5,ABS(YSAFE)))
                     Y(I)=YSAFE+DELT
                     CALL FCN(N,X,Y,YH,RPAR,IPAR)
                     DO J=M1+1,N
                       FJAC(J-M1,I)=(YH(J)-DY(J))/DELT
                     END DO
                     Y(I)=YSAFE
                     MLJAC=NM1
                  END DO
               END IF
            ELSE
C --- COMPUTE JACOBIAN MATRIX ANALYTICALLY
               CALL JAC(N,X,Y,FJAC,LFJAC,RPAR,IPAR)
           END IF
           CALJAC=.TRUE.
           CALHES=.TRUE.
       END IF
C *** *** *** *** *** *** ***
C --- THE FIRST AND LAST STEP
C *** *** *** *** *** *** ***
      IF (NSTEP.EQ.0.OR.LAST) THEN
        IPT=0
        NSTEP=NSTEP+1
        DO J=1,K
         KC=J
         CALL SEUL(J,N,FCN,X,Y,DY,FX,FJAC,LFJAC,FMAS,LDMAS,E,LE,IP,H,KM,
     &             HMAXN,T,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,SAFE1,FAC,
     &             FAC1,FAC2,SAFE2,THETA,MLJAC,MUJAC,NFCN,NDEC,NSOL,MLB,
     &             MUB,ERROLD,IPHES,ICOMP,AUTNMS,IMPLCT,BANDED,REJECT,
     &             ATOV,FSAFE,KM2,NRD,IOUT,IPT,M1,M2,NM1,IJOB,CALHES,
     &             RPAR,IPAR)
         IF (ATOV) GOTO 10
         IF (J.GT.1.AND.ERR.LE.1.D0) GO TO 60
        END DO
        GO TO 55
      END IF
C --- BASIC INTEGRATION STEP
  30  CONTINUE
      IPT=0
      NSTEP=NSTEP+1
      IF (NSTEP.GE.NMAX) GO TO 120
      KC=K-1
      DO J=1,KC
       CALL SEUL(J,N,FCN,X,Y,DY,FX,FJAC,LFJAC,FMAS,LDMAS,E,LE,IP,H,KM,
     &           HMAXN,T,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,SAFE1,
     &           FAC,FAC1,FAC2,SAFE2,THETA,MLJAC,MUJAC,NFCN,NDEC,NSOL,
     &           MLB,MUB,ERROLD,IPHES,ICOMP,AUTNMS,IMPLCT,BANDED,REJECT,
     &           ATOV,FSAFE,KM2,NRD,IOUT,IPT,M1,M2,NM1,IJOB,CALHES,
     &           RPAR,IPAR)
       IF (ATOV) GOTO 10
      END DO
C *** *** *** *** *** *** ***
C --- CONVERGENCE MONITOR
C *** *** *** *** *** *** ***
      IF (K.EQ.2.OR.REJECT) GO TO 50
      IF (ERR.LE.1.D0) GO TO 60
      IF (ERR.GT.DBLE(NJ(K+1)*NJ(K))*4.D0) GO TO 100
  50  CALL SEUL(K,N,FCN,X,Y,DY,FX,FJAC,LFJAC,FMAS,LDMAS,E,LE,IP,H,KM,
     &           HMAXN,T,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,SAFE1,
     &           FAC,FAC1,FAC2,SAFE2,THETA,MLJAC,MUJAC,NFCN,NDEC,NSOL,
     &           MLB,MUB,ERROLD,IPHES,ICOMP,AUTNMS,IMPLCT,BANDED,REJECT,
     &           ATOV,FSAFE,KM2,NRD,IOUT,IPT,M1,M2,NM1,IJOB,CALHES,
     &           RPAR,IPAR)
      IF (ATOV) GOTO 10
      KC=K
      IF (ERR.LE.1.D0) GO TO 60
C --- HOPE FOR CONVERGENCE IN LINE K+1
  55  IF (ERR.GT.DBLE(NJ(K+1))*2.D0) GO TO 100
      KC=K+1
      CALL SEUL(KC,N,FCN,X,Y,DY,FX,FJAC,LFJAC,FMAS,LDMAS,E,LE,IP,H,KM,
     &           HMAXN,T,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,SAFE1,
     &           FAC,FAC1,FAC2,SAFE2,THETA,MLJAC,MUJAC,NFCN,NDEC,NSOL,
     &           MLB,MUB,ERROLD,IPHES,ICOMP,AUTNMS,IMPLCT,BANDED,REJECT,
     &           ATOV,FSAFE,KM2,NRD,IOUT,IPT,M1,M2,NM1,IJOB,CALHES,
     &           RPAR,IPAR)
      IF (ATOV) GOTO 10
      IF (ERR.GT.1.D0) GO TO 100
C *** *** *** *** *** *** ***
C --- STEP IS ACCEPTED
C *** *** *** *** *** *** ***
  60  XOLD=X
      X=X+H
      IF (IOUT.EQ.2) THEN
         KRIGHT=KC
         DO I=1,NRD
            DENS(I)=Y(ICOMP(I))
         END DO
      END IF
      DO I=1,N
         T1I=T(1,I)
         IF (ITOL.EQ.0) THEN
            SCAL(I)=ATOL(1)+RTOL(1)*DABS(T1I)
         ELSE
            SCAL(I)=ATOL(I)+RTOL(I)*DABS(T1I)
         END IF
         Y(I)=T1I
      END DO
      NACCPT=NACCPT+1
      CALJAC=.FALSE.
      IF (IOUT.EQ.2) THEN
         XOLDD=XOLD
         HHH=H
         DO I=1,NRD
            DENS(NRD+I)=Y(ICOMP(I))
         END DO
         DO KLR=1,KRIGHT-1
C --- COMPUTE DIFFERENCES
            IF (KLR.GE.2) THEN
               DO KK=KLR,KC
                  LBEG=((KK+1)*KK)/2
                  LEND=LBEG-KK+2
                  DO L=LBEG,LEND,-1
                     DO I=1,NRD
                        FSAFE(L,I)=FSAFE(L,I)-FSAFE(L-1,I)
                     END DO
                  END DO
               END DO
             END IF
C --- COMPUTE DERIVATIVES AT RIGHT END ----
             DO KK=KLR+LAMBDA,KC
                FACNJ=NJ(KK)
                FACNJ=FACNJ**KLR/FACUL(KLR+1)
                IPT=((KK+1)*KK)/2
                DO  I=1,NRD
                   KRN=(KK-LAMBDA+1)*NRD
                   DENS(KRN+I)=FSAFE(IPT,I)*FACNJ
                END DO
             END DO
             DO J=KLR+LAMBDA+1,KC
               DBLENJ=NJ(J)
               DO L=J,KLR+LAMBDA+1,-1
                 FACTOR=DBLENJ/NJ(L-1)-1.D0
                 DO I=1,NRD
                   KRN=(L-LAMBDA+1)*NRD+I
                   DENS(KRN-NRD)=DENS(KRN)
     &                          +(DENS(KRN)-DENS(KRN-NRD))/FACTOR
                 END DO
               END DO
             END DO
         END DO
C ---  COMPUTE THE COEFFICIENTS OF THE INTERPOLATION POLYNOMIAL
         DO IN=1,NRD
            DO J=1,KRIGHT
               II=NRD*J+IN
               DENS(II)=DENS(II)-DENS(II-NRD)
            END DO
         END DO
      END IF
      IF (IOUT.NE.0) THEN
         IRTRN=1
         NRSOL=NACCPT+1
         XSOL=X
         DO I=1,N
            YH(I)=Y(I)
         END DO
         NSOLU=N
         CALL SOLOUT(NRSOL,XOLD,XSOL,YH,DENS,LRDE,ICOMP,NRD,NSOLU,
     &               RPAR,IPAR,IRTRN)
         IF (IRTRN.LT.0) GOTO 120
      END IF
C --- COMPUTE OPTIMAL ORDER
      IF (KC.EQ.2) THEN
         KOPT=MIN(3,KM-1)
         IF (REJECT) KOPT=2
         GO TO 80
      END IF
      IF (KC.LE.K) THEN
         KOPT=KC
         IF (W(KC-1).LT.W(KC)*FAC3) KOPT=KC-1
         IF (W(KC).LT.W(KC-1)*FAC4) KOPT=MIN0(KC+1,KM-1)
      ELSE
         KOPT=KC-1
         IF (KC.GT.3.AND.W(KC-2).LT.W(KC-1)*FAC3) KOPT=KC-2
         IF (W(KC).LT.W(KOPT)*FAC4) KOPT=MIN0(KC,KM-1)
      END IF
C --- AFTER A REJECTED STEP
  80  IF (REJECT) THEN
         K=MIN0(KOPT,KC)
         H=POSNEG*MIN(ABS(H),ABS(HH(K)))
         REJECT=.FALSE.
         GO TO 10
      END IF
C --- COMPUTE STEP SIZE FOR NEXT STEP
      IF (KOPT.LE.KC) THEN
         H=HH(KOPT)
      ELSE
         IF (KC.LT.K.AND.W(KC).LT.W(KC-1)*FAC4) THEN
            H=HH(KC)*A(KOPT+1)/A(KC)
         ELSE
            H=HH(KC)*A(KOPT)/A(KC)
         END IF
      END IF
      K=KOPT
      H=POSNEG*ABS(H)
      GO TO 10
C *** *** *** *** *** *** ***
C --- STEP IS REJECTED
C *** *** *** *** *** *** ***
 100  K=MIN(K,KC,KM-1)
      IF (K.GT.2.AND.W(K-1).LT.W(K)*FAC3) K=K-1
      NREJCT=NREJCT+1
      H=POSNEG*HH(K)
      LAST=.FALSE.
      REJECT=.TRUE.
      IF (CALJAC) GOTO 30
      GO TO 10
C --- SOLUTION EXIT
 110  CONTINUE
      H=HOPT
      IDID=1
      RETURN
C --- FAIL EXIT
 120  WRITE (6,979) X,H
 979  FORMAT(' EXIT OF SEULEX AT X=',D14.7,'   H=',D14.7)
      IDID=-1
      RETURN
      END
C
C
C *** *** *** *** *** *** ***
C     S U B R O U T I N E    S E U L
C *** *** *** *** *** *** ***
C
      SUBROUTINE SEUL(JJ,N,FCN,X,Y,DY,FX,FJAC,LFJAC,FMAS,LDMAS,E,LE,IP,
     &          H,KM,HMAXN,T,SCAL,NJ,HH,W,A,YH,DYH,DEL,WH,ERR,SAFE1,
     &          FAC,FAC1,FAC2,SAFE2,THETA,MLJAC,MUJAC,NFCN,NDEC,NSOL,
     &          MLB,MUB,ERROLD,IPHES,ICOMP,
     &          AUTNMS,IMPLCT,BANDED,REJECT,ATOV,FSAFE,KM2,NRD,IOUT,
     &          IPT,M1,M2,NM1,IJOB,CALHES,RPAR,IPAR)
C --- THIS SUBROUTINE COMPUTES THE J-TH LINE OF THE
C --- EXTRAPOLATION TABLE AND PROVIDES AN ESTIMATE
C --- OF THE OPTIMAL STEP SIZE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),YH(N),DY(N),FX(N),DYH(N),DEL(N)
      DIMENSION WH(N),SCAL(N),HH(KM),W(KM),A(KM),FJAC(LFJAC,N),E(LE,N)
      DIMENSION FMAS(LDMAS,N),T(KM,N),IP(N),NJ(KM),IPHES(N)
      DIMENSION FSAFE(KM2,NRD),ICOMP(NRD),RPAR(*),IPAR(*)
      LOGICAL ATOV,REJECT,AUTNMS,IMPLCT,BANDED,CALHES
      COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG
C *** *** *** *** *** *** ***
C  COMPUTE THE MATRIX E AND ITS DECOMPOSITION
C *** *** *** *** *** *** ***
      HJ=H/NJ(JJ)
      HJI=1.D0/HJ
      CALL DECOMR(N,FJAC,LFJAC,FMAS,LDMAS,MLB,MUB,
     &            M1,M2,NM1,HJI,E,LE,IP,IER,IJOB,CALHES,IPHES)
      IF (IER.NE.0) GOTO 79
      NDEC=NDEC+1
C *** *** *** *** *** *** ***
C --- STARTING PROCEDURE
C *** *** *** *** *** *** ***
       IF (.NOT.AUTNMS) THEN
          CALL FCN(N,X+HJ,Y,DY,RPAR,IPAR)
          NFCN=NFCN+1
       END IF
       DO I=1,N
          YH(I)=Y(I)
          DEL(I)=DY(I)
       END DO
       CALL SLVSEU(N,FJAC,LFJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS,
     &          M1,M2,NM1,HJI,E,LE,IP,IPHES,DEL,IJOB)
       NSOL=NSOL+1
       M=NJ(JJ)
       IF (IOUT.EQ.2.AND.M.EQ.JJ) THEN
          IPT=IPT+1
          DO I=1,NRD
             FSAFE(IPT,I)=DEL(ICOMP(I))
          END DO
       END IF
C *** *** *** *** *** *** ***
C --- SEMI-IMPLICIT EULER METHOD
C *** *** *** *** *** *** ***
       IF (M.GT.1) THEN
          DO MM=1,M-1
             DO I=1,N
                YH(I)=YH(I)+DEL(I)
             END DO
             IF (AUTNMS) THEN
                CALL FCN(N,X+HJ*MM,YH,DYH,RPAR,IPAR)
             ELSE
                CALL FCN(N,X+HJ*(MM+1),YH,DYH,RPAR,IPAR)
             END IF
             NFCN=NFCN+1
             IF (MM.EQ.1.AND.JJ.LE.2) THEN
C --- STABILITY CHECK
                DEL1=0.D0
                DO I=1,N
                   DEL1=DEL1+(DEL(I)/SCAL(I))**2
                END DO
                DEL1=DSQRT(DEL1)
                IF (IMPLCT) THEN
                   DO I=1,NM1
                      WH(I)=DEL(I+M1)
                   END DO
                   IF (MLB.EQ.NM1) THEN
                      DO I=1,NM1
                         SUM=0.D0
                         DO J=1,NM1
                            SUM=SUM+FMAS(I,J)*WH(J)
                         END DO
                         DEL(I+M1)=SUM
                      END DO
                   ELSE
                      DO I=1,NM1
                         SUM=0.D0
                         DO J=MAX(1,I-MLB),MIN(NM1,I+MUB)
                            SUM=SUM+FMAS(I-J+MBDIAG,J)*WH(J)
                         END DO
                         DEL(I+M1)=SUM
                      END DO
                   END IF
                END IF
                IF (.NOT.AUTNMS) THEN
                   CALL FCN(N,X+HJ,YH,WH,RPAR,IPAR)
                   NFCN=NFCN+1
                   DO I=1,N
                      DEL(I)=WH(I)-DEL(I)*HJI
                   END DO
                ELSE
                   DO I=1,N
                      DEL(I)=DYH(I)-DEL(I)*HJI
                   END DO
                END IF
                CALL SLVSEU(N,FJAC,LFJAC,MLJAC,MUJAC,FMAS,LDMAS,
     &            MLMAS,MUMAS,M1,M2,NM1,HJI,E,LE,IP,IPHES,DEL,IJOB)
                NSOL=NSOL+1
                DEL2=0.D0
                DO I=1,N
                   DEL2=DEL2+(DEL(I)/SCAL(I))**2
                END DO
                DEL2=DSQRT(DEL2)
                THETA=DEL2/MAX(1.D0,DEL1)
                IF (THETA.GT.1.D0) GOTO 79
             END IF
             CALL SLVSEU(N,FJAC,LFJAC,MLJAC,MUJAC,FMAS,LDMAS,
     &          MLMAS,MUMAS,M1,M2,NM1,HJI,E,LE,IP,IPHES,DYH,IJOB)
             NSOL=NSOL+1
             DO I=1,N
                DEL(I)=DYH(I)
             END DO
             IF (IOUT.EQ.2.AND.MM.GE.M-JJ) THEN
                IPT=IPT+1
                DO I=1,NRD
                   FSAFE(IPT,I)=DEL(ICOMP(I))
                END DO
             END IF
          END DO
       END IF
       DO I=1,N
          T(JJ,I)=YH(I)+DEL(I)
       END DO
C *** *** *** *** *** *** ***
C --- POLYNOMIAL EXTRAPOLATION
C *** *** *** *** *** *** ***
       IF (JJ.EQ.1) RETURN
       DO L=JJ,2,-1
          FAC=(DBLE(NJ(JJ))/DBLE(NJ(L-1)))-1.D0
          DO I=1,N
             T(L-1,I)=T(L,I)+(T(L,I)-T(L-1,I))/FAC
          END DO
       END DO
       ERR=0.D0
       DO I=1,N
          ERR=ERR+MIN(ABS((T(1,I)-T(2,I)))/SCAL(I),1.D15)**2
       END DO
       IF (ERR.GE.1.D30) GOTO 79
       ERR=DSQRT(ERR/DBLE(N))
       IF (JJ.GT.2.AND.ERR.GE.ERROLD) GOTO 79
       ERROLD=MAX(4*ERR,1.D0)
C --- COMPUTE OPTIMAL STEP SIZES
       EXPO=1.D0/JJ
       FACMIN=FAC1**EXPO
       FAC=MIN(FAC2/FACMIN,DMAX1(FACMIN,(ERR/SAFE1)**EXPO/SAFE2))
       FAC=1.D0/FAC
       HH(JJ)=MIN(ABS(H)*FAC,HMAXN)
       W(JJ)=A(JJ)/HH(JJ)
       RETURN
  79   ATOV=.TRUE.
       H=H*0.5D0
       REJECT=.TRUE.
       RETURN
       END
C
      FUNCTION SCONTEX(II,X,RC,LRC,IC,LIC)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT IN CONECTION
C     WITH THE OUTPUT-SUBROUTINE FOR SEULEX. IT PROVIDES AN
C     APPROXIMATION TO THE II-TH COMPONENT OF THE SOLUTION AT X.
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION RC(LRC),IC(LIC)
      COMMON /COSEU/XOLD,H,NRD,IR
C ----- COMPUTE PLACE OF II-TH COMPONENT
      I=0
      DO J=1,NRD
        IF (IC(J).EQ.II) I=J
      END DO
      IF (I.EQ.0) THEN
         WRITE (6,*) ' NO DENSE OUTPUT AVAILABLE FOR COMP.',II
         RETURN
      END IF
C ----- COMPUTE THE INTERPOLATED VALUE
      THETA=(X-XOLD)/H
      SCONTEX=RC(IR*NRD+I)
      DO J=2,IR
         SCONTEX=RC((1+IR-J)*NRD+I)+SCONTEX*(THETA-1.D0)
      END DO
      SCONTEX=RC(I)+SCONTEX*THETA
      RETURN
      END