subroutine abcon ( fun, c, num, ierr )

!*****************************************************************************80
!
!! ABCON calculates the abscissa of convergence of a given function
!  which is not too oscillatory.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     c is the calculated value of the abscissa of convergence.
!
!     num is a variable. on output it has for its value the number
!     of evaluations of fun that were performed.
!
!     ierr is an output integer reporting the status of the
!     calculation of c.  ierr is assigned values as follows...
!
!          ierr = 0     the calculation was fully successful.
!          ierr = 1     the requested accuracy may not have been
!                       obtained.  more subintervals may be required
!                       in the numerical quadratures in subroutines
!                       acond and xcond.
!          ierr = 2     c could not be calculated with sufficient
!                       accuracy, or an interval containing c could
!                       not be found.  the special value c = 0.0 is
!                       assigned.
!
  external acond
  real c
  real eta
  logical find
  external fun
  integer ierr
  integer num
  integer num1
  external xcond
  real xmin

  eta = 0.01E+00
  xmin = -1.00736E+04
!
!  Calculation of the location of the singularity on the real
!  axis which is farthest to the right.  Set this value to X0.
!
  call srch ( fun, xcond, xmin, eta, x0, num, ierr )
  c = x0

  if ( ierr == 2 ) then
    return
  end if
!
!  Check if S0 is on the right or left of the abscissa of
!  convergence.  If it is on the right, then we are done.
!
  if ( ierr /= 3 ) then

    call acond ( fun, x0, find, num1, ierr )
    num = num + num1

    if ( find ) then
      ierr = min ( ierr, 2 )
      return
    end if

  end if
!
!  Search to the right of x0 to find the abscissa of convergence.
!
  call srch ( fun, acond, x0, eta, c, num1, ierr )

  num = num + num1

  if ( ierr == 3 ) then
    c = 0.0E+00
    ierr = 2
  end if

  return
end
subroutine abcon1 (fun, c, num, ierr)
!
!*******************************************************************************
!
!! ABCON1 calculates the abscissa of convergence of a given function
!  which is not too oscillatory.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     c is the calculated value of the abscissa of convergence.
!
!     num is a variable. on output it has for its value the number
!     of evaluations of fun that were performed.
!
!     ierr is an output integer reporting the status of the
!     calculation of c.  ierr is assigned values as follows...
!
!          ierr = 0     the calculation was fully successful.
!          ierr = 1     the requested accuracy may not have been
!                       obtained.  more subintervals may be required
!                       in the numerical quadratures in subroutines
!                       acond and xcond.
!          ierr = 2     c could not be calculated with sufficient
!                       accuracy, or an interval containing c could
!                       not be found.  the special value c = 0.0 is
!                       assigned.
!
  external acond
  real eta
  external fun
  logical iend
  logical right
  real x1
  external xcond

  eta = 0.01E+00
!
!     search for an interval (x1, x2) containing x where
!     x1 >= 1.01269
!
  x1 = 1.01269E+00

  call xcond (fun,x1,right,num,ierr)

  if ( .not. right) go to 10

  call acond (fun,x1,right,num1,ierr)
  num = num + num1
  if ( right) go to 30

   10    continue

     x2 = 10.1269

     do i = 1,4

       if ( x2 <= x1) go to 10
       call xcond(fun,x2,right,num1,ierr)
       num = num + num1
       if ( right) then
         call acond(fun,x2,right,num1,ierr)
         num = num + num1
         if ( right) go to 50
       end if
       x1 = x2
       x2 = 10.0*x2

     end do

     go to 100
!
!     search for an interval (x1, x2) containing x where
!     x2 <= 1.01269
!
   30    x2 = x1
     x1 = -1.00358
     do i = 1,5
        call xcond (fun,x1,right,num1,ierr)
        num = num + num1
        if(.not. right) go to 50
        call acond (fun,x1,right,num1,ierr)
        num = num + num1
        if(.not. right) go to 50
        x2 = x1
        x1 = 10.0*x1
     end do

     go to 100
!
!     search for x in the interval (x1, x2) by bisection
!
   50       dx = x2 - x1
        xbar = x1 + dx/2.0
        xm = max ( abs(x1), abs(x2))
        tol = eta
        if ( xm > 1.0 ) tol = eta*xm
        iend =  dx <= tol

        call xcond (fun,xbar,right,num1,ierr)
        num = num + num1
        if ( right) go to 60
           if ( iend) go to 80
           x1 = xbar
           go to 50

   60       call acond (fun,xbar,right,num1,ierr)
        num = num + num1
        if ( right) go to 70
           if ( iend) go to 80
           x1 = xbar
           go to 50
   70       x2 = xbar
        if ( .not. iend) go to 50
!
!     standard termination
!
   80    c = x2
     return
!
!     error return when x cannot be found in (-1.e4, 1.e4)
!
  100 c = 0.0
  ierr = 2

  return
end
subroutine abslv ( mo, m, n, a, na, b, nb, c, nc, wk, ierr )

!*******************************************************************************
!
!! ABSLV solves the real matrix equation A*x + x*B = c.
!
!  Discussion:
!
!    A is reduced to lower Schur form, B is reduced to upper Schur form, 
!    and the transformed system is solved by back substitution.
!
!  Reference:
!
!    bartels, r.h. and stewart, g.w., 
!    algorithm 432, solution of the matrix equation ax + xb = c,
!    comm. acm 15 (1972), pp. 820-826.
!
!  Parameters:
!
!        mo is an input argument which specifies if the routine is
!     being called for the first time. on an initial call mo = 0 and
!     we have the following setup.
!
!        a(na,m)
!           a is a matrix of order m. it is assumed that
!           na >= m >= 1.
!
!        b(nb,n)
!           b is a matrix of order n. it is assumed that
!           nb >= n >= 1.
!
!        c(nc,n)
!           c is a matrix having m rows and n columns.
!           it is assumed that nc >= m.
!
!        wk(---)
!           wk is an array of dimension m**2  + n**2 + 2k
!           where k = max(m,n). wk is a general storage
!           area for the routine.
!
!     ierr is a variable that reports the status of the results. when
!     the routine terminates, ierr has one of the following values...
!
!        ierr =  0  the solution was obtained and stored in c.
!        ierr =  1  the equations are inconsistent for a and b.
!                   the problem cannot be solved.
!        ierr = -1  a could not be reduced to lower schur form.
!                   the problem cannot be solved.
!        ierr = -2  b could not be reduced to upper schur form.
!                   the problem cannot be solved.
!
!     when ierr = 0, a contains the lower schur form of the matrix a,
!     b contains the upper schur form of the matrix b, and wk contains
!     the orthonal matrices involved in the schur decompositions of
!     a and b. this information can be reused to solve a new set of
!     equations ax + xb = c without having to redecompose a and b.
!     the following options are available...
!
!        mo = 1      new matrices a and c are given. the data for b
!                    is reused in solving the new set of equations.
!
!        mo = 2      new matrices b and c are given. the data for a
!                    is reused in solving the new set of equations.
!
!     mo /= 0,1,2  a new matrix c is given. the data for a and b
!                    is reused in solving the new set of equations.
!
!     when abslv is recalled, it is assumed that m, n, and wk have
!     not been modified.
!
!     this subroutine is a modification by
!        Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!     of the subroutine axpxb written by
!        r.h. bartels and g.w.stewart
!        university of texas at austin.
!
  real a(na,m)
  real b(nb,n)
  real c(nc,n)
  real wk(*)

  iu = 1
  iv = m*m + 1
  iw = n*n + iv
  call abslv1 (mo,m,n,a,na,wk(iu),m,b,nb,wk(iv),n, &
                  c,nc,wk(iw),ierr)
  return
end
subroutine abslv1 (mo,m,n,a,na,u,nu,b,nb,v,nv,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! ABSLV1 solves the real matrix equation a*x + x*b = c.
!
!
!  a is reduced to lower Schur form, b is reduced to upper Schur form, and the
!     transformed system is solved by back substitution.
!
  real a(na,m)
  real b(nb,n)
  real c(nc,n)
  real temp
  real u(nu,m)
  real v(nv,n)
  real wk(*)
!
!  If required, reduce A to lower real Schur form.
!
  if ( mo /= 0 .and. mo /= 1) go to 35

  do 11 i = 1,m
     do 10 j = i,m
        temp = a(i,j)
        a(i,j) = a(j,i)
        a(j,i) = temp
   10    continue
   11 continue

  call orthes (na,m,1,m,a,wk)
  call ortrn1 (m,1,m,a,na,u,nu,wk)

  if ( m == 1) go to 20
  call schur (m,1,m,a,na,u,nu,wk(1),wk(m+1),ierr)
  if ( ierr /= 0) go to 200

   20 do 31 i = 1,m
     do j = i,m
        temp = a(i,j)
        a(i,j) = a(j,i)
        a(j,i) = temp
     end do
   31 continue
!
!     if required, reduce b to upper real schur form
!
   35 if ( mo /= 0 .and. mo /= 2) go to 45
  call orthes (nb,n,1,n,b,wk)
  call ortrn1 (n,1,n,b,nb,v,nv,wk)

  if ( n == 1) go to 45
  call schur (n,1,n,b,nb,v,nv,wk(1),wk(n+1),ierr)
  if ( ierr /= 0) go to 210
!
!     transform c
!
 45 continue

  do j = 1,n
    do i = 1,m
      wk(i) = dot_product ( u(1:m,i), c(1:m,j) )
    end do
    c(1:m,j) = wk(1:m)
  end do

  do 81 i = 1,m
     do 71 j = 1,n
        wk(j) = 0.0
        do 70 k = 1,n
           wk(j) = wk(j) + c(i,k)*v(k,j)
   70       continue
   71    continue
     do 80 j = 1,n
        c(i,j) = wk(j)
   80    continue
   81 continue
!
!     solve the transformed system
!
  call shrslv (a,b,c,m,n,na,nb,nc,ierr)
  if ( ierr /= 0) go to 220
!
!     transform c back to the solution
!
  do 101 j = 1,n
     do 91 i = 1,m
        wk(i) = 0.0
        do 90 k = 1,m
           wk(i) = wk(i) + u(i,k)*c(k,j)
   90       continue
   91    continue
     do 100 i = 1,m
        c(i,j) = wk(i)
  100    continue
  101 continue
!
  do 121 i = 1,m
     do 111 j = 1,n
        wk(j) = 0.0
        do 110 k = 1,n
           wk(j) = wk(j) + c(i,k)*v(j,k)
  110       continue
  111    continue
     do 120 j = 1,n
        c(i,j) = wk(j)
  120    continue
  121 continue
  return
!
!     error return
!
  200 ierr = -1
  return
  210 ierr = -2
  return
  220 ierr = 1
  return
end
subroutine acond(fun,x,cond,num,ierr)
!
!*******************************************************************************
!
!! ACOND tests whether X lies to the right of the abscissa of convergence 
!  of the
!     complex function defined by fun when no singularities lie
!     on the real axis.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     x is a real number. the logical variable cond = .true. if
!     x > c, where c is the abscissa of convergence, and .false.
!     if x < c.
!
!     num is a variable. on output it has for its value the number
!     of evaluations of fun that were performed.
!
!     ierr is an output integer indicating the status of the
!     calculation. it is assigned values as follows...
!          ierr = 0     the calculation was fully successful.
!
!          ierr = 1     the calculation of cond may not be accurate
!                       for all values of x.
!
  dimension iwk(100)
  dimension wk(400)
  logical cond
  external fun, acondf, acondg
!
!     eps is a machine dependent constant.  it is the smallest
!     number such that 1 + eps > 1.
!
  eps = epsilon ( eps )

  eps1 = 10.0*eps
  eps2 = 100.0*sqrt(eps)
  aerr = 1.0e-30
  rerr = eps1

  mo = 1
  l = 100
  m = 400
  a = x
  c = abs(x)
!
!     calculation of the integral of acondf from x to infinity.
!
  call qagi1(acondf,fun,y,c,a,mo,aerr,rerr,z1,error1,num1,ier1, &
             l,m,n,iwk,wk)
  a = 0.0
  c = x
!
!     calculation of the integral of acondg from 0 to infinity.
!
  call qagi1(acondg,fun,y,c,a,mo,aerr,rerr,z2,error2,num2,ier2, &
              l,m,n,iwk,wk)
  num = num1 + num2
  ier = max (ier1, ier2)
!
!     determination of cond.
!
  cond = .false.
  if ( abs(z1 - z2) <= eps2*max ( abs(z1),abs(z2))) cond = .true.
!
!     set ierr and return
!
  ierr = 0
  if ( ier > 4) ierr = 1
  return
end
function acondf(x,y,c,fun)

!*******************************************************************************
!
!! ACONDF is the function integrated along the X axis in ACOND.
!
!     y is a dummy variable.
!
  external fun
  call fun(x, 0.0, a, b)
  acondf = a/(x + c + 1.0)

  return
end
function acondg ( x, y, c, fun )

!*******************************************************************************
!
!! ACONDG is the function integrated along the line X = C in ACOND.
!
!
!     y is a dummy variable.
!
  real a
  real b
  real c
  external fun

  call fun(c, x, a, b)
  z = c + abs(c) + 1.0
  t = cpabs(x, z)
  t1 = x/t
  t2 = z/t
  acondg = (t1*a - t2*b)/t
  return
end
subroutine adapt (f, xlft, xrgt, epsln, npiece, errest, xknots, &
  coefs, ierr, kmax, ndeg, nsmth, anorm, dx, mo, kbreak, brakpt, &
  kdiff, vallft, valrgt)
!
!*******************************************************************************
!
!! ADAPT computes a piecewise polynomial approximation.
!
!     tabulation of the internal and external names of the arguments.
!
!
!    internal   external
!     f          f
!     a          xlft
!     b          xrgt
!     accur      epsln
!     knots      npiece
!     error      errest
!     xknots     xknots
!     coefs      coefs
!     ierr       ierr
!     kmax       kmax
!     degree     ndeg
!     smooth     nsmth
!     norm       anorm
!     charf      dx
!     edist      mo
!     nbreak     kbreak
!     xbreak     brakpt
!     dbreak     kdiff
!     bleft      vallft
!     bright     valrgt
!
  double precision a, accur, b, bleft, bright, charf, ddtemp
  double precision dsctol, error, errori, factor, fintrp
  double precision fleft, fright, norm
  double precision xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10)
  dimension fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision xknots(*), coefs(kmax,*)
  double precision anorm, brakpt, dx, epsln, errest, vallft
  double precision valrgt, xlft, xrgt
  dimension brakpt(kbreak), kdiff(kbreak), vallft(kbreak)
  dimension valrgt(kbreak)
  double precision f
  external f

  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx

  a = xlft
  b = xrgt
  accur = epsln
  degree = ndeg
  smooth = nsmth
  norm = anorm
  charf = dx
  edist = mo
  nbreak = kbreak

  if ( nbreak<=0 .or. nbreak>=21) go to 30

  do k=1,nbreak
    xbreak(k) = brakpt(k)
    dbreak(k) = kdiff(k)
    bleft(k) = vallft(k)
    bright(k) = valrgt(k)
  end do
   30 continue

  kdimen = kmax+1
  ndimen = ndeg+1
  call adapt1(f, xknots, coefs, kdimen, kmax, ndimen, ierr)
  npiece = knots
  errest = error

  return
end
subroutine adapt1 ( f, xknots, coefs, kdimen, kmax, ndimen, ierr )

!*******************************************************************************
!
!! ADAPT1 computes a piecewise polynomial approximation
!  of specified smoothness, accuracy and degree.  
!
!  the input to the computation is
!
!   f      - function being approximated. it must provide values of
!            derivatives up to the order of smoothness specified for
!            the approximation.  the calling sequence is f(x,fderv) and
!            fderv contains the derivatives( see constraint below)
!   a,b    - the endpoints of the interval of approximation
!   accur  - the accuracy required for the approximation
!   smooth - the smoothness required for the approximation
!              = 0  means continuous
!              = 1  means continuous slope
!              = 2  means continuous second derivative, etc.
!   degree - the degree of the polynomial pieces.
!            must have degree gt 2*smooth
!   charf  - characteristic length of the function f(x). pieces are not
!            longer than this length.
!   norm   - norm to measure the approximation error
!              = 1  l1 approximation (least deviations)
!              = 2  l2 approximation (least squares)
!              = 3  tchebycheff (minimax) approximation
!              =-p  (negative value) general lp approximation
!   nbreak - number of special break points in the approximation.
!            associated input variables are
!              xbreak(j)  - location of break points
!              dbreak(j)  - derivative broken at xbreak
!              bleft (j)  - value from left for dbreak derivative
!              bright(j)  -   -    -   right -    -        -
!   edist  - switch to change from proportional error distribution
!            to fixed distribution. this is primarily of use in
!            approximation of functions with singularities. one should
!            use norm = 1. or so in such cases
!              = 0  proportional distribution
!              = 1  approximate fixed error distribution
!                   attempts to achieve specified accuracy value accur
!              = 2  true fixed error distribution
!
!  output
!     the output of the computation consists of 4 parts, each returned
!     to the user in a different way. they are
!
!   xknots,coefs - arrays defining the piecewise polynomial result.
!            xknots(k)  = knots of the approximation ( k = 1 to knots)
!                         the last one is right end point of interval
!            coefs(k,n) = coefficient of (x - xknot(k))**(n-1) in the
!                         interval xknot(k) to xknot(k+1)
!                           k = 1 to knots-1  and  n = 1 to degree+1
!            these arrays are passed as arguments so as to use variable
!            dimensions. the arrays are of dimension xknots(kdimen) and
!            coefs(kmax,ndimen). it is assumed that kdimen = kmax+1.
!               ***** note ***** several small arrays here have fixed
!                        dimensions that limit degree and thus ndimen
!                        should not exceed this limit (currently = 20)
!
!   resulz - a labeled common block containing knots and error
!              knots - number of knots of the approximation
!              error - estimated accuracy of the approximation
!
!   ierr - status indicator. ierr takes the values
!      0   the approximation was successfully constructed.
!     -1   input error reported by adset.
!     -2   a and b are too close.
!     -3   charf is too small.
!     -4   either all the break points are not between a and b, or
!          xbreak(i)>=xbreak(i+1) for some i.
!     -5   dbreak(i)<0 .or. dbreak(i)>(degree-1)/2 for some i.
!      1   the knot limit was exceeded.
!      2   break point adjustment requires that a subinterval be
!          partitioned. however, this cannot be done either because
!          the interval stack is full, or partitioning will produce
!          too small an interval.
!      3   a subinterval must be partitioned because its length is
!          greater than charf. however, this cannot be done since the
!          interval stack is full.
!      4   a subinterval must be partitioned so that the accuracy
!          criteria can be satisfied. however, this cannot be done
!          either because the interval stack is full, or partitioning
!          will produce too small an interval.
!
!  ********** dimension constraints **********
!     maxknt - max number of knots taken from user via kdimen
!              arrays with this dimension (or related values)
!                   coefs   xknots
!     maxpar - max number of parameters per interval (currently = 20)
!                   user provided ndimen must have ndimen le maxpar
!                   must have  degree + 1 le maxpar
!              arrays with this dimension (or related values)
!                d       ddtemp  fdervl  fdervr  fdumb   factor
!                fintrp  fleft   fright  powers  xtemp   xintrp  xdd
!              ***** note ***** maxpar also affects argument fderv
!              of function f.  fdervl, fdervr are also involved.
!              should declare fderv of size 10 in f to be safe.
!     maxaux - maximum number of auxiliary input ( = 20 now ). arrays
!                 xbreak  dbreak  bleft   bright
!     maxstk - max size of active interval stack
!              min interval length is 2**(-maxstk)*(b-a). arrays
!                 xleft   xright
!
!  **********  portability considerations  **********
!
!     all the routines in this package (except adapt) are written in
!     ansi standard fortran. in addition, they meet all the requirements
!     of the bell labs portable fortran -pfort-.  nevertheless, the
!     routines are affected by a change in machine word length and
!     changing to single precision.
!
!     ***** the gauss weights and abscissae in adcomp are given to
!           30 digits. the parameter eps0 in adset specifies the
!           accuracy of these constants. if the accuracy is changed
!           to k decimal digits then set eps0 = 10**(-k).
!
!     ***** the interval stack size maxstk is defined in adset to
!           be 50. if maxstk is modified then set the dimensions of
!           xleft and xright to the new value for maxstk. note that
!           the minimum interval length is 2**(-maxstk)*(b-a).
!
!  single precision conversion -- requires four steps
!     1. declare all double precision variables to be real.
!
!     2. change all double precision numbers in the data statements.
!        (floating point numbers appear only in data statements.)
!
!     3. change dabs,dmax1,dmin1 at many places.
!
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision xknots(kdimen), coefs(kmax,ndimen)
  double precision f
  external f
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
!                      kntdim - kdimen, name changed to put in common
!                      npardm - ndimen, name changed to put in common
  common /resulz/ error, knots
!                      knots = final no. of knots, includes b as one.
!                      error = estimate of error actually achieved.
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
!             kontrl contains generally useful variables
!                      maxstk - see comments above
!                      buffer - the machine dependent tolerance used
!                               by the algorithm
!                      nstack - counter for interval stack, consists of
!                               (xleft(j),xright(j))  j = 1 to nstack
!                      errori - error estimate for top interval
!                      dsctol - tolerance to check discarding intervals
!                      discrd - switch to signal discard of top interval
!                      factor - array of factorials
!                      npar   - number of paremeters = degree + 1
!                      interp - number of interior interpolation points
!                               in the normal interval
!                      ibreak - counter on break points
!                      break  - switch for break point in top interval
!                               0     = no break present
!                               left  = break at xleft(nstack)
!                               right = break at xright(nstack)
!                               both  = break at both ends
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!             comdif contains variables used only by adcomp and friends.
!                      nintrp - number of interior interpolation points
!                               for the current interval
!                      xintrp - interior interpolation points
!                      fintrp - f values at xintrp points
!                      leftx  - multiplicity of interpolation at xleft
!                               = no. of derivatives matched at xleft
!                      fleft  - values of f and its derivatives at xleft
!                      rightx - multiplicity of interpolation at xright
!                      fright - values of f and derivatives at xright
!                      ddtemp - the array of divided differences
!                      xdd    - the x values for ddtemp with proper
!                               multiplicities of xleft and xright
!
!  main control program
!
!  check the input and initialize all the parameters
!
  call adset(xknots, coefs, kdimen, kmax, ndimen, ierr)
  if ( ierr/=0) return
!
!  loop over processing of intervals
!
   10 call adtake(ierr)
  if ( ierr/=0) return
  call adcomp(f)
!
!  check for discarding intervals
!
  call adchk
!
!  put new intervals on stack or discard, update status
!
  call adput(xknots, coefs, kdimen, kmax, ndimen, ierr)
  if ( ierr/=0) return
!
!  test for normal termination
!
  if ( nstack==0) return
!
!  check on the number of knots generated
!
  if ( knots<maxknt) go to 10
  ierr = 1
  return
end
subroutine adchk

!*******************************************************************************
!
!! ADCHK checks for discarding interval, applies various tests
!  about discarding involving edist and charf.
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision aknots, dtest, dx, three, five
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  data three,five/3.0d0,5.0d0/
!
  discrd = .false.
  dx = xright(nstack) - xleft(nstack)
  if ( dx>charf) return
!
!         compute dtest for the local error criterion
!
  if ( norm==three) go to 30
  if ( edist-1) 10,20,30
   10 dtest = dx*dsctol
  go to 40
!         for the approximate fixed error distribution type we estimate
!         the final number of knots by( limiting it a little )
!             (nstack+knots+2)((b-a)/(xright-a))
   20 aknots = nstack+knots+2
  dtest = dsctol/(aknots*dmin1((b-a)/(xright(nstack)-a),five))
  go to 40
   30 dtest = dsctol
!
!             check for discard of interval
!
   40 if ( errori<=dtest) discrd = .true.
  return
end
subroutine adcomp ( f )
!
!*****************************************************************************80
!
!! ADCOMP computes the piecewise polynomial approximation on current interval.
!
!  it also estimates the error
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision absc, aj, dx, fdervl, fdervr, fdumb, r, wgts
  dimension absc(4), wgts(4), fdervl(9), fdervr(9), fdumb(9)
  double precision errint, f, polydd
  external f, polydd
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  equivalence (fleft(2),fdervl(1)), (fright(2),fdervr(1))
  data r/1.5d0/
!
!     thirty digit values for the gauss integration constants
!                    .861136311594052575223946488893d0
!                    .339981043584856264802665759103d0
!                    .347854845137453857373063949222d0
!                    .652145154862546142626936050778d0
!
!     ***** the absissae and weights are given below to 30 digits.
!           the parameter eps0 in adset specifies the accuracy of
!           these constants. if the accuracy is changed to k decimal
!           digits then set eps0 = 10**(-k).
!
  data absc(1) /-.861136311594052575223946488893d0 /
  data absc(2) /-.339981043584856264802665759103d0 /
  data absc(3) / .339981043584856264802665759103d0 /
  data absc(4) / .861136311594052575223946488893d0 /
  data wgts(1) / .347854845137453857373063949222d0 /
  data wgts(2) / .652145154862546142626936050778d0 /
  data wgts(3) / .652145154862546142626936050778d0 /
  data wgts(4) / .347854845137453857373063949222d0 /
!
!             compute interpolation information
  nintrp = degree - 2*smooth - 1
!
!          increase number of interpolation points if break points are
!          specified with fewer derivatives than smooth
!
  if ( break==left .or. break == right) nintrp = nintrp + smooth - &
   dbreak(ibreak)
  if ( break==both) nintrp = nintrp + 2*smooth - dbreak(ibreak) - &
   dbreak(ibreak+1)
  if ( nintrp==0) go to 20
!
!             generate equal spaced interpolation points.
!
  aj = nintrp+1
  dx = (xright(nstack)-xleft(nstack))/aj
  do 10 j=1,nintrp
    aj = j
    xintrp(j) = xleft(nstack) + aj*dx
   10 continue
!
!  get left and right f-values, put f-value in first element
!  of arrays fleft and fright.  get derivatives back as
!  other elements via the subarrays fdervl and fdervr.
!
   20 fleft(1) = f(xleft(nstack),fdervl)
  fright(1) = f(xright(nstack),fdervr)
  leftx = smooth + 1
  rightx = leftx
!
!            get f-values at other interpolation points, if any
!
  if ( nintrp==0) go to 40
  do 30 j=1,nintrp
    fintrp(j) = f(xintrp(j),fdumb)
   30 continue
!
!          check for break points, modify values if necessary.
!
   40 continue
  if ( break/=left) go to 50
  leftx = dbreak(ibreak) + 1
  fleft(leftx) = bright(ibreak)
   50 if ( break/=right) go to 60
  rightx = dbreak(ibreak) + 1
  fright(rightx) = bleft(ibreak)
   60 if ( break/=both) go to 70
  leftx = dbreak(ibreak) + 1
  rightx = dbreak(ibreak+1) + 1
  fleft(leftx) = bright(ibreak)
  fright(rightx) = bleft(ibreak+1)
   70 continue
!
!           compute divided differences, newton form of polynomial.
!
  call newton(leftx, rightx, nintrp)
!
!         compute norm of error of this appromimation using four pts
!         add 50 percent fudge factor
  errori = errint(f,polydd,xleft(nstack),xright(nstack),absc,wgts)
  errori = r*errori
  return
end
subroutine adput ( xknots, coefs, kdimen, kmax, ndimen, ierr )
!
!*******************************************************************************
!
!! ADPUT puts intervals on the stack or discards them.
!
!
!     when an interval is discarded a new knot is found. then this
!     program updates the error estimate, the xknot array, transforms
!     the polynomial to the power form and put the coefficients into
!     the array coefs.  it also checks for passing break points
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision xknots(kdimen), coefs(kmax,ndimen)
  double precision dx, half, one, powers, p, ratio, three
  dimension powers(20)
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  data half,one,three/.5d0,1.d0,3.d0/
!
!            check for discarding the interval.
!
  if ( discrd) go to 30
!
!         subdivide interval and place on stack
  if ( nstack<maxstk) go to 10
!             fatal error, exceeded active stack size
  ierr = 4
  dx = xright(nstack)-xleft(nstack)
  if ( dx>charf) ierr = 3
  return

   10 dx = (xright(nstack)-xleft(nstack))*half
!
!  Check for small intervals
!
  ratio = dx/(dabs(a)+dabs(b))
  if ( ratio>buffer) go to 20
  ierr = 4
  return

   20 nstack = nstack + 1
  xleft(nstack) = xleft(nstack-1)
  xleft(nstack-1) = xright(nstack-1) - dx
  xright(nstack) = xleft(nstack-1)
  return
!
!            discard interval, update global error, xknots and coefs.
!
   30 p = dabs(norm)
  if ( norm==three) error = dmax1(error,errori)
  if ( norm/=three) error = (error**p+errori)**(one/p)
!
!  check for passing break points.
!
  if ( break==left .or. break == both) ibreak = ibreak + 1
!
!  transform representation of polynomial from divided
!  differences to powers of x with origin at xknots (knots)
!
  call adtran(ddtemp, powers)
!
!  put coefs into the main array
!
  do k=1,npar
    coefs(knots,k) = powers(k)
  end do
!
!  put the new knots in xknots
!
  knots = knots + 1
  xknots(knots) = xright(nstack)
  nstack = nstack - 1
  return
end
subroutine adset(xknots, coefs, kdimen, kmax, ndimen, ierr)
!
!*******************************************************************************
!
!! ADSET checks the input data and initializes the computation.
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision xknots(kdimen), coefs(kmax,ndimen)
  double precision akmax, eps, eps0, km1, ratio, zero, one, two, &
   three, c100
  double precision dpmpar
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  data eps0/1.d-30/
  data zero,one,two,three,c100/0.d0,1.d0,2.d0,3.d0,100.d0/
  data kleft, kright, kboth /1, 2, 3/
!
  eps = epsilon ( eps )
  buffer = c100*dmax1(eps,eps0)
!
!  put data statement items into common variables
!
  left = kleft
  right = kright
  both = kboth
!
!  set current values of limits on dimensions
!
  kntdim = kdimen
  npardm = ndimen
  maxknt = kntdim
  maxstk = 50
  maxpar = min (20,npardm)
  maxaux = 20
!
!  check input data
!
  ierr = 0
  if ( a>=b .or. accur<=zero) go to 200
  if ( degree>=maxpar .or. 2*smooth>=degree) go to 200
  akmax = kmax
  ratio = (b-a)/(dabs(a)+dabs(b))
  if ( ratio<=two*buffer*akmax) go to 210
  if ( charf<(b-a)/akmax) go to 220
  if ( norm>=zero .and. (norm-one)*(norm-two)*(norm-three)/=zero) &
           go to 200
  if ( edist*(edist-1)*(edist-2)/=0) go to 200
  if ( nbreak<0 .or. nbreak>maxaux) go to 200
  if ( nbreak==0) go to 150
!
!         check the break point data, monotonicity and degree
!
  j = 1
  if ( xbreak(1)<a .or. xbreak(nbreak)>b) go to 230
  if ( nbreak==1) go to 110
  do 100 j=2,nbreak
    if ( xbreak(j-1)>=xbreak(j)) go to 230
  100 continue
  110 limsm = (degree-1)/2
  do 120 j=1,nbreak
    if ( dbreak(j)<0 .or. dbreak(j)>limsm) go to 240
  120 continue
!
!  initialization of variables
!
!  active interval stack
!
  150 nstack = 1
  xleft(1) = a
  xright(1) = b
!
!  termination and error values
!
  error = zero
  dsctol = accur**dabs(norm)
  if ( edist==0) dsctol = dsctol/(b-a)
  if ( norm==three) dsctol = accur
!
!  miscellaneous variables and pointers
!
  ibreak = 1
  knots = 1
  interp = degree + 2 - 2*smooth
  xknots(1) = a
  npar = degree + 1
!
!  compute array of npar factorials
!
  factor(1) = one
  factor(2) = one
  do k=3,npar
    km1 = k-1
    factor(k) = km1*factor(k-1)
  end do
  return
!
!  error return
!
  200 ierr = -1
  return
!
!         a and b are too close
!
  210 ierr = -2
  return
!
!         charf is too small
!
  220 ierr = -3
  return
!
!         break points are not monotonic
!
  230 ierr = -4
  return
!
!         bad value in derivative breaks
!
  240 ierr = -5
  return
end
subroutine adtake(ierr)
!
!*******************************************************************************
!
!! ADTAKE takes an active interval off the top of the stack.
!
!
!     it also does most of the work of locating and handling
!     break points
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision dx, ratio
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
!         check for break point
  break = 0
  if ( nbreak==0 .or. ibreak>nbreak) go to 20
  if ( xbreak(ibreak)>xright(nstack)) go to 20
!
!               set control variable break, check for location
  if ( xbreak(ibreak)>xleft(nstack)) go to 10
  break = left
  if ( ibreak==nbreak) go to 20
!             check for second break point in this interval
  if ( xbreak(ibreak+1)>=xright(nstack)) go to 20
!                 next break is inside interval, split top interval
  break = both
!                  check exceeding stack limit. if so, stop
  if ( nstack==maxstk) go to 30
!                     dont split very small intervals, stop instead
  dx = xbreak(ibreak+1) - xleft(nstack)
  ratio = dx/(dabs(a)+dabs(b))
  if ( ratio<=buffer) go to 30
  nstack = nstack + 1
  xleft(nstack) = xleft(nstack-1)
  xright(nstack) = xbreak(ibreak+1)
  xleft(nstack-1) = xright(nstack)
  go to 20
!
   10 break = right
!
!  check to see if break is already at right end point
!
  if ( xbreak(ibreak)>=xright(nstack)) go to 20
!                 the break is inside interval, split top interval
!                  check exceeding stack limit. if so, stop
  if ( nstack==maxstk) go to 30
!                     dont split very small intervals, stop instead
  dx = xbreak(ibreak) - xleft(nstack)
  ratio = dx/(dabs(a)+dabs(b))
  if ( ratio<=buffer) go to 30
  nstack = nstack + 1
  xleft(nstack) = xleft(nstack-1)
  xright(nstack) = xbreak(ibreak)
  xleft(nstack-1) = xright(nstack)
   20 continue
  return
!
!        a break point is in the interior of the top subinterval of
!        the stack.  the subinterval cannot be partitioned either
!        because the stack is full, or because partitioning leads to
!        too small an interval.
!
   30 ierr = 2
  return
end
subroutine adtran ( d, powers )
!
!*****************************************************************************80
!
!! ADTRAN converts polynomial rep from divided difference to power form.
!
!  there are coalesced points on each
!     end of the interval (xl,xr) = (xleft(nstack),xright(nstack)).
!     the number coalesced at each end is leftx and rightx.
!     and there are nintrp other pts xintrp(k)  inbetween them.
!     see subroutine newton for more details
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision d, powers, shift, xl, xr, xtemp
  dimension d(20, *), powers( *), xtemp(20)
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
!  set some short local variable names
!
  xl = xleft(nstack)
  xr = xright(nstack)
  nl = leftx
  nr = rightx
  ni = nintrp
  nrl = nr + nl
  nri = nr + ni
  nri1 = nri - 1
  nrli = nrl + ni
!
!         starting representation is (assuming xl = 0 )
!
!    d(1) +d(2)x +d(3)x**2 + --- +d(nl)x**(nl-1)
!   +(x**nl)*( d(nl+1)(+d(nl+2)(x-xr)**2 + --- +d(nl+nr)*(x-xr)**(nr-1)
!        *((x-xr)**nr)*(d(nl+nr+1) + d(nl+nr+2)*(x-xintrp(1))
!                      +d(nl+nr+3)*(x-xintrp(1))(x-xintrp(2)) + ---))
!
!         strategy is to first convert the part from the interp. pts.
!         to poly in (x-xr).  this poly then has origin shifted to xl.
!
!     the conversion of the interp part is done explicitly for degree
!     two or less and done by synthetic division for higher degrees
!
!   d1 + d2(x-x1) +d3(x**2-(x1+x2)x +x1*x2)
!
!     the resulting coefficients are put in the array powers
!
  if ( ni==0) go to 100
!
!             build up the polynomial for the interpolation points
!
!         use special formulas for ni less than 3
  if ( ni==1) go to 10
  if ( ni==2) go to 20
  go to 30
   10 powers(1) = d(nrl+1,1)
  go to 80
   20 powers(1) = d(nrl+1,1) + (xr-xintrp(1))*d(nrl+2,1)
  powers(2) = d(nrl+2,1)
  go to 80
!
!  conversion by repeated synthetic division.
!
   30 ni1 = ni - 1
!
!  initialize the powers and xtemp arrays
!
  do k=1,ni
    xtemp(k) = xintrp(k)
    nrlk = nrl + k
    powers(k) = d(nrlk,1)
  end do
!
!         do the repeated synthetic division to replace the xtemp
!         = xintrp points of the newton expansion by the xr points.
!
  do 70 k=1,ni1
!              powers(ni) is fixed and set above
    do 50 ii=1,ni1
      i = ni - ii
      powers(i) = powers(i) + (xr-xtemp(i))*powers(i+1)
   50   continue
!              shift the newton expansion pts. up, put in one more xr
    do 60 ii=1,ni1
      i = ni - ii
      xtemp(i+1) = xtemp(i)
   60   continue
    xtemp(1) = xr
   70 continue
   80 continue
!             shift the coefficients to the top of the powers array
  do 90 k=1,ni
    l = ni + 1 - k
    ltop = l + nrl
    powers(ltop) = powers(l)
   90 continue
!
!             have the interpolation pt. coefs. in the array powers
  100 continue
!             put the remaining divided diffs into the powers array
  do 110 j=1,nrl
    powers(j) = d(j,1)
  110 continue
!
!         transform the origin of the polynomial from xr to xl
!         we use repeated synthetic division
  if ( nri==1) go to 140
  shift = xr - xl
  khi = nri1
!             loop through the coefficients
  do 130 j=2,nri
!                   synthetic division loop
    do 120 k=1,khi
      koef = nrli - k
      powers(koef) = powers(koef) - shift*powers(koef+1)
  120   continue
    khi = khi - 1
  130 continue
  140 continue
!     the coefficients are now of the power form with origin xl
  return
end
function ai ( x )
!
!*******************************************************************************
!
!! AI evaluates the Airy function.
!
!
!     x0 = 2**(2/3)
!     c = exp(2/3)
!
  real ai
  real, parameter :: c = 1.94773404105468E+00
  real x
  real, parameter :: x0 = 1.58740105196820
!
  data an0/ .355028053887818e+00/, an1/-.187394912983414e+00/, &
       an2/-.383735973881972e-01/, an3/ .491952571236878e-01/, &
       an4/-.967017625191329e-02/, an5/-.205648610308316e-02/, &
       an6/ .114176040526844e-02/, an7/-.117114823456866e-03/, &
       an8/-.270165470074755e-04/, an9/ .789002965889206e-05/
  data ad0/ .100000000000000e+01/, ad1/ .201179850513612e+00/, &
       ad2/ .385762517106249e-01/, ad3/ .230887443780120e-04/
!
  data bn0/ .355028053887817e+00/, bn1/-.997169317338190e-01/, &
       bn2/-.602216060213075e-01/, bn3/ .297705337630730e-01/, &
       bn4/-.152969932286570e-02/, bn5/-.147868368189372e-02/, &
       bn6/ .350518617006107e-03/, bn7/-.257766924610873e-04/
  data bd0/.100000000000000e+01/, bd1/.448140563306831e+00/, &
       bd2/.157074537566686e+00/, bd3/.316964519364865e-01/, &
       bd4/.485922740843953e-02/, bd5/.423326964456309e-03/
!
  data pn0/.282094378896566e+00/, pn1/.807868561687271e-01/, &
       pn2/.630644564152247e-02/, pn3/.147116711467936e-03/, &
       pn4/.750490748341483e-06/
  data pd0/.100000000000000e+01/, pd1/.292890323271551e+00/, &
       pd2/.239376862143358e-01/, pd3/.612353984250624e-03/, &
       pd4/.384461189764830e-05/, pd5/.123247804102182e-08/
!
  data qn0/.282094791017188e+00/, qn1/.149585822742689e+00/, &
       qn2/.241876418864958e-01/, qn3/.138190913282142e-02/, &
       qn4/.241862862465003e-04/, qn5/.709733720554615e-07/
  data qd0/.100000000000000e+01/, qd1/.536778341756648e+00/, &
       qd2/.889112579703465e-01/, qd3/.533368703697049e-02/, &
       qd4/.103812739863315e-03/, qd5/.408838544650398e-06/
!
  data rn0/.282094791773878e+00/, rn1/.203731967781874e+00/, &
       rn2/.436660479870037e-01/, rn3/.306595563073142e-02/, &
       rn4/.517398800281618e-04/
  data rd0/.100000000000000e+01/, rd1/.728721438361672e+00/, &
       rd2/.159210021472267e+00/, rd3/.116985268534248e-01/, &
       rd4/.225973894323078e-03/, rd5/.232707159780478e-06/
!
  if ( x < -1.0 ) then
    call aimp (-x, r, phi)
    ai = r*sin(phi)
    return
  end if

  if ( x < 0.0) then
    ai = (((((((((an9*x + an8)*x + an7)*x + an6)*x + an5)*x &
             + an4)*x + an3)*x + an2)*x + an1)*x + an0) / &
             (((ad3*x + ad2)*x + ad1)*x + ad0)
    return
  end if

   20 if ( x >= 1.0) go to 30
  ai = (((((((bn7*x + bn6)*x + bn5)*x + bn4)*x + bn3)*x + bn2)*x &
                    + bn1)*x + bn0) / &
       (((((bd5*x + bd4)*x + bd3)*x + bd2)*x + bd1)*x + bd0)
  return

   30 rtx = sqrt(x)
  if ( x > x0) go to 40
  t = 16.0/(x*rtx)
  w = ((((pn4*t + pn3)*t + pn2)*t + pn1)*t + pn0) / &
      (((((pd5*t + pd4)*t + pd3)*t + pd2)*t + pd1)*t + pd0)
  ai = (w/sqrt(rtx)) * exp(-2.0*x*rtx/3.0)
  return

   40 if ( x > 4.0d0) go to 50
  t = 16.0/(x*rtx)
  w = (((((qn5*t + qn4)*t + qn3)*t + qn2)*t + qn1)*t + qn0) / &
      (((((qd5*t + qd4)*t + qd3)*t + qd2)*t + qd1)*t + qd0)
  ai = (w/sqrt(rtx)) * exp(-2.0*x*rtx/3.0)
  return

   50 if ( x*rtx > 1.5*exparg(0)) go to 60
  t = 16.0/(x*rtx)
  w = ((((rn4*t + rn3)*t + rn2)*t + rn1)*t + rn0) / &
      (((((rd5*t + rd4)*t + rd3)*t + rd2)*t + rd1)*t + rd0)
  n = rtx
  n2 = n*n
  t = (x - n2)/(rtx + n)
  ai = ((w/sqrt(rtx)) / c**(n2*n)) * exp(-2.0*t*(n*rtx + t*t/3.0))
  return

   60 ai = 0.0
  return
end
subroutine aia (ind, z, ai, aip, ierr)
!
!*******************************************************************************
!
!! AIA calculates the Airy function and its derivative.
!
!
!     complex argument z by means of asymptotic expansions.
!
  complex ai
  complex aip,z,z1,z2,z2r,zz,w,w2,s1,s2,s3,s4,e,zeta,si,cn
  complex alpha,beta,j
  real c(30), d(30)
!
  data c(1)  /.100000000000000e+01/, c(2)  /.694444444444444e-01/, &
       c(3)  /.371334876543210e-01/, c(4)  /.379930591278006e-01/, &
       c(5)  /.576491904126697e-01/, c(6)  /.116099064025515e+00/, &
       c(7)  /.291591399230751e+00/, c(8)  /.877666969510017e+00/, &
       c(9)  /.307945303017317e+01/, c(10) /.123415733323452e+02/, &
       c(11) /.556227853659171e+02/, c(12) /.278465080777603e+03/, &
       c(13) /.153316943201280e+04/, c(14) /.920720659972641e+04/, &
       c(15) /.598925135658791e+05/, c(16) /.419524875116551e+06/, &
       c(17) /.314825741786683e+07/, c(18) /.251989198716024e+08/, &
       c(19) /.214288036963680e+09/, c(20) /.192937554918249e+10/
  data c(21) /.183357669378906e+11/, c(22) /.183418303528833e+12/, &
       c(23) /.192647115897045e+13/, c(24) /.211969993886476e+14/, &
       c(25) /.243826826879716e+15/, c(26) /.292659921929793e+16/, &
       c(27) /.365903070126431e+17/, c(28) /.475768102036307e+18/, &
       c(29) /.642404935790194e+19/, c(30) /.899520742705838e+20/
!
  data d(1)  / .100000000000000e+01/, d(2)  /-.972222222222222e-01/, &
       d(3)  /-.438850308641975e-01/, d(4)  /-.424628307898948e-01/, &
       d(5)  /-.626621634920323e-01/, d(6)  /-.124105896027275e+00/, &
       d(7)  /-.308253764901079e+00/, d(8)  /-.920479992412945e+00/, &
       d(9)  /-.321049358464862e+01/, d(10) /-.128072930807356e+02/, &
       d(11) /-.575083035139143e+02/, d(12) /-.287033237109221e+03/, &
       d(13) /-.157635730333710e+04/, d(14) /-.944635482309593e+04/, &
       d(15) /-.613357066638521e+05/, d(16) /-.428952400400069e+06/, &
       d(17) /-.321453652140086e+07/, d(18) /-.256979083839113e+08/, &
       d(19) /-.218293420832160e+09/, d(20) /-.196352378899103e+10/
  data d(21) /-.186439310881072e+11/, d(22) /-.186352996385294e+12/, &
       d(23) /-.195588293238984e+13/, d(24) /-.215064446351972e+14/, &
       d(25) /-.247236992290621e+15/, d(26) /-.296588243029521e+16/, &
       d(27) /-.370624400063547e+17/, d(28) /-.481678264794522e+18/, &
       d(29) /-.650098408075106e+19/, d(30) /-.909919826436541e+20/
!
!     c1 = pi**(-1/2)
!     c2 = (2*pi)**(-1/2)
!
  data c1 /.564189583547756/
  data c2 /.398942280401433/
!
!
!     eps, xpos, and xneg are machine dependent constants. eps is
!     the smallest number such that 1.0 + eps > 1.0, xpos is the
!     the largest postive number for which exp(x) can be computed,
!     and xneg is the largest negative number for which exp(x) does
!     not underflow.
!
  eps = epsilon ( eps )
  xpos = exparg(0)
  xneg = exparg(1)

  ierr = 0
  if ( real(z) < 0.0) go to 30
!
!             -----   real(z) >= 0    -----
!
  z1 = csqrt(z)
  z2 = csqrt(z1)
  z2r = 1.0/z2
  call crec (real(z), aimag(z), u, v)
  w = -1.5*cmplx(u,v)/z1
  u = abs(real(w))
  v = abs(aimag(w))
  t = max ( u,v)
  if ( ind /= 0) go to 10

     if ( t == 0.0) go to 90
     u1 = u/t
     v1 = v/t
     r = u*u1 + v*v1
     xm = xpos
     if ( real(w) < 0.0) xm = -xneg
     if ( u1 >= r*xm .or. v1 >= 0.1*r/eps) go to 90
     zeta = z1*z/1.5
     e = cexp(-zeta)

   10 m = 20
  if ( t > 30.0) m = 8
  s1 = cmplx(c(m),0.0)
  s2 = cmplx(d(m),0.0)
  i = m
  do 20 k = 2,m
     i = i - 1
     s1 = c(i) + w*s1
     s2 = d(i) + w*s2
   20 continue
!
  ai = 0.5*c1*z2r*s1
  aip = - 0.5*c1*z2*s2
  if ( ind /= 0) return
  ai = e*ai
  aip = e*aip
  return
!
!  real(z) < 0
!
   30 zz = -z
  z1 = csqrt(zz)
  z2 = csqrt(z1)
  z2r = 1.0/z2
  call crec (real(zz), aimag(zz), u, v)
  w = 1.5*cmplx(u,v)/z1
  u = abs(real(w))
  v = abs(aimag(w))
  t = max ( u,v)
!
     if ( t == 0.0) go to 90
     u1 = u/t
     v1 = v/t
     r = u*u1 + v*v1
     if ( ind /= 0) go to 40
        if ( v1 >= r*xpos .or. u1 >= 0.1*r/eps) go to 90
        zeta = z1*zz/1.5
        go to 50
   40    e = (0.0, 0.0)
     j = (0.0, -1.0)
     if ( aimag(z) < 0.0) j = (0.0, 1.0)
     if ( v1 > 0.5*r*abs(xneg)) go to 50
     if ( u1 >= 0.05*r/eps) go to 90
     zeta = z1*zz/1.5
     e = cexp(2.0*j*zeta)
!
   50 w2 =  w*w
  m = 15
  if ( t > 30.0) m = 5
  m2 = m + m
  i = m2 - 1
  s1 = cmplx(c(i),0.0)
  s2 = cmplx(c(m2),0.0)
  s3 = cmplx(d(i),0.0)
  s4 = cmplx(d(m2),0.0)
  do 60 k = 2,m
     i = i - 1
     s2 = c(i) - s2*w2
     s4 = d(i) - s4*w2
     i = i - 1
     s1 = c(i) - s1*w2
     s3 = d(i) - s3*w2
   60 continue
  s2 = w*s2
  s4 = w*s4

  if ( ind /= 0) go to 70
     cn = ccos(zeta)
     si = csin(zeta)
     go to 80
   70 cn = 0.5*(1.0 + e)
  si = 0.5*(1.0 - e)*j

   80 alpha = s1 - s2
  beta  = s1 + s2
  ai = c2*z2r*(alpha*cn + beta*si)
  alpha = s3 - s4
  beta  = s3 + s4
  aip = c2*z2*(alpha*si - beta*cn)
  return
!
!         return with zero values if scaling is needed
!
   90 ai = (0.0, 0.0)
  aip = (0.0, 0.0)
  ierr = 1
  return
end
function aie(x)
!
!*******************************************************************************
!
!! AIE computes the scaled Airy function.
!
!
!             aie(x) = exp(zeta)*ai(x)  when x >= 0
!             aie(x) = ai(x)            when x < 0
!
!             zeta = (2/3) * x**(3/2)
!
!
!     x0 = 2**(2/3)
!
  real aie
!
  data x0/.158740105196820e+01/
!
  data an0/ .355028053887818e+00/, an1/-.187394912983414e+00/, &
       an2/-.383735973881972e-01/, an3/ .491952571236878e-01/, &
       an4/-.967017625191329e-02/, an5/-.205648610308316e-02/, &
       an6/ .114176040526844e-02/, an7/-.117114823456866e-03/, &
       an8/-.270165470074755e-04/, an9/ .789002965889206e-05/
  data ad0/ .100000000000000e+01/, ad1/ .201179850513612e+00/, &
       ad2/ .385762517106249e-01/, ad3/ .230887443780120e-04/
!
  data bn0/ .355028053887817e+00/, bn1/-.997169317338190e-01/, &
       bn2/-.602216060213075e-01/, bn3/ .297705337630730e-01/, &
       bn4/-.152969932286570e-02/, bn5/-.147868368189372e-02/, &
       bn6/ .350518617006107e-03/, bn7/-.257766924610873e-04/
  data bd0/.100000000000000e+01/, bd1/.448140563306831e+00/, &
       bd2/.157074537566686e+00/, bd3/.316964519364865e-01/, &
       bd4/.485922740843953e-02/, bd5/.423326964456309e-03/
!
  data pn0/.282094378896566e+00/, pn1/.807868561687271e-01/, &
       pn2/.630644564152247e-02/, pn3/.147116711467936e-03/, &
       pn4/.750490748341483e-06/
  data pd0/.100000000000000e+01/, pd1/.292890323271551e+00/, &
       pd2/.239376862143358e-01/, pd3/.612353984250624e-03/, &
       pd4/.384461189764830e-05/, pd5/.123247804102182e-08/
!
  data qn0/.282094791017188e+00/, qn1/.149585822742689e+00/, &
       qn2/.241876418864958e-01/, qn3/.138190913282142e-02/, &
       qn4/.241862862465003e-04/, qn5/.709733720554615e-07/
  data qd0/.100000000000000e+01/, qd1/.536778341756648e+00/, &
       qd2/.889112579703465e-01/, qd3/.533368703697049e-02/, &
       qd4/.103812739863315e-03/, qd5/.408838544650398e-06/
!
  data rn0/.282094791773878e+00/, rn1/.203731967781874e+00/, &
       rn2/.436660479870037e-01/, rn3/.306595563073142e-02/, &
       rn4/.517398800281618e-04/
  data rd0/.100000000000000e+01/, rd1/.728721438361672e+00/, &
       rd2/.159210021472267e+00/, rd3/.116985268534248e-01/, &
       rd4/.225973894323078e-03/, rd5/.232707159780478e-06/
!
  if ( x >= -1.0) go to 10
  call aimp (-x, r, phi)
  aie = r*sin(phi)
  return

   10 if ( x >= 0.0) go to 20
  aie = (((((((((an9*x + an8)*x + an7)*x + an6)*x + an5)*x &
              + an4)*x + an3)*x + an2)*x + an1)*x + an0) / &
              (((ad3*x + ad2)*x + ad1)*x + ad0)
  return

   20 if ( x >= 1.0) go to 30
  aie = (((((((bn7*x + bn6)*x + bn5)*x + bn4)*x + bn3)*x + bn2)*x &
                     + bn1)*x + bn0) / &
        (((((bd5*x + bd4)*x + bd3)*x + bd2)*x + bd1)*x + bd0)
  if ( x > 1.e-20) aie = aie * exp(2.0*x*sqrt(x)/3.0)
  return

   30 rtx = sqrt(x)
  if ( x > x0) go to 40
  t = 16.0/(x*rtx)
  w = ((((pn4*t + pn3)*t + pn2)*t + pn1)*t + pn0) / &
      (((((pd5*t + pd4)*t + pd3)*t + pd2)*t + pd1)*t + pd0)
  aie = w/sqrt(rtx)
  return
!
   40 if ( x > 4.0d0) go to 50
  t = 16.0/(x*rtx)
  w = (((((qn5*t + qn4)*t + qn3)*t + qn2)*t + qn1)*t + qn0) / &
      (((((qd5*t + qd4)*t + qd3)*t + qd2)*t + qd1)*t + qd0)
  aie = w/sqrt(rtx)
  return

   50 if ( x > 1.e20) go to 60
  t = 16.0/(x*rtx)
  w = ((((rn4*t + rn3)*t + rn2)*t + rn1)*t + rn0) / &
      (((((rd5*t + rd4)*t + rd3)*t + rd2)*t + rd1)*t + rd0)
  aie = w/sqrt(rtx)
  return

   60 aie = rn0/sqrt(rtx)
  return
end
subroutine aii ( ind, z, ai, aip, ierr )
!
!*******************************************************************************
!
!! AII calculates the Airy function ai and its derivative aip
!     for complex argument z in the intermediate range 1 <=
!     cabs(z) <= 10.0.
!
  complex z, ai, aip, z1, z2, z3, zm, w1, w2, w1m, w2m, e
!
!     c1 = 1/(pi*sqrt(3))
!
  data c1/1.83776298473931e-01/
  ierr = 0
  a = real(z)
  b = aimag(z)
  r = cpabs(a, b)
  z1 = csqrt(z)
  z2 = z1*z/1.5
  if ( abs(b) < -5.0*a) go to 10
!
!           ----  abs(b) >= -5.0*a  ----
!
     call ka(ind, z2, w1, w2)
     ai = c1*z1*w1
     aip = -c1*z*w2
     return
!
!           ----  abs(b) < -5.0*a  ----
!
   10 if ( abs(b) < -1.74*a) go to 30
     if ( r >= 8.2) go to 40
   20    zm = -z
     z1 = csqrt(zm)
     z3 = z1*zm/1.5
     call ja(z3, w1, w2, w1m, w2m)
     ai = (z1/3.0)*(w1m +w1)
     aip = (z/3.0)*(w2m - w2)
     if ( ind == 0) return
        e = cexp(z2)
        ai = ai*e
        aip = aip*e
        return
   30 if ( r < 7.4) go to 20
   40 call aia (ind,z,ai,aip,ierr)
  return
end
subroutine aimp ( x, r, phi )
!
!*******************************************************************************
!
!! AIMP computes the Airy modulus and phase for x >= 1
!
  data pi4 /.785398163397448/
!
  data an0/.297640916735064e+00/, an1/.772796814419809e+00/, &
       an2/.764990563560236e+00/, an3/.375694096095838e+00/, &
       an4/.978661044870204e-01/, an5/.110446639522696e-01/, &
       an6/.145271249611697e-05/
  data ad0/.100000000000000e+01/, ad1/.247380029946443e+01/, &
       ad2/.240125897828762e+01/, ad3/.118267264172257e+01/, &
       ad4/.306942883081787e+00/, ad5/.347670057203535e-01/
!
  data bn0/.593601051670149e+00/, bn1/.223281495955754e+01/, &
       bn2/.317718143418600e+01/, bn3/.229890914530923e+01/, &
       bn4/.933580623665765e+00/, bn5/.209164380960390e+00/, &
       bn6/.207910965366403e-01/
  data bd0/.100000000000000e+01/, bd1/.345985556561483e+01/, &
       bd2/.479629661187354e+01/, bd3/.345429311552596e+01/, &
       bd4/.140017214942186e+01/, bd5/.313770549939860e+00/, &
       bd6/.311852186700025e-01/
!
  data cn0/.313541841678871e+00/, cn1/.470104287134296e+00/, &
       cn2/.291795874641314e+00/, cn3/.962250689852768e-01/, &
       cn4/.171024484244850e-01/, cn5/.134933201907052e-02/
  data cd0/.100000000000000e+01/, cd1/.148070947673639e+01/, &
       cd2/.917484386216329e+00/, cd3/.302281922152536e+00/, &
       cd4/.537309296828367e-01/, cd5/.423890576557513e-02/, &
       cd6/.525954318463502e-08/
!
  data dn0/.654836896032068e+00/, dn1/.117099614856528e+01/, &
       dn2/.831899010444840e+00/, dn3/.301060337976575e+00/, &
       dn4/.564712748150658e-01/, dn5/.444134415666317e-02/
  data dd0/.100000000000000e+01/, dd1/.176306543768126e+01/, &
       dd2/.124897609613487e+01/, dd3/.451576491257036e+00/, &
       dd4/.847085955634988e-01/, dd5/.666188176245820e-02/, &
       dd6/.537600060708764e-08/
!
  data pn0/.318309886183791e+00/, pn1/.100996327221962e+01/, &
       pn2/.902315148591491e+00/, pn3/.259820640977615e+00/, &
       pn4/.203717769716282e-01/, pn5/.216893438784765e-03/
  data pd0/.100000000000000e+01/, pd1/.317533460265059e+01/, &
       pd2/.284232123705698e+01/, pd3/.822777439238360e+00/, &
       pd4/.656865942543526e-01/, pd5/.775376048996392e-03/

  data qn0/.666666666666667e+00/, qn1/.141905542385598e+01/, &
       qn2/.772778148352443e+00/, qn3/.115170415082442e+00/, &
       qn4/.326457319318373e-02/
  data qd0/.100000000000000e+01/, qd1/.213102454203392e+01/, &
       qd2/.116432601041188e+01/, qd3/.175509465791633e+00/, &
       qd4/.528319849831061e-02/, qd5/.867802002275824e-05/
!
  if ( x > 2.0) go to 10
  z = x - 1.0
  r =   ((((((an6*z + an5)*z + an4)*z + an3)*z + an2)*z &
                    + an1)*z + an0) / &
        (((((ad5*z + ad4)*z + ad3)*z + ad2)*z + ad1)*z + ad0)
  phi = ((((((bn6*z + bn5)*z + bn4)*z + bn3)*z + bn2)*z &
                    + bn1)*z + bn0) / &
        ((((((bd6*z + bd5)*z + bd4)*z + bd3)*z + bd2)*z &
                    + bd1)*z + bd0)
  go to 40
!
   10 if ( x >= 4.0) go to 20
  z = x - 2.0
  r =   (((((cn5*z + cn4)*z + cn3)*z + cn2)*z + cn1)*z + cn0) / &
        ((((((cd6*z + cd5)*z + cd4)*z + cd3)*z + cd2)*z &
                    + cd1)*z + cd0)
  phi = (((((dn5*z + dn4)*z + dn3)*z + dn2)*z + dn1)*z + dn0) / &
        ((((((dd6*z + dd5)*z + dd4)*z + dd3)*z + dd2)*z &
                    + dd1)*z + dd0)
  go to 40
!
   20 if ( x > 1.e10) go to 30
  z = 64.0/x**3
  r =   (((((pn5*z + pn4)*z + pn3)*z + pn2)*z + pn1)*z + pn0) / &
        (((((pd5*z + pd4)*z + pd3)*z + pd2)*z + pd1)*z + pd0)
  phi = ((((qn4*z + qn3)*z + qn2)*z + qn1)*z + qn0) / &
        (((((qd5*z + qd4)*z + qd3)*z + qd2)*z + qd1)*z + qd0)
  go to 40
!
   30 r = pn0
  phi = qn0

 40   rtx = sqrt(x)
  r = sqrt(r/rtx)
  phi = pi4 + x*rtx*phi
  return
end
subroutine airm (ind,z,ai,aip,bi,bip)
!
!*******************************************************************************
!
!! AIRM calculates the Airy functions ai and bi and their
!     derivatives aip and bip by use of their maclaurin
!     expansions.
!
  complex ai, aip, bi, bip, z, z1, z2, z3, zz, f, f1, g, g1, &
          e, e1
  real a(8), b(8), c(8), d(8)
!
!     c1 = 3**(-2/3)/gamma(2/3)
!     c2 = 3**(-1/3)/gamma(1/3)
!
  data c1/3.55028053887817e-01/, c2/2.58819403792807e-01/, &
       sqt3/1.73205080756888e+00/
!
  data a(1) /.166666666666667e+00/, a(2) /.555555555555556e-02/, &
       a(3) /.771604938271605e-04/, a(4) /.584549195660307e-06/, &
       a(5) /.278356759838241e-08/, a(6) /.909662613850462e-11/, &
       a(7) /.216586336631062e-13/, a(8) /.392366551867867e-16/
  data b(1) /.833333333333333e-01/, b(2) /.198412698412698e-02/, &
       b(3) /.220458553791887e-04/, b(4) /.141319585764030e-06/, &
       b(5) /.588831607350126e-09/, b(6) /.172172984605300e-11/, &
       b(7) /.372668797846970e-14/, b(8) /.621114663078283e-17/
  data c(1) /.333333333333333e-01/, c(2) /.694444444444444e-03/, &
       c(3) /.701459034792368e-05/, c(4) /.417535139757362e-07/, &
       c(5) /.163739270493083e-09/, c(6) /.454831306925231e-12/, &
       c(7) /.941679724482880e-15/, c(8) /.150910212256872e-17/
  data d(1) /.333333333333333e+00/, d(2) /.138888888888889e-01/, &
       d(3) /.220458553791887e-03/, d(4) /.183715461493239e-05/, &
       d(5) /.942130571760201e-08/, d(6) /.327128670750070e-10/, &
       d(7) /.819871355263333e-13/, d(8) /.155278665769571e-15/
!
  z2 = z*z
  z3 = z*z2
!
!     summation of f and g
!
  f = cmplx(a(8),0.0)
  g = cmplx(b(8),0.0)
  do 10 n = 1, 7
     i = 8 - n
     f = a(i) + z3*f
     g = b(i) + z3*g
   10 continue
  f = 1.0 + z3*f
  g = z + z2*z2*g
!
!     summation of f1 and g1
!
  f1 = cmplx(c(8),0.0)
  g1 = cmplx(d(8),0.0)
  do 20 n = 1,7
     i = 8 - n
     f1 = c(i) + z3*f1
     g1 = d(i) + z3*g1
   20 continue
  f1 = z2*(0.5 + z3*f1)
  g1 = 1.0 + z3*g1
!
!     final assembly
!
  ai = c1*f - c2*g
  bi = sqt3*(c1*f + c2*g)
  aip = c1*f1 - c2*g1
  bip = sqt3*(c1*f1 + c2*g1)
  if ( ind == 0) return
     x = real(z)
     y = aimag(z)
     z1 = csqrt(z)
     zz = z*z1/1.5
     e = cexp(zz)
     e1 = 1.0/e
     ai = ai*e
     aip = aip*e
     if ( abs(y) > x*sqt3) go to 30
        bi = bi*e1
        bip = bip*e1
        return
   30    bi = bi*e
     bip = bip*e
  return
end
subroutine airy_values ( n, x, ax, ap, bx, bp )
!
!*******************************************************************************
!
!! AIRY_VALUES returns some values of the Airy function for testing.
!
!
!  Modified:
!
!    18 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real AX, AP, the value and derivative of the Airy AI function.
!
!    Output, real BX, BP, the value and derivative of the Airy BI function.
!
  integer, parameter :: nmax = 11
!
  real ap
  real, save, dimension ( nmax ) :: apvec = (/ &
    -0.25881940E+00, -0.25713042E+00, -0.25240547E+00, -0.24514636E+00, &
    -0.23583203E+00, -0.22491053E+00, -0.21279326E+00, -0.19985119E+00, &
    -0.18641286E+00, -0.17276384E+00, -0.15914744E+00 /)
  real ax
  real, save, dimension ( nmax ) :: axvec = (/ &
    0.35502805E+00, 0.32920313E+00, 0.30370315E+00, 0.27880648E+00, &
    0.25474235E+00, 0.23169361E+00, 0.20980006E+00, 0.18916240E+00, &
    0.16984632E+00, 0.15188680E+00, 0.13529242E+00 /)
  real bp
  real, save, dimension ( nmax ) :: bpvec = (/ &
    0.44828836E+00, 0.45151263E+00, 0.46178928E+00, 0.48004903E+00, &
    0.50728168E+00, 0.54457256E+00, 0.59314448E+00, 0.65440592E+00, &
    0.73000690E+00, 0.82190389E+00, 0.93243593E+00 /)
  real bx
  real, save, dimension ( nmax ) :: bxvec = (/ &
    0.61492663E+00, 0.65986169E+00, 0.70546420E+00, 0.75248559E+00, &
    0.80177300E+00, 0.85427704E+00, 0.91106334E+00, 0.97332866E+00, &
    1.04242217E+00, 1.11987281E+00, 1.20742359E+00 /)
  real fx
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00, &
    0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00, &
    0.8E+00, 0.9E+00, 1.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    ax = 0.0E+00
    ap = 0.0E+00
    bx = 0.0E+00
    bp = 0.0E+00
    return
  end if

  x = xvec(n)
  ax = axvec(n)
  ap = apvec(n)
  bx = bxvec(n)
  bp = bpvec(n)

  return
end
function algdiv (a, b)
!
!*******************************************************************************
!
!! ALGDIV computes ln(gamma(b)/gamma(a+b)) when b >= 8
!
!
!     in this algorithm, del(x) is the function defined by
!     ln(gamma(x)) = (x - 0.5)*ln(x) - x + 0.5*ln(2*pi) + del(x).
!
  real algdiv
  data c0/.833333333333333e-01/, c1/-.277777777760991e-02/, &
       c2/.793650666825390e-03/, c3/-.595202931351870e-03/, &
       c4/.837308034031215e-03/, c5/-.165322962780713e-02/
!
  if ( a > b) then
    h = b/a
    c = 1.0/(1.0 + h)
    x = h/(1.0 + h)
    d = a + (b - 0.5)
  else
    h = a/b
    c = h/(1.0 + h)
    x = 1.0/(1.0 + h)
    d = b + (a - 0.5)
  end if
!
!  set sn = (1 - x**n)/(1 - x)
!
  x2 = x*x
  s3 = 1.0 + (x + x2)
  s5 = 1.0 + (x + x2*s3)
  s7 = 1.0 + (x + x2*s5)
  s9 = 1.0 + (x + x2*s7)
  s11 = 1.0 + (x + x2*s9)
!
!                set w = del(b) - del(a + b)
!
  t = (1.0/b)**2
  w = ((((c5*s11*t + c4*s9)*t + c3*s7)*t + c2*s5)*t + c1*s3)*t + c0
  w = w*(c/b)
!
!                    combine the results
!
  u = d*alnrel(a/b)
  v = a*(alog(b) - 1.0)
  if ( u <= v) go to 30
     algdiv = (w - v) - u
     return
   30 algdiv = (w - u) - v
  return
end
subroutine allot(degree,npolys,npts,dimen,iwork,iwklen, &
                   ireqd,dreqd,error)
!
!*******************************************************************************
!
!! ALLOT checks for sufficiency the declared  dimensions  of  the
!     work  arrays  used by the subroutine  mfit .  various sizes of
!     sub-arrays are computed and reported.
!
!     this routine is called by  mfit .  it is not  called  directly
!     by the user.
!
!     this routine calls   basiz   and   mtable   for  the  substantive
!     computations.
!
!     variables
!     ---------
!
!      degree  - (passed/returned)
!         ignored if < 0.
!         if  degree  >= 0 then  degree is checked  against   npts .
!         the value of  degree  will be reduced if there is a basis of
!         multinomials, all of  degree <=  degree ,  of  cardinality
!          npts
!      npolys  - (passed/returned)
!         ignored if  degree  >= 0.
!         if degree < 0 then the value of npolys will be taken  as
!         the size of the basis of multinomials to be used in the fit.
!         npolys  must satisfy npolys <  npts  and  npolys  >= 1
!      npts  --- (passed)
!         the number of data points to be used in the fit.
!          npts  must be >= 1.
!      dimen  -- (passed)
!         the number of variables.
!      iwork  -- (returned)
!         an integer work array of length at least
!            if  degree  >= 0 then
!               4*binomial( dimen + degree , dimen )
!                  +( dimen )*( degree )
!            else
!               4*binomial( dimen +d,d)+( dimen )*d
!         where d is the minimum cardinality  of  a  basis  of  degree
!          degree  such that
!            binomial( dimen +abs( degree ), dimen ) >=  npolys
!      iwklen  - (passed)
!         the length of  iwork
!      ireqd  -- (returned)
!         the size of the integer work array required by  mfit   for
!         the fit specified by the 4 input parameters.
!      dreqd  -- (returned)
!         the size of the double  precision  work  array  required  by
!          mfit  for the fit specified by the 4 input parameters.
!      error  -- (returned)
!       0 if  npolys ,  dimen ,   degree ,   npts   and   iwklen   are
!         valid and consistent with each other.
!       1 if  degree  >= 0 but there is an interpolating multinomial
!         of smaller degree or if  degree < 0 and  npolys > npts
!       2 if  degree  < 0 and  npolys  <= 0
!       3 if  npts  < 1 and/or  dimen  < 1
!       4 if  iwklen  is too small (set  iwklen  to the value returned
!         in  ireqd  to resolve this problem)
!
!     note that  degree ,  npolys ,  psiwid  and  alfl   are  returned
!     in  iwork (1-4), respectively.
!
!     date last modified
!     ---- ---- --------
!     december 10, 1984
!     ****************
!
  integer ireqd,dreqd,alfl,error,npolys,degree,dimen,npts
  integer newstt,psiwid,kmxbas,startj,kjp1d2,index,iwklen
  integer nplyt4
  integer iwork(iwklen)
!
!     basiz  computes the size of the basis (and auxiliary sizes)
!     based primarily upon the degree, number of  fitting points,
!     and the dimension.
!
  call basiz(degree,npts,dimen,npolys,error)
  if ( error >= 2 ) return
  ireqd = 4 * npolys + degree * dimen
  if ( iwklen >= ireqd ) go to 5
     error = 4
     return
 5    newstt = 4 * npolys + 1
!
!     set up useful indexing arrays
!          iwork(1) ,..., iwork(newstt-1)
!     and
!          iwork(newstt ,..., iwork(newstt+dimen*degree)
!
  call mtable(degree,dimen,npolys,iwork,iwork(newstt),alfl)
  iwork(1) = degree
  iwork(2) = npolys
!
!     force  alfl  to be at least 1 so that dimension statements
!     using  alfl  do not bomb.
!
  if ( alfl > 1 ) alfl = alfl - 1
  iwork(4) = alfl
!
!     ***************
!     the following is a section of code for setting up the
!     storage  management of the  psi  array.  there  is  a
!     complicated dovetailing formula used to pack information
!     into  psi  without leaving gaps.
!
!     array          length
!     -----          ------
!      maxabs         dimen  + 1
!      alpha          alfl
!      c              npolys
!      sumsqs         npolys
!
!     the number of columns in  psi ,  psiwid , is determined by
!     psiwid  =  npolys  + 1 - (the smallest m such that alpha(j,m)
!                                   is nonzero and j >= npolys)
!     this insures that if the user extends the basis, all the  psi
!     required will certainly be stored
!
!     if degree( npolys ) <= 2 then                      (case 1)
!       psiwid  =  npolys
!     else
!       if k =  dimen  then                                (case 2)
!         psiwid  =  npolys
!                    -  newkj( 1 , degree(npolys)-1 )  + 1
!       else
!            psiwid  =  npolys
!                      + 1
!                      - (
!                         the smaller of
!                           newkj(k+1,degree(npolys)-2)    (case 3)
!                         and
!                           indexs(3,npolys)               (case 4)
!                        )
!
  if ( degree > 2 ) go to 10
!
!     case 1
!
     psiwid = npolys
  go to 40
 10      nplyt4 = 4 * npolys
!
!     kmxbas  is k
!                 npolys
!     ***************
!
     kmxbas = iwork(nplyt4 - 2)
!
     if ( kmxbas /= dimen ) go to 20
!
!     ***************
!     case 2
!     ***************
!
        psiwid = npolys - iwork(4 * npolys - 1)
     go to 40
!
!     ***************
!     index =  newkj( k      + 1 , degree(npolys-2) )
!                      npolys
!     ***************
!
 20         index = nplyt4 + (degree - 3) * dimen + kmxbas + 1
        kjp1d2 = iwork(index)
!
!  startj  =  indexs(3,npolys)
!
        startj = iwork(nplyt4 - 1)
        if ( startj > kjp1d2 ) go to 30
!
!  case 4
!
           psiwid = npolys - startj + 1
        go to 40
!
!     case 3
!
 30            psiwid = npolys - kjp1d2 + 1
 40   iwork(3) = psiwid
  dreqd = 2 * npolys + dimen + 1 + npts * psiwid + alfl
  return
end
function alnrel(a)
!
!*******************************************************************************
!
!! ALNREL evaluates the function ln(1 + a)
!
  real a
  real alnrel
!
  data p1/-.129418923021993e+01/, p2/.405303492862024e+00/, &
       p3/-.178874546012214e-01/
  data q1/-.162752256355323e+01/, q2/.747811014037616e+00/, &
       q3/-.845104217945565e-01/
!
  if ( abs(a) > 0.375) go to 10
  t = a/(a + 2.0)
  t2 = t*t
  w = (((p3*t2 + p2)*t2 + p1)*t2 + 1.0)/ &
      (((q3*t2 + q2)*t2 + q1)*t2 + 1.0)
  alnrel = 2.0*t*w
  return
!
   10 x = 1.d0 + dble(a)
  alnrel = alog(x)
  return
end
subroutine aord (a, n)
!
!*******************************************************************************
!
!! AORD reorders the elements of a so that abs(a(i)) <= abs(a(i+1))
!  for i = 1,...,n-1. it is assumed that n >= 1.
!
  real a(n)
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if ( n < 2) return
  imax = 1
  do 10 i = 3,10
     if ( n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!                 so that abs(a(j)) <= abs(a(j+ki))
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if ( abs(s) >= abs(a(l))) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if ( l > 0) go to 30
   31    a(ll) = s

   40 i = i - 1
  return
end
subroutine arcebe(block, nrwblk, nclpiv, novrlp, pivot, x)
!
!*****************************************************************************80
!
!! ARCEBE performs the backward elimination step in solution phase of arceco.
!
  real block, x, dotprd, swap
  integer pivot(nrwblk), pivotj
  dimension block(nrwblk,novrlp), x(*)
  do 40 nj=1,nclpiv
    j = nclpiv + 1 - nj
    i = nrwblk + 1 - nj
    dotprd = x(j)
    if ( j==novrlp) go to 20
    jplus1 = j + 1
    do 10 j1=jplus1,novrlp
      dotprd = dotprd - x(j1)*block(i,j1)
   10   continue
   20   continue
    x(j) = dotprd
    pivotj = pivot(j)
    if ( pivotj==j) go to 30
    swap = x(pivotj)
    x(pivotj) = x(j)
    x(j) = swap
   30   continue
   40 continue
  return
end
subroutine arcebm(block, nrwblk, nclblk, nrwpiv, b, x)
!
!*****************************************************************************80
!
!! ARCEBM performs backward modification step in the solution phase of arceco.
!
  real block, b, x, xj
  dimension block(nrwblk,nclblk), b(*), x(*)
  nrwpv1 = nrwpiv + 1
  do 20 j=nrwpv1,nclblk
    xj = x(j)
    do 10 l=1,nrwpiv
      b(l) = b(l) - block(l,j)*xj
   10   continue
   20 continue
  return
end
subroutine arcebs(block, nrwblk, nclblk, nrwpiv, b, x)
!
!*******************************************************************************
!
!! ARCEBS performs the backward solution step in the solution phase of arceco.
!
  real block, b, x, xj
  dimension block(nrwblk,nclblk), b(*), x(*)
  do 20 nj=1,nrwpiv
    j = nrwpiv - nj + 1
    x(j) = b(j)/block(j,j)
    if ( j==1) return
    jmin1 = j - 1
    xj = x(j)
    do 10 l=1,jmin1
      b(l) = b(l) - block(l,j)*xj
   10   continue
   20 continue
  return
end
subroutine arceco(n, array, mtrstr, nmblks, pivot, b, x, iflag)
!
!*******************************************************************************
!
!! ARCECO solves the linear system  a*x = b  where  a is
!  an almost block diagonal matrix.  the method implemented is
!  based on gauss elimination with alternate row and column
!  elimination with partial pivoting, which produces a stable
!  decomposition of the matrix  a  without introducing fill-in.
!
!  parameters
!
!       *** on entry ...
!
!                n     - integer
!                         the order of the linear system, where
!                           n = sum(mtrstr(1,k),k=1,nmblks)
!
!                array - real(numels)
!                         where
!                          numels = sum(mtrstr(1,k)*mtrstr(2,k),
!                               k=1,nmblks).
!                         contains the entries of the almost
!                         block diagonal matrix  a  whose block
!                         structure is given by the integer array
!                         mtrstr. the elements of a are stored by
!                         columns, in blocks corresponding to the
!                         given structure.
!
!               mtrstr - integer(3,nmblks)
!                         describes the block structure of  a ...
!                           mtrstr(1,k)  = number of rows in
!                                            block k.
!                           mtrstr(2,k)  = number of columns in
!                                            block k.
!                           mtrstr(3,k)  = number of columns
!                                          overlapped by block k
!                                          and block (k+1).
!                        mtrstr must satisfy some restrictions.
!                         in order that a be square, we need
!                         sum(mtrstr(1,k),k=1,nmblks) = n =
!                         sum((mtrstr(2,k)-mtrstr(3,k)),k=1,nmblks).
!                        in addition, to ensure that three success-
!                         ive blocks do not have columns in common,
!                         mtrstr must satisfy
!                         mtrstr(3,k-1)+mtrstr(3,k)<=mtrstr(2,k),
!                         for k = 2,nmblks.
!                        finally,  a r c e c o,  sets
!                         mtrstr(3,nmblks) = 0, in arcecd.
!
!               nmblks - integer
!                         total number of blocks in  a
!
!                pivot - integer(n)
!                         work space
!
!                    b - real(n)
!                         the right hand side vector
!
!                    x - real(n)
!                         work space
!
!       *** on return  ...
!
!                array - real(numels)
!                         contains the modified alternate row
!                         and column decomposition of  a (if
!                         iflag = 0)
!
!                pivot - integer(n)
!                         records the pivoting indices deter-
!                         mined in the decomposition
!
!                    x - real(n)
!                         the solution vector (if iflag = 0)
!
!                iflag - integer
!                         =  1,if input parameters are invalid
!                         = -1, if matrix is singular
!                         =  0, otherwise
!
!               *****  auxiliary programs  *****
!
!            arcedc(array,mtrstr,nmblks,pivot,iflag)
!               - decomposes the matrix  a  using modified
!                 alternate row and column elimination
!                 with partial pivoting, and is used for
!                 this purpose in  a r c e c o.
!                 the arguments are all as in a r c e c o.
!
!            arcesl(array,mtrstr,nmblks,pivot,b,x)
!               - solves the system  a*x = b  once  a  is
!                 decomposed.
!                 the arguments are all as in a r c e c o .
!
!               *****  block structure of  a  *****
!
!  the nmblks blocks of a are stored consecutively in the one
!  dimensional matrix  array, the entries of  a  being stored
!  as follows ...
!
!       in array(1)     the (1,1) entry of the top block,
!
!       in array(index) the (1,1) entry of the ith block where
!                       index = 1 + sum(mtrstr(1,j)*mtrstr(2,j),
!                               j=1,i-1), i=2,nmblks.
!
!       the subroutine  a r c e c o  automatically solves the
!  input system when iflag=0.  a r c e c o  is called only once
!  for a given system. the solution for a sequence of p right
!  hand sides can be obtained by one call to  a r c e c o  and
!  p-1 calls to arcesl only. since the arrays array and
!  pivot contain, respectively, the decomposition of the given
!  coefficient matrix and pivoting information on return from
!  a r c e c o , they must not be altered between successive
!  calls to arcesl with the same right hand sides. for the
!  same reason, if the user wishes to save the coefficient
!  matrix, the array array must be copied before a call
!  to  a r c e c o .
!
  real array, b, x
  integer mtrstr(3,*), pivot(*)
  dimension array(*), b(*), x(*)
  call arcedc(n, array, mtrstr, nmblks, pivot, iflag)
  if ( iflag/=0) return
  call arcesl(array, mtrstr, nmblks, pivot, b, x)
  return
end
subroutine arcedc(n, array, mtrstr, nmblks, pivot, iflag)
!
!*******************************************************************************
!
!! ARCEDC supervises the modified alternate row and column decomposition
!  with partial pivoting of the almost block
!  diagonal matrix  a   stored in the arrays a r r a y  and
!  m t r s t r .
!
!               *****  parameters  *****
!
!       *** on entry ...
!
!                n     - integer
!                         the order of the linear system, where
!                           n = sum(mtrstr(1,k),k=1,nmblks)
!
!                array - real(numels)
!                         where
!                          numels = sum(mtrstr(1,k)*mtrstr(2,k),
!                               k=1,nmblks).
!                         contains the entries of the almost
!                         block diagonal matrix  a  whose block
!                         structure is given by the integer array
!                         mtrstr. the elements of a are stored by
!                         columns, in blocks corresponding to the
!                         given structure.
!               mtrstr - integer(3,nmblks)
!                         describes the block structure of  a ...
!                           mtrstr(1,k)  = number of rows in
!                                            block k.
!                           mtrstr(2,k)  = number of columns in
!                                            block k.
!                           mtrstr(3,k)  = number of columns
!                                          overlapped by block k
!                                          and block (k+1).
!                        mtrstr must satisfy some restrictions.
!                         in order that a be square, we need
!                         sum(mtrstr(1,k),k=1,nmblks) = n =
!                         sum((mtrstr(2,k)-mtrstr(3,k)),k=1,nmblks).
!                        in addition, to ensure that three success-
!                         ive blocks do not have columns in common,
!                         mtrstr must satisfy
!                         mtrstr(3,k-1)+mtrstr(3,k)<=mtrstr(2,k),
!                         for k = 2,nmblks.
!                        finally,  a r c e c o,  sets
!                         mtrstr(3,nmblks) = 0, in arcecd.
!
!               nmblks - integer
!                         total number of blocks
!
!                pivot - integer(n)
!                         work space
!
!       *** on return  ...
!
!                array - real(numels)
!                         contains the modified alternate row
!                         and column decomposition of  a (if
!                         iflag = 0)
!
!                pivot - integer(n)
!                         records the pivoting indices deter-
!                         mined in the decomposition
!
!                iflag - integer
!                         =  1, if input parameters are invalid
!                         = -1, if matrix is singular
!                         =  0, otherwise
!
!               *****  auxiliary programs  *****
!
!       arcepr(block,nrwblk,nclblk,nrwpiv,pivot,pivmax,iflag)
!        carries out the row eliminations
!
!       arcepc(topblk,nrwtop,novrlp,botblk,nrwbot,nclpiv,
!            pivot,pivmax,iflag)
!        carries out the column eliminations
!
  real array, pivmax, zero
  integer pivot(*)
  dimension array(*), mtrstr(3,*)
  data zero /0.0/
!
!       ****  check validity of the input parameters....
!
!            if parameters are invalid then terminate at 7,
!                                      else continue at 8.
!
!
  mtrstr(3,nmblks) = 0
  do 10 k=2,nmblks
    if ( mtrstr(3,k-1)+mtrstr(3,k)>mtrstr(2,k)) go to 30
   10 continue
  isum1 = 0
  isum2 = 0
  do 20 k=1,nmblks
    isum1 = isum1 + mtrstr(1,k)
    isum2 = isum2 + mtrstr(2,k) - mtrstr(3,k)
   20 continue
  if ( isum1/=isum2) go to 30
  if ( isum1/=n) go to 30
!
!  parameters are acceptable - continue at 8
!
  go to 40
   30 continue
!
!  parameters are invalid.  set iflag = 1, and terminate
!
  iflag = 1
  return
   40 continue
!
!  internal parameters ...
!
!  index1  pointer to the element in the column where row pivoting starts.
!
!  index2  pointer to the element in the column where column pivoting starts.
!
!  index3  pointer to 1st element in 1st column of next block.
!
!  indpiv  pointer to 1st element of block of pivot
!
!  nrwblk  number of rows in block.
!
!  nrwbk2  number of rows in next block.
!
!  nrwpiv  number of row eliminations.
!
!  nclblk  number of columns in block to be row pivoted.
!
!  nclpiv  number of column eliminations.
!
!  novrlp  number of columns overlapped by the current block and the next block.
!
  pivmax = zero
  iflag = 0
  index1 = 1
  indpiv = 1
  nrwblk = mtrstr(1,1)
  nclblk = mtrstr(2,1)
  novrlp = mtrstr(3,1)
  nrwpiv = nclblk - novrlp
!
!  call arcepr to perform nrwpiv row eliminations on top block.
!
  if ( nrwpiv>0) call arcepr(array(index1), nrwblk, nclblk, &
   nrwpiv, pivot(indpiv), pivmax, iflag)

  if ( iflag<0) return
!
!  now do decomposition proceeding one block at a time.
!
  do 70 k=2,nmblks
    indpiv = indpiv + nrwpiv
    index2 = index1 + nrwblk*nrwpiv
    index3 = index2 + nrwblk*novrlp
    nclpiv = nrwblk - nrwpiv
    nrwbk2 = mtrstr(1,k)
!
!  call arcepc to perform nclpiv column eliminations.
!
    if ( nclpiv==0) go to 50
    call arcepc(array(index2), nrwblk, novrlp, array(index3), &
     nrwbk2, nclpiv, pivot(indpiv), pivmax, iflag)

    if ( iflag<0) return
   50   continue
    nrwblk = nrwbk2
    index1 = index3 + nrwblk*nclpiv
    nclblk = mtrstr(2,k) - nclpiv
    novrlp = mtrstr(3,k)
    nrwpiv = nclblk - novrlp
    indpiv = indpiv + nclpiv
!
!  call arcepr to perform nrwpiv row eliminations.
!
    if ( nrwpiv==0) go to 60
    call arcepr(array(index1), nrwblk, nclblk, nrwpiv, &
     pivot(indpiv), pivmax, iflag)
!
! if matrix is singular return.
!
    if ( iflag<0) return
   60   continue
   70 continue
  return
end
subroutine arcefe(block, nrwblk, nrwpiv, pivot, b)
!
!*******************************************************************************
!
!! ARCEFE performs the forward elimination step in the solution phase of arceco.
!
  real block, b, bi, swap
  integer pivot(nrwpiv), pivoti
  dimension block(nrwblk,nrwpiv), b(*)
  do 30 i=1,nrwpiv
    pivoti = pivot(i)
    if ( pivoti==i) go to 10
    swap = b(i)
    b(i) = b(pivoti)
    b(pivoti) = swap
   10   continue
    if ( i==nrwblk) return
    bi = b(i)
    iplus1 = i + 1
    do 20 l=iplus1,nrwblk
      b(l) = b(l) - block(l,i)*bi
   20   continue
   30 continue
  return
end
subroutine arcefm(block, nrwblk, nclpiv, b, x)
!
!*****************************************************************************80
!
!! ARCEFM performs the forward modification step in solution phase of arceco.
!
  real block, b, x, xj
  dimension block(nrwblk,nclpiv), b(*), x(*)
  do 20 j=1,nclpiv
    xj = x(j)
    do 10 l=1,nrwblk
      nclpvl = nclpiv + l
      b(nclpvl) = b(nclpvl) - block(l,j)*xj
   10   continue
   20 continue
  return
end
subroutine arcefs(block, nrwblk, nclpiv, novrlp, b, x)
!
!*******************************************************************************
!
!! ARCEFS performs the forward solution step in the solution phase of arceco.
!
  real block, b, x, xj
  dimension block(nrwblk,novrlp), b(*), x(*)
  do 20 j=1,nclpiv
    i = nrwblk - nclpiv + j
    x(j) = b(j)/block(i,j)
    if ( i==nrwblk) return
    long = nrwblk - i
    xj = x(j)
    do 10 l=1,long
      iplusl = i + l
      jplusl = j + l
      b(jplusl) = b(jplusl) - block(iplusl,j)*xj
   10   continue
   20 continue
  return
end
subroutine arcepc(topblk, nrwtop, novrlp, botblk, nrwbot, nclpiv, &
   pivot, pivmax, iflag)
!
!*******************************************************************************
!
!! ARCEPC performs nclpiv column eliminations on the matrices topblk and botblk
!
  real topblk, botblk, colmax, pivmax, colmlt
  real tempiv, swap
  integer max3
  integer pivot(nrwtop)
  dimension topblk(nrwtop,novrlp), botblk(nrwbot,novrlp)
!
!  perform the column eliminations on a loop.
!
  do 110 j=1,nclpiv
    i = nrwtop - nclpiv + j
!
!  determine column pivot and pivot index
!
    max3 = j
    colmax = abs(topblk(i,j))
    if ( j==novrlp) go to 30
    jplus1 = j + 1
    do 20 j1=jplus1,novrlp
      tempiv = abs(topblk(i,j1))
      if ( tempiv<=colmax) go to 10
      colmax = tempiv
      max3 = j1
   10     continue
   20   continue
   30   continue
!
!  test for singularity ...
!
    if ( pivmax+colmax==pivmax) then
      iflag = -1
      return
    end if
 
    pivmax = max ( pivmax,colmax)
!
!  if necessary interchange columns
!
    pivot(j) = max3
    if ( j == max3 ) go to 60
    do 40 i1=i,nrwtop
      swap = topblk(i1,j)
      topblk(i1,j) = topblk(i1,max3)
      topblk(i1,max3) = swap
   40   continue
    do 50 i2=1,nrwbot
      swap = botblk(i2,j)
      botblk(i2,j) = botblk(i2,max3)
      botblk(i2,max3) = swap
   50   continue
   60   continue
    if ( j==novrlp) return
!
!  compute multipliers and perform column elimination
!
    do 100 j1=jplus1,novrlp
      colmlt = topblk(i,j1)/topblk(i,j)
      topblk(i,j1) = colmlt
      if ( i==nrwtop) go to 80
      iplus1 = i + 1
      do 70 l1=iplus1,nrwtop
        topblk(l1,j1) = topblk(l1,j1) - colmlt*topblk(l1,j)
   70     continue
   80     continue
      do 90 l1=1,nrwbot
        botblk(l1,j1) = botblk(l1,j1) - colmlt*botblk(l1,j)
   90     continue
  100   continue
  110 continue
  return
end
subroutine arcepr(block, nrwblk, nclblk, nrwpiv, pivot, pivmax, &
   iflag)
!
!*******************************************************************************
!
!! ARCEPR performs nrwpiv row eliminations on the matrix block
!
  integer pivot(nrwblk)
  integer max3
  real block, rowmax, pivmax, tempiv, rowpiv, swap
  dimension block(nrwblk,nclblk)
!
!  perform nrwpiv row eliminations...
!
  do 90 j=1,nrwpiv
    jplus1 = j + 1
!
!  determine row pivot and pivot index
!
    max3 = j
    rowmax = abs(block(j,j))
    if ( j==nrwblk) go to 30
    do 20 i1=jplus1,nrwblk
      tempiv = abs(block(i1,j))
      if ( tempiv<=rowmax) go to 10
      rowmax = tempiv
      max3 = i1
   10     continue
   20   continue
   30   continue
!
!  test for singularity ...
!  if singular then terminate at 90, else continue.
!
    if ( pivmax+rowmax==pivmax) go to 100
    pivmax = max ( pivmax,rowmax)
!
! if necessary interchange rows
!
    pivot(j) = max3
    if ( j==max3) go to 50
    do 40 j1=j,nclblk
      swap = block(max3,j1)
      block(max3,j1) = block(j,j1)
      block(j,j1) = swap
   40   continue
   50   continue
    if ( j==nrwblk) return
!
!  compute the multipliers
!
    rowpiv = block(j,j)
    do 60 i1=jplus1,nrwblk
      block(i1,j) = block(i1,j)/rowpiv
   60   continue
!
!  perform row eliminations with column indexing
!
    do 80 j1=jplus1,nclblk
      do 70 l1=jplus1,nrwblk
        block(l1,j1) = block(l1,j1) - block(l1,j)*block(j,j1)
   70     continue
   80   continue
   90 continue
  return
  100 continue
!
!  matrix is singular - set iflag = -1.
!
  iflag = -1
  return
end
subroutine arcesl(array, mtrstr, nmblks, pivot, b, x)
!
!*******************************************************************************
!
!! ARCESL supervises the solution of the linear system
!                          a*x = b
!  using the decomposition of the matrix  a  already generated
!  in  a r c e d c.  it involves two loops, the forward loop,
!  consisting of forward solution, forward modification, and
!  forward elimination, and the backward loop, consisting of
!  backward solution, backward modification, and backward
!  elimination.
!
!               *****  parameters  *****
!
!       *** on entry ...
!
!                array - real(numels)
!                         where
!                          numels = sum(mtrstr(1,k)*mtrstr(2,k),
!                               k=1,nmblks).
!                         output from a r c e d c
!
!               mtrstr - integer(3,nmblks)
!                         describes the block structure of  a ...
!                           mtrstr(1,k)  = number of rows in
!                                            block k.
!                           mtrstr(2,k)  = number of columns in
!                                            block k.
!                           mtrstr(3,k)  = number of columns
!                                          overlapped by block k
!                                          and block (k+1).
!
!                        the linear system is of order
!                           n  = sum(mtrstr(1,k),k=1,nmblks)
!
!               nmblks - integer
!                         total number of blocks in  a
!
!                pivot - integer(n)
!                         output from a r c e d c
!
!                    b - real(n)
!                         the right hand side vector
!
!                    x - real(n)
!                         work space
!
!       *** on return  ...
!
!
!                    x - real(n)
!                         the solution vector
!
!               *****  auxiliary programs  *****
!
!
!       arcefs - performs forward solution step
!
!       arcefm - performs forward modification step
!
!       arcefe - performs forward elimination step
!
!       arcebs - performs backward solution step
!
!       arcebm - performs backward modification step
!
!       arcebe - performs backward elimination step
!
  real array, b, x
  integer pivot(*)
  dimension array(*), mtrstr(3,*), b(*), x(*)
  indpiv = 1
!
!  indexa  pointer to 1st element of block of a.
!
!  indexb  pointer to 1st element of block of b.
!
!  indpiv,nrwblk,nrwpiv,nclblk,nclpiv,novrlp are as in arcedc.
!
  indexa = 1
  nrwblk = mtrstr(1,1)
  nclblk = mtrstr(2,1)
  novrlp = mtrstr(3,1)
  nrwpiv = nclblk - novrlp
!
!  call arcefe to perform forward elimination.
!
  if ( nrwpiv>0) call arcefe(array(indexa), nrwblk, nrwpiv, &
   pivot(indpiv), b(indpiv))
!
!  forward loop
!
  do 10 k=2,nmblks
    indexa = indexa + nrwblk*nrwpiv
    nclpiv = nrwblk - nrwpiv
    indpiv = indpiv + nrwpiv
!
!  call arcefs to perform forward solution
!
    if ( nclpiv>0) call arcefs(array(indexa), nrwblk, nclpiv, &
     novrlp, b(indpiv), x(indpiv))
    indexa = indexa + novrlp*nrwblk
    nrwblk = mtrstr(1,k)
!
!  call arcefm to perform forward modification
!
    if ( nclpiv>0) call arcefm(array(indexa), nrwblk, nclpiv, &
     b(indpiv), x(indpiv))
    indexa = indexa + nrwblk*nclpiv
    nclblk = mtrstr(2,k) - nclpiv
    novrlp = mtrstr(3,k)
    nrwpiv = nclblk - novrlp
    indpiv = indpiv + nclpiv
!
!  call arcefe to perform forward elimination
!
    if ( nrwpiv>0) call arcefe(array(indexa), nrwblk, nrwpiv, &
     pivot(indpiv), b(indpiv))
   10 continue
!     indexb = indpiv + nrwpiv - 1
!
!  backward loop
!
  do 30 ll=2,nmblks
    k = nmblks - ll + 1
!
!  call arcebm to perform backward modification
!
    if ( nrwpiv==0) go to 20
    if ( nrwpiv/=nclblk) call arcebm(array(indexa), nrwblk, &
     nclblk, nrwpiv, b(indpiv), x(indpiv))
!
!  call arcebs to perform backward solution
!
    call arcebs(array(indexa), nrwblk, nclblk, nrwpiv, b(indpiv), &
     x(indpiv))
   20   continue
    indexa = indexa - nrwblk*nclpiv
    nrwblk = mtrstr(1,k)
    novrlp = mtrstr(3,k)
    indexa = indexa - nrwblk*novrlp
    indpiv = indpiv - nclpiv
!
!  call arcebe to perform backward elimination
!
    if ( nclpiv>0) call arcebe(array(indexa), nrwblk, nclpiv, &
     novrlp, pivot(indpiv), x(indpiv))
    nrwpiv = nrwblk - nclpiv
    nclblk = novrlp + nrwpiv
    indexa = indexa - nrwblk*nrwpiv
    indpiv = indpiv - nrwpiv
    nclpiv = mtrstr(2,k) - nclblk
   30 continue
!
!  if row eliminations were done in topblock, call
!  arcebs to perform backward solution
!
  if ( nrwpiv==0) return
  if ( nrwpiv/=nclblk) call arcebm(array(indexa), nrwblk, nclblk, &
   nrwpiv, b(indpiv), x(indpiv))
  call arcebs(array(indexa), nrwblk, nclblk, nrwpiv, b(indpiv), &
   x(indpiv))
  return
end
function artnq(y,x)
!
!*******************************************************************************
!
!! ARTNQ ??? looks like a variation of the arc-tangent function.
!
  if ( x ) 1,2,5
1 artnq = atan ( y / x ) + 3.1415926535898
  return
2 if ( y) 3,8,4
3 artnq=4.7123889803847
  return
4 artnq=1.5707963267949
  return
5 if ( y) 6,8,7
6 artnq=atan(y/x)+6.2831853071795
  return
7 artnq=atan(y/x)
  return
8 artnq = 0.0

  return
end
subroutine asik(x,fnu,kode,flgik,ra,arg,in,tol,y)
!
!*******************************************************************************
!
!! ASIK computes Bessel functions I and K for positive argument and high order.
!
!
!  ASIK computes Bessel functions I and K for arguments X > 0.0 and 
!  orders fnu>=35 on flgik = 1 and flgik = -1 respectively.
!
!                                    input
!
!      x    - argument, x>0.0e0
!      fnu  - order of first Bessel function
!      kode - a parameter to indicate the scaling option
!             kode=1 returns y(i)=        i/sub(fnu+i-1)/(x), i=1,in
!                    or      y(i)=        k/sub(fnu+i-1)/(x), i=1,in
!                    on flgik = 1.0e0 or flgik = -1.0e0
!             kode=2 returns y(i)=exp(-x)*i/sub(fnu+i-1)/(x), i=1,in
!                    or      y(i)=exp( x)*k/sub(fnu+i-1)/(x), i=1,in
!                    on flgik = 1.0e0 or flgik = -1.0e0
!     flgik - selection parameter for i or k function
!             flgik =  1.0e0 gives the i function
!             flgik = -1.0e0 gives the k function
!        ra - sqrt(1.+z*z), z=x/fnu
!       arg - argument of the leading exponential
!        in - number of functions desired, in=1 or 2
!       tol - tolerance specified by besi or besk
!
!                                    output
!
!         y - a vector whose first in components contain the sequence
!
!                                 written by
!                                 d. e. amos
!
!     abstract
!         asik implements the uniform asymptotic expansion of
!         the i and k Bessel functions for fnu>=35 and real
!         x>0.0e0. the forms are identical except for a change
!         in sign of some of the terms. this change in sign is
!         accomplished by means of the flag flgik = 1 or -1.
!
  integer in, j, jn, k, kk, kode, l
  real ak,ap,arg,c, coef,con,etx,flgik,fn, fnu,gln,ra,s1,s2, &
   t, tol, t2, x, y, z
  dimension y(*), c(65), con(2)
  data con(1), con(2)  / &
          3.98942280401432678e-01,    1.25331413731550025e+00/
  data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), &
       c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), &
       c(19), c(20), c(21), c(22), c(23), c(24)/ &
         -2.08333333333333e-01,        1.25000000000000e-01, &
          3.34201388888889e-01,       -4.01041666666667e-01, &
          7.03125000000000e-02,       -1.02581259645062e+00, &
          1.84646267361111e+00,       -8.91210937500000e-01, &
          7.32421875000000e-02,        4.66958442342625e+00, &
         -1.12070026162230e+01,        8.78912353515625e+00, &
         -2.36408691406250e+00,        1.12152099609375e-01, &
         -2.82120725582002e+01,        8.46362176746007e+01, &
         -9.18182415432400e+01,        4.25349987453885e+01, &
         -7.36879435947963e+00,        2.27108001708984e-01, &
          2.12570130039217e+02,       -7.65252468141182e+02, &
          1.05999045252800e+03,       -6.99579627376133e+02/
  data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), &
       c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), &
       c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ &
          2.18190511744212e+02,       -2.64914304869516e+01, &
          5.72501420974731e-01,       -1.91945766231841e+03, &
          8.06172218173731e+03,       -1.35865500064341e+04, &
          1.16553933368645e+04,       -5.30564697861340e+03, &
          1.20090291321635e+03,       -1.08090919788395e+02, &
          1.72772750258446e+00,        2.02042913309661e+04, &
         -9.69805983886375e+04,        1.92547001232532e+05, &
         -2.03400177280416e+05,        1.22200464983017e+05, &
         -4.11926549688976e+04,        7.10951430248936e+03, &
         -4.93915304773088e+02,        6.07404200127348e+00, &
         -2.42919187900551e+05,        1.31176361466298e+06, &
         -2.99801591853811e+06,        3.76327129765640e+06/
  data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), &
       c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), &
       c(65)/ &
         -2.81356322658653e+06,        1.26836527332162e+06, &
         -3.31645172484564e+05,        4.52187689813627e+04, &
         -2.49983048181121e+03,        2.43805296995561e+01, &
          3.28446985307204e+06,       -1.97068191184322e+07, &
          5.09526024926646e+07,       -7.41051482115327e+07, &
          6.63445122747290e+07,       -3.75671766607634e+07, &
          1.32887671664218e+07,       -2.78561812808645e+06, &
          3.08186404612662e+05,       -1.38860897537170e+04, &
          1.10017140269247e+02/
!
  fn = fnu
  z  = (3.0e0-flgik)/2.0e0
  kk = int(z)
  do 50 jn=1,in
    if ( jn==1) go to 10
    fn = fn - flgik
    z = x/fn
    ra = sqrt(1.0e0+z*z)
    gln = alog((1.0e0+ra)/z)
    etx = real(kode-1)
    t = ra*(1.0e0-etx) + etx/(z+ra)
    arg = fn*(t-gln)*flgik
   10   coef = exp(arg)
    t = 1.0e0/ra
    t2 = t*t
    t = t/fn
    t = sign(t,flgik)
    s2 = 1.0e0
    ap = 1.0e0
    l = 0
    do 30 k=2,11
      l = l + 1
      s1 = c(l)
      do 20 j=2,k
        l = l + 1
        s1 = s1*t2 + c(l)
   20     continue
      ap = ap*t
      ak = ap*s1
      s2 = s2 + ak
      if ( max ( abs(ak),abs(ap)) < tol) go to 40
   30   continue
   40   continue
  t = abs(t)
  y(jn) = s2*coef*sqrt(t)*con(kk)
   50 continue
  return
end
subroutine asjy(funjy,x,fnu,flgjy,in,tol,elim,y,wk,iflw)
!
!*******************************************************************************
!
!! ASJY computes Bessel functions J and Y for positive argument and high order.
!
!
!  ASJY computes Bessel functions J and Y for arguments x>0.0 and orders 
!  fnu>=35.0
!               on flgjy = 1 and flgjy = -1 respectively
!
!                                  input
!
!      funjy - external function jairy or yairy
!          x - argument, x>0.0e0
!        fnu - order of the first Bessel function
!      flgjy - selection flag
!              flgjy =  1.0e0 gives the j function
!              flgjy = -1.0e0 gives the y function
!         in - number of functions desired, in = 1 or 2
!        tol - tolerance specified by besj or besy
!       elim - tolerance specified by besj or besy
!
!                                  output
!
!         y  - a vector whose first in components contain the sequence
!       iflw - a flag indicating underflow or overflow
!                    return variables for besj only
!      wk(1) = 1 - (x/fnu)**2 = w**2
!      wk(2) = sqrt(abs(wk(1)))
!      wk(3) = abs(wk(2) - atan(wk(2)))  or
!              abs(ln((1 + wk(2))/(x/fnu)) - wk(2))
!            = abs((2/3)*zeta**(3/2))
!      wk(4) = fnu*wk(3)
!      wk(5) = (1.5*wk(3)*fnu)**(1/3) = sqrt(zeta)*fnu**(1/3)
!      wk(6) = sign(1.,w**2)*wk(5)**2 = sign(1.,w**2)*zeta*fnu**(2/3)
!      wk(7) = fnu**(1/3)
!
!                                  written by
!                                  d. e. amos
!
!     abstract
!         asjk implements the uniform asymptotic expansion of
!         the j and y Bessel functions for fnu>=35 and real
!         x>0.0e0. the forms are identical except for a change
!         in sign of some of the terms. this change in sign is
!         accomplished by means of the flag flgjy = 1 or -1. on
!         flgjy = 1 the airy functions ai(x) and dai(x) are
!         supplied by the external function jairy, and on
!         flgjy = -1 the airy functions bi(x) and dbi(x) are
!         supplied by the external funtion yairy.
!
  integer i, iflw, in, j, jn,jr,ju,k, kb,klast,kmax,kp1, ks, ksp1, &
   kstemp, l, lr, lrp1
  real abw2, akm, alfa, alfa1, alfa2, ap, ar, asum, az, &
   beta, beta1, beta2, beta3, br, bsum, c, con1, con2, &
   con3,con548,cr,crz32, dfi,elim, dr,fi, flgjy, fn, fnu, &
   fn2, gama, phi,  rcz, rden, relb, rfn2,  rtz, rzden, &
   sa, sb, suma, sumb, s1, ta, tau, tb, tfn, tol, tols, t2, upol, &
    wk, x, xx, y, z, z32
  external funjy
  dimension y(*), wk(*), c(65)
  dimension alfa(26,4), beta(26,5)
  dimension alfa1(26,2), alfa2(26,2)
  dimension beta1(26,2), beta2(26,2), beta3(26,1)
  dimension gama(26), kmax(5), ar(8), br(10), upol(10)
  dimension cr(10), dr(10)
  equivalence (alfa(1,1),alfa1(1,1))
  equivalence (alfa(1,3),alfa2(1,1))
  equivalence (beta(1,1),beta1(1,1))
  equivalence (beta(1,3),beta2(1,1))
  equivalence (beta(1,5),beta3(1,1))
  data tols            /-6.90775527898214e+00/
  data con1,con2,con3,con548/ &
   6.66666666666667e-01, 3.33333333333333e-01, 1.41421356237310e+00, &
   1.04166666666667e-01/
  data  ar(1),  ar(2),  ar(3),  ar(4),  ar(5),  ar(6),  ar(7), &
        ar(8)          / 8.35503472222222e-02, 1.28226574556327e-01, &
   2.91849026464140e-01, 8.81627267443758e-01, 3.32140828186277e+00, &
   1.49957629868626e+01, 7.89230130115865e+01, 4.74451538868264e+02/
  data  br(1), br(2), br(3), br(4), br(5), br(6), br(7), br(8), &
        br(9), br(10)  /-1.45833333333333e-01,-9.87413194444444e-02, &
  -1.43312053915895e-01,-3.17227202678414e-01,-9.42429147957120e-01, &
  -3.51120304082635e+00,-1.57272636203680e+01,-8.22814390971859e+01, &
  -4.92355370523671e+02,-3.31621856854797e+03/
  data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), &
       c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), &
       c(19), c(20), c(21), c(22), c(23), c(24)/ &
         -2.08333333333333e-01,        1.25000000000000e-01, &
          3.34201388888889e-01,       -4.01041666666667e-01, &
          7.03125000000000e-02,       -1.02581259645062e+00, &
          1.84646267361111e+00,       -8.91210937500000e-01, &
          7.32421875000000e-02,        4.66958442342625e+00, &
         -1.12070026162230e+01,        8.78912353515625e+00, &
         -2.36408691406250e+00,        1.12152099609375e-01, &
         -2.82120725582002e+01,        8.46362176746007e+01, &
         -9.18182415432400e+01,        4.25349987453885e+01, &
         -7.36879435947963e+00,        2.27108001708984e-01, &
          2.12570130039217e+02,       -7.65252468141182e+02, &
          1.05999045252800e+03,       -6.99579627376133e+02/
  data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), &
       c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), &
       c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ &
          2.18190511744212e+02,       -2.64914304869516e+01, &
          5.72501420974731e-01,       -1.91945766231841e+03, &
          8.06172218173731e+03,       -1.35865500064341e+04, &
          1.16553933368645e+04,       -5.30564697861340e+03, &
          1.20090291321635e+03,       -1.08090919788395e+02, &
          1.72772750258446e+00,        2.02042913309661e+04, &
         -9.69805983886375e+04,        1.92547001232532e+05, &
         -2.03400177280416e+05,        1.22200464983017e+05, &
         -4.11926549688976e+04,        7.10951430248936e+03, &
         -4.93915304773088e+02,        6.07404200127348e+00, &
         -2.42919187900551e+05,        1.31176361466298e+06, &
         -2.99801591853811e+06,        3.76327129765640e+06/
  data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), &
       c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), &
       c(65)/ &
         -2.81356322658653e+06,        1.26836527332162e+06, &
         -3.31645172484564e+05,        4.52187689813627e+04, &
         -2.49983048181121e+03,        2.43805296995561e+01, &
          3.28446985307204e+06,       -1.97068191184322e+07, &
          5.09526024926646e+07,       -7.41051482115327e+07, &
          6.63445122747290e+07,       -3.75671766607634e+07, &
          1.32887671664218e+07,       -2.78561812808645e+06, &
          3.08186404612662e+05,       -1.38860897537170e+04, &
          1.10017140269247e+02/
  data alfa1(1,1), alfa1(2,1), alfa1(3,1), alfa1(4,1), alfa1(5,1), &
       alfa1(6,1), alfa1(7,1), alfa1(8,1), alfa1(9,1), alfa1(10,1), &
       alfa1(11,1),alfa1(12,1),alfa1(13,1),alfa1(14,1),alfa1(15,1), &
       alfa1(16,1),alfa1(17,1),alfa1(18,1),alfa1(19,1),alfa1(20,1), &
       alfa1(21,1),alfa1(22,1),alfa1(23,1),alfa1(24,1),alfa1(25,1), &
       alfa1(26,1)     /-4.44444444444444e-03,-9.22077922077922e-04, &
  -8.84892884892885e-05, 1.65927687832450e-04, 2.46691372741793e-04, &
   2.65995589346255e-04, 2.61824297061501e-04, 2.48730437344656e-04, &
   2.32721040083232e-04, 2.16362485712365e-04, 2.00738858762752e-04, &
   1.86267636637545e-04, 1.73060775917876e-04, 1.61091705929016e-04, &
   1.50274774160908e-04, 1.40503497391270e-04, 1.31668816545923e-04, &
   1.23667445598253e-04, 1.16405271474738e-04, 1.09798298372713e-04, &
   1.03772410422993e-04, 9.82626078369363e-05, 9.32120517249503e-05, &
   8.85710852478712e-05, 8.42963105715700e-05, 8.03497548407791e-05/
  data alfa1(1,2), alfa1(2,2), alfa1(3,2), alfa1(4,2), alfa1(5,2), &
       alfa1(6,2), alfa1(7,2), alfa1(8,2), alfa1(9,2), alfa1(10,2), &
       alfa1(11,2),alfa1(12,2),alfa1(13,2),alfa1(14,2),alfa1(15,2), &
       alfa1(16,2),alfa1(17,2),alfa1(18,2),alfa1(19,2),alfa1(20,2), &
       alfa1(21,2),alfa1(22,2),alfa1(23,2),alfa1(24,2),alfa1(25,2), &
       alfa1(26,2)     / 6.93735541354589e-04, 2.32241745182922e-04, &
  -1.41986273556691e-05,-1.16444931672049e-04,-1.50803558053049e-04, &
  -1.55121924918096e-04,-1.46809756646466e-04,-1.33815503867491e-04, &
  -1.19744975684254e-04,-1.06184319207974e-04,-9.37699549891194e-05, &
  -8.26923045588193e-05,-7.29374348155221e-05,-6.44042357721016e-05, &
  -5.69611566009369e-05,-5.04731044303562e-05,-4.48134868008883e-05, &
  -3.98688727717599e-05,-3.55400532972042e-05,-3.17414256609022e-05, &
  -2.83996793904175e-05,-2.54522720634871e-05,-2.28459297164725e-05, &
  -2.05352753106481e-05,-1.84816217627666e-05,-1.66519330021394e-05/
  data alfa2(1,1), alfa2(2,1), alfa2(3,1), alfa2(4,1), alfa2(5,1), &
       alfa2(6,1), alfa2(7,1), alfa2(8,1), alfa2(9,1), alfa2(10,1), &
       alfa2(11,1),alfa2(12,1),alfa2(13,1),alfa2(14,1),alfa2(15,1), &
       alfa2(16,1),alfa2(17,1),alfa2(18,1),alfa2(19,1),alfa2(20,1), &
       alfa2(21,1),alfa2(22,1),alfa2(23,1),alfa2(24,1),alfa2(25,1), &
       alfa2(26,1)     /-3.54211971457744e-04,-1.56161263945159e-04, &
   3.04465503594936e-05, 1.30198655773243e-04, 1.67471106699712e-04, &
   1.70222587683593e-04, 1.56501427608595e-04, 1.36339170977445e-04, &
   1.14886692029825e-04, 9.45869093034688e-05, 7.64498419250898e-05, &
   6.07570334965197e-05, 4.74394299290509e-05, 3.62757512005344e-05, &
   2.69939714979225e-05, 1.93210938247939e-05, 1.30056674793963e-05, &
   7.82620866744497e-06, 3.59257485819352e-06, 1.44040049814252e-07, &
  -2.65396769697939e-06,-4.91346867098486e-06,-6.72739296091248e-06, &
  -8.17269379678658e-06,-9.31304715093561e-06,-1.02011418798016e-05/
  data alfa2(1,2), alfa2(2,2), alfa2(3,2), alfa2(4,2), alfa2(5,2), &
       alfa2(6,2), alfa2(7,2), alfa2(8,2), alfa2(9,2), alfa2(10,2), &
       alfa2(11,2),alfa2(12,2),alfa2(13,2),alfa2(14,2),alfa2(15,2), &
       alfa2(16,2),alfa2(17,2),alfa2(18,2),alfa2(19,2),alfa2(20,2), &
       alfa2(21,2),alfa2(22,2),alfa2(23,2),alfa2(24,2),alfa2(25,2), &
       alfa2(26,2)     / 3.78194199201773e-04, 2.02471952761816e-04, &
  -6.37938506318862e-05,-2.38598230603006e-04,-3.10916256027362e-04, &
  -3.13680115247576e-04,-2.78950273791323e-04,-2.28564082619141e-04, &
  -1.75245280340847e-04,-1.25544063060690e-04,-8.22982872820208e-05, &
  -4.62860730588116e-05,-1.72334302366962e-05, 5.60690482304602e-06, &
   2.31395443148287e-05, 3.62642745856794e-05, 4.58006124490189e-05, &
   5.24595294959114e-05, 5.68396208545815e-05, 5.94349820393104e-05, &
   6.06478527578422e-05, 6.08023907788436e-05, 6.01577894539460e-05, &
   5.89199657344698e-05, 5.72515823777593e-05, 5.52804375585853e-05/
  data beta1(1,1), beta1(2,1), beta1(3,1), beta1(4,1), beta1(5,1), &
       beta1(6,1), beta1(7,1), beta1(8,1), beta1(9,1), beta1(10,1), &
       beta1(11,1),beta1(12,1),beta1(13,1),beta1(14,1),beta1(15,1), &
       beta1(16,1),beta1(17,1),beta1(18,1),beta1(19,1),beta1(20,1), &
       beta1(21,1),beta1(22,1),beta1(23,1),beta1(24,1),beta1(25,1), &
       beta1(26,1)     / 1.79988721413553e-02, 5.59964911064388e-03, &
   2.88501402231133e-03, 1.80096606761054e-03, 1.24753110589199e-03, &
   9.22878876572938e-04, 7.14430421727287e-04, 5.71787281789705e-04, &
   4.69431007606482e-04, 3.93232835462917e-04, 3.34818889318298e-04, &
   2.88952148495752e-04, 2.52211615549573e-04, 2.22280580798883e-04, &
   1.97541838033063e-04, 1.76836855019718e-04, 1.59316899661821e-04, &
   1.44347930197334e-04, 1.31448068119965e-04, 1.20245444949303e-04, &
   1.10449144504599e-04, 1.01828770740567e-04, 9.41998224204238e-05, &
   8.74130545753834e-05, 8.13466262162801e-05, 7.59002269646219e-05/
  data beta1(1,2), beta1(2,2), beta1(3,2), beta1(4,2), beta1(5,2), &
       beta1(6,2), beta1(7,2), beta1(8,2), beta1(9,2), beta1(10,2), &
       beta1(11,2),beta1(12,2),beta1(13,2),beta1(14,2),beta1(15,2), &
       beta1(16,2),beta1(17,2),beta1(18,2),beta1(19,2),beta1(20,2), &
       beta1(21,2),beta1(22,2),beta1(23,2),beta1(24,2),beta1(25,2), &
       beta1(26,2)     /-1.49282953213429e-03,-8.78204709546389e-04, &
  -5.02916549572035e-04,-2.94822138512746e-04,-1.75463996970783e-04, &
  -1.04008550460816e-04,-5.96141953046458e-05,-3.12038929076098e-05, &
  -1.26089735980230e-05,-2.42892608575730e-07, 8.05996165414274e-06, &
   1.36507009262147e-05, 1.73964125472926e-05, 1.98672978842134e-05, &
   2.14463263790823e-05, 2.23954659232457e-05, 2.28967783814713e-05, &
   2.30785389811178e-05, 2.30321976080909e-05, 2.28236073720349e-05, &
   2.25005881105292e-05, 2.20981015361991e-05, 2.16418427448104e-05, &
   2.11507649256221e-05, 2.06388749782171e-05, 2.01165241997082e-05/
  data beta2(1,1), beta2(2,1), beta2(3,1), beta2(4,1), beta2(5,1), &
       beta2(6,1), beta2(7,1), beta2(8,1), beta2(9,1), beta2(10,1), &
       beta2(11,1),beta2(12,1),beta2(13,1),beta2(14,1),beta2(15,1), &
       beta2(16,1),beta2(17,1),beta2(18,1),beta2(19,1),beta2(20,1), &
       beta2(21,1),beta2(22,1),beta2(23,1),beta2(24,1),beta2(25,1), &
       beta2(26,1)     / 5.52213076721293e-04, 4.47932581552385e-04, &
   2.79520653992021e-04, 1.52468156198447e-04, 6.93271105657044e-05, &
   1.76258683069991e-05,-1.35744996343269e-05,-3.17972413350427e-05, &
  -4.18861861696693e-05,-4.69004889379141e-05,-4.87665447413787e-05, &
  -4.87010031186735e-05,-4.74755620890087e-05,-4.55813058138628e-05, &
  -4.33309644511266e-05,-4.09230193157750e-05,-3.84822638603221e-05, &
  -3.60857167535411e-05,-3.37793306123367e-05,-3.15888560772110e-05, &
  -2.95269561750807e-05,-2.75978914828336e-05,-2.58006174666884e-05, &
  -2.41308356761280e-05,-2.25823509518346e-05,-2.11479656768913e-05/
  data beta2(1,2), beta2(2,2), beta2(3,2), beta2(4,2), beta2(5,2), &
       beta2(6,2), beta2(7,2), beta2(8,2), beta2(9,2), beta2(10,2), &
       beta2(11,2),beta2(12,2),beta2(13,2),beta2(14,2),beta2(15,2), &
       beta2(16,2),beta2(17,2),beta2(18,2),beta2(19,2),beta2(20,2), &
       beta2(21,2),beta2(22,2),beta2(23,2),beta2(24,2),beta2(25,2), &
       beta2(26,2)     /-4.74617796559960e-04,-4.77864567147321e-04, &
  -3.20390228067038e-04,-1.61105016119962e-04,-4.25778101285435e-05, &
   3.44571294294968e-05, 7.97092684075675e-05, 1.03138236708272e-04, &
   1.12466775262204e-04, 1.13103642108481e-04, 1.08651634848774e-04, &
   1.01437951597662e-04, 9.29298396593364e-05, 8.40293133016090e-05, &
   7.52727991349134e-05, 6.69632521975731e-05, 5.92564547323195e-05, &
   5.22169308826976e-05, 4.58539485165361e-05, 4.01445513891487e-05, &
   3.50481730031328e-05, 3.05157995034347e-05, 2.64956119950516e-05, &
   2.29363633690998e-05, 1.97893056664022e-05, 1.70091984636413e-05/
  data beta3(1,1), beta3(2,1), beta3(3,1), beta3(4,1), beta3(5,1), &
       beta3(6,1), beta3(7,1), beta3(8,1), beta3(9,1), beta3(10,1), &
       beta3(11,1),beta3(12,1),beta3(13,1),beta3(14,1),beta3(15,1), &
       beta3(16,1),beta3(17,1),beta3(18,1),beta3(19,1),beta3(20,1), &
       beta3(21,1),beta3(22,1),beta3(23,1),beta3(24,1),beta3(25,1), &
       beta3(26,1)     / 7.36465810572578e-04, 8.72790805146194e-04, &
   6.22614862573135e-04, 2.85998154194304e-04, 3.84737672879366e-06, &
  -1.87906003636972e-04,-2.97603646594555e-04,-3.45998126832656e-04, &
  -3.53382470916038e-04,-3.35715635775049e-04,-3.04321124789040e-04, &
  -2.66722723047613e-04,-2.27654214122820e-04,-1.89922611854562e-04, &
  -1.55058918599094e-04,-1.23778240761874e-04,-9.62926147717644e-05, &
  -7.25178327714425e-05,-5.22070028895634e-05,-3.50347750511901e-05, &
  -2.06489761035552e-05,-8.70106096849767e-06, 1.13698686675100e-06, &
   9.16426474122779e-06, 1.56477785428873e-05, 2.08223629482467e-05/
  data gama(1),   gama(2),   gama(3),   gama(4),   gama(5), &
       gama(6),   gama(7),   gama(8),   gama(9),   gama(10), &
       gama(11),  gama(12),  gama(13),  gama(14),  gama(15), &
       gama(16),  gama(17),  gama(18),  gama(19),  gama(20), &
       gama(21),  gama(22),  gama(23),  gama(24),  gama(25), &
       gama(26)        / 6.29960524947437e-01, 2.51984209978975e-01, &
   1.54790300415656e-01, 1.10713062416159e-01, 8.57309395527395e-02, &
   6.97161316958684e-02, 5.86085671893714e-02, 5.04698873536311e-02, &
   4.42600580689155e-02, 3.93720661543510e-02, 3.54283195924455e-02, &
   3.21818857502098e-02, 2.94646240791158e-02, 2.71581677112934e-02, &
   2.51768272973862e-02, 2.34570755306079e-02, 2.19508390134907e-02, &
   2.06210828235646e-02, 1.94388240897881e-02, 1.83810633800683e-02, &
   1.74293213231963e-02, 1.65685837786612e-02, 1.57865285987918e-02, &
   1.50729501494096e-02, 1.44193250839955e-02, 1.38184805735342e-02/
!
  fn = fnu
  iflw = 0
  do 170 jn=1,in
    xx = x/fn
    wk(1) = 1.0e0 - xx*xx
    abw2 = abs(wk(1))
    wk(2) = sqrt(abw2)
    wk(7) = fn**con2
    if ( abw2>0.27750e0) go to 80
!
!     asymptotic expansion
!     cases near x=fn, abs(1.-(x/fn)**2)<=0.2775
!     coefficients of asymptotic expansion by series
!
!     zeta and truncation for a(zeta) and b(zeta) series
!
!     kmax is truncation index for a(zeta) and b(zeta) series=max(2,sa)
!
    sa = 0.0e0
    if ( abw2==0.0e0) go to 10
    sa = tols/alog(abw2)
   10   sb = sa
    do 20 i=1,5
      akm = max ( sa,2.0e0)
      kmax(i) = int(akm)
      sa = sa + sb
   20   continue
    kb = kmax(5)
    klast = kb - 1
    sa = gama(kb)
    do 30 k=1,klast
      kb = kb - 1
      sa = sa*wk(1) + gama(kb)
   30   continue
    z = wk(1)*sa
    az = abs(z)
    rtz = sqrt(az)
    wk(3) = con1*az*rtz
    wk(4) = wk(3)*fn
    wk(5) = rtz*wk(7)
    wk(6) = -wk(5)*wk(5)
    if(z<=0.0e0) go to 35
    if(wk(4)>elim) go to 75
    wk(6) = -wk(6)
   35   continue
    phi = sqrt(sqrt(sa+sa+sa+sa))
!
!     b(zeta) for s=0
!
    kb = kmax(5)
    klast = kb - 1
    sb = beta(kb,1)
    do 40 k=1,klast
      kb = kb - 1
      sb = sb*wk(1) + beta(kb,1)
   40   continue
    ksp1 = 1
    fn2 = fn*fn
    rfn2 = 1.0e0/fn2
    rden = 1.0e0
    asum = 1.0e0
    relb = tol*abs(sb)
    bsum = sb
    do 60 ks=1,4
      ksp1 = ksp1 + 1
      rden = rden*rfn2
!
!     a(zeta) and b(zeta) for s=1,2,3,4
!
      kstemp = 5 - ks
      kb = kmax(kstemp)
      klast = kb - 1
      sa = alfa(kb,ks)
      sb = beta(kb,ksp1)
      do 50 k=1,klast
        kb = kb - 1
        sa = sa*wk(1) + alfa(kb,ks)
        sb = sb*wk(1) + beta(kb,ksp1)
   50     continue
      ta = sa*rden
      tb = sb*rden
      asum = asum + ta
      bsum = bsum + tb
      if ( abs(ta)<=tol .and. abs(tb)<=relb) go to 70
   60   continue
   70   continue
    bsum = bsum/(fn*wk(7))
    go to 160

   75   continue
    iflw = 1
    return

   80   continue
    upol(1) = 1.0e0
    tau = 1.0e0/wk(2)
    t2 = 1.0e0/wk(1)
    if ( wk(1)>=0.0e0) go to 90
!
!     cases for (x/fn)>sqrt(1.2775)
!
    wk(3) = abs(wk(2)-atan(wk(2)))
    wk(4) = wk(3)*fn
    rcz = -con1/wk(4)
    z32 = 1.5e0*wk(3)
    rtz = z32**con2
    wk(5) = rtz*wk(7)
    wk(6) = -wk(5)*wk(5)
    go to 100
   90   continue
!
!     cases for (x/fn)<sqrt(0.7225)
!
    wk(3) = abs(alog((1.0e0+wk(2))/xx)-wk(2))
    wk(4) = wk(3)*fn
    rcz = con1/wk(4)
    if(wk(4)>elim) go to 75
    z32 = 1.5e0*wk(3)
    rtz = z32**con2
    wk(7) = fn**con2
    wk(5) = rtz*wk(7)
    wk(6) = wk(5)*wk(5)
  100   continue
    phi = sqrt((rtz+rtz)*tau)
    tb = 1.0e0
    asum = 1.0e0
    tfn = tau/fn
    upol(2) = (c(1)*t2+c(2))*tfn
    crz32 = con548*rcz
    bsum = upol(2) + crz32
    relb = tol*abs(bsum)
    ap = tfn
    ks = 0
    kp1 = 2
    rzden = rcz
    l = 2
    do 140 lr=2,8,2
!
!     compute two u polynomials for next a(zeta) and b(zeta)
!
      lrp1 = lr + 1
      do 120 k=lr,lrp1
        ks = ks + 1
        kp1 = kp1 + 1
        l = l + 1
        s1 = c(l)
        do 110 j=2,kp1
          l = l + 1
          s1 = s1*t2 + c(l)
  110       continue
        ap = ap*tfn
        upol(kp1) = ap*s1
        cr(ks) = br(ks)*rzden
        rzden = rzden*rcz
        dr(ks) = ar(ks)*rzden
  120     continue
      suma = upol(lrp1)
      sumb = upol(lr+2) + upol(lrp1)*crz32
      ju = lrp1
      do 130 jr=1,lr
        ju = ju - 1
        suma = suma + cr(jr)*upol(ju)
        sumb = sumb + dr(jr)*upol(ju)
  130     continue
      tb = -tb
      if ( wk(1)>0.0e0) tb = abs(tb)
      asum = asum + suma*tb
      bsum = bsum + sumb*tb
      if ( abs(suma)<=tol .and. abs(sumb)<=relb) go to 150
  140   continue
  150   tb = wk(5)
    if ( wk(1)>0.0e0) tb = -tb
    bsum = bsum/tb
!
  160   continue
    call funjy(wk(6), wk(5), wk(4), fi, dfi)
    y(jn) = flgjy*phi*(fi*asum+dfi*bsum)/wk(7)
    fn = fn - flgjy
  170 continue
  return
end
subroutine assgn (n,a,c,t,iwk,ierr)
!
!*******************************************************************************
!
!! ASSGN solves the assignment problem.
!
  integer a(n,*), c(n), t, iwk(*)
!
  i1 = n + 1
  i2 = i1 + n
  i3 = i2 + n
  i4 = i3 + n + 1
  i5 = i4 + n
  i6 = i5 + n
  call assgn1(n,a,c,t,iwk(1),iwk(i1),iwk(i2),iwk(i3),iwk(1), &
              iwk(i3),iwk(i4),iwk(i5),iwk(i6),ierr)
  return
end
subroutine assgn1(n,a,c,t,ch,lc,lr,lz,nz,rh,slc,slr,u,ierr)
!
!*******************************************************************************
!
!! ASSGN1 solves the square assignment problem.
!
!
! the meaning of the input parameters is
! n = number of rows and columns of the cost matrix
! a(i,j) = element in row i and column j of the cost matrix
! ( at the end of computation the elements of a are changed)
! the meaning of the output parameters is
! c(j) = row assigned to column j (j=1,n)
! t = cost of the optimal assignment
! all parameters are integer
! the meaning of the local variables is
! a(i,j) = element of the cost matrix if a(i,j) is positive,
!          column of the unassigned zero following in row i
!          (i=1,n) the unassigned zero of column j (j=1,n)
!          if a(i,j) is not positive
! a(i,n+1) = column of the first unassigned zero of row i
!            (i=1,n)
! ch(i) = column of the next unexplored and unassigned zero
!         of row i (i=1,n)
! lc(j) = label of column j (j=1,n)
! lr(i) = label of row i (i=1,n)
! lz(i) = column of the last unassigned zero of row i(i=1,n)
! nz(i) = column of the next unassigned zero of row i(i=1,n)
! rh(i) = unexplored row following the unexplored row i
!         (i=1,n)
! rh(n+1) = first unexplored row
! slc(k) = k-th element contained in the set of the labelled
!          columns
! slr(k) = k-th element contained in the set of the labelled
!          rows
! u(i) = unassigned row following the unassigned row i
!        (i=1,n)
! u(n+1) = first unassigned row
! ierr = 0 if the routine terminates successfully. otherwise
!          ierr = 1
!
! the vectors c,ch,lc,lr,lz,nz,slc,slr must be dimensioned
! at least at (n), the vectors rh,u at  least at (n+1),
! and the matrix a at least at (n,n+1). to save storage
! lz and rh may use the same storage area, and nz and ch
! may use the same storage area.
!
  integer a(n,*), c(n), ch(n), lc(n), lr(n), lz(n)
  integer maxnum
  integer nz(n), rh(*), slc(n), slr(n), u(*)
  integer h, q, r, s, t
!
! initialization
!
  maxnum = huge ( maxnum )
  ierr = 0
  np1 = n+1
  do j=1,n
    c(j) = 0
    lz(j) = 0
    nz(j) = 0
    u(j) = 0
  end do
  u(np1) = 0
  t = 0
! reduction of the initial cost matrix
  do 40 j=1,n
    s = a(1,j)
    do 15 l=2,n
      if ( a(l,j) < s ) s = a(l,j)
   15   continue
    if ( s) 20,40,30
   20   mm = maxnum + s
    if ( t < -mm) go to 400
    t = t + s
    do 25 i = 1,n
      if ( a(i,j) > mm) go to 400
      a(i,j) = a(i,j) - s
   25   continue
    go to 40
   30   mm = maxnum - s
    if ( t > mm) go to 400
    t = t + s
    do 35 i = 1,n
      a(i,j) = a(i,j) - s
   35   continue
   40 continue
  do 70 i=1,n
    q = a(i,1)
    do 50 l=2,n
      if ( a(i,l) < q ) q = a(i,l)
   50   continue
    mm = maxnum - q
    if ( t > mm) go to 400
    t = t + q
    l = np1
    do 60 j=1,n
      a(i,j) = a(i,j)-q
      if ( a(i,j) /= 0 ) go to 60
      a(i,l) = -j
      l = j
   60   continue
   70 continue
! choice of the initial solution
  k = np1
  do 140 i=1,n
    lj = np1
    j = -a(i,np1)
   80   if ( c(j) == 0 ) go to 130
    lj = j
    j = -a(i,j)
    if ( j /= 0 ) go to 80
    lj = np1
    j = -a(i,np1)
   90   r = c(j)
    lm = lz(r)
    m = nz(r)
  100   if ( m == 0 ) go to 110
    if ( c(m) == 0 ) go to 120
    lm = m
    m = -a(r,m)
    go to 100
  110   lj = j
    j = -a(i,j)
    if ( j /= 0 ) go to 90
    u(k) = i
    k = i
    go to 140
  120   nz(r) = -a(r,m)
    lz(r) = j
    a(r,lm) = -j
    a(r,j) = a(r,m)
    a(r,m) = 0
    c(m) = r
  130   c(j) = i
    a(i,lj) = a(i,j)
    nz(i) = -a(i,j)
    lz(i) = lj
    a(i,j) = 0
  140 continue
! research of a new assignment
  150 if ( u(np1) == 0 ) return
  do 160 i=1,n
    ch(i) = 0
    lc(i) = 0
    lr(i) = 0
    rh(i) = 0
  160 continue
  rh(np1) = -1
  kslc = 0
  kslr = 1
  r = u(np1)
  lr(r) = -1
  slr(1) = r
  if ( a(r,np1) == 0 ) go to 220
  170 l = -a(r,np1)
  if ( a(r,l) == 0 ) go to 180
  if ( rh(r) /= 0 ) go to 180
  rh(r) = rh(np1)
  ch(r) = -a(r,l)
  rh(np1) = r
  180 if ( lc(l) == 0 ) go to 200
  if ( rh(r) == 0 ) go to 210
  190 l = ch(r)
  ch(r) = -a(r,l)
  if ( a(r,l) /= 0 ) go to 180
  rh(np1) = rh(r)
  rh(r) = 0
  go to 180
  200 lc(l) = r
  if ( c(l) == 0 ) go to 360
  kslc = kslc+1
  slc(kslc) = l
  r = c(l)
  lr(r) = l
  kslr = kslr+1
  slr(kslr) = r
  if ( a(r,np1) /= 0 ) go to 170
  210 continue
  if ( rh(np1) > 0 ) go to 350
! reduction of the current cost matrix
  220 h = maxnum
  do 240 j=1,n
    if ( lc(j) /= 0 ) go to 240
    do 230 k=1,kslr
      i = slr(k)
      if ( a(i,j) < h ) h = a(i,j)
  230   continue
  240 continue
  mm = maxnum - h
  if ( mm == 0 .or. t > mm) go to 400
  t = t + h
  do 290 j=1,n
    if ( lc(j) /= 0 ) go to 290
    do 280 k=1,kslr
      i = slr(k)
      a(i,j) = a(i,j)-h
      if ( a(i,j) /= 0 ) go to 280
      if ( rh(i) /= 0 ) go to 250
      rh(i) = rh(np1)
      ch(i) = j
      rh(np1) = i
  250     l = np1
  260     nl = -a(i,l)
      if ( nl == 0 ) go to 270
      l = nl
      go to 260
  270     a(i,l) = -j
  280   continue
  290 continue
  if ( kslc == 0 ) go to 350
  do 340 i=1,n
    if ( lr(i) /= 0 ) go to 340
    do 330 k=1,kslc
      j = slc(k)
      if ( a(i,j) > 0 ) go to 320
      l = np1
  300     nl = - a(i,l)
      if ( nl == j ) go to 310
      l = nl
      go to 300
  310     a(i,l) = a(i,j)
      a(i,j) = h
      go to 330
  320     mm = maxnum - h
      if ( a(i,j) > mm) go to 400
      a(i,j) = a(i,j) + h
  330   continue
  340 continue
  350 r = rh(np1)
  go to 190
! assignment of a new row
  360 c(l) = r
  m = np1
  370 nm = -a(r,m)
  if ( nm == l ) go to 380
  m = nm
  go to 370
  380 a(r,m) = a(r,l)
  a(r,l) = 0
  if ( lr(r) < 0 ) go to 390
  l = lr(r)
  a(r,l) = a(r,np1)
  a(r,np1) = -l
  r = lc(l)
  go to 360
  390 u(np1) = u(r)
  u(r) = 0
  go to 150
! error return - integer overflow occurs
  400 ierr = 1
  return
end
function atn(z)
!
!*******************************************************************************
!
!! ATN calculates complex function atn(z) = z*atan(z) using double precision.
!
  complex atn
  double precision dx
  double precision dy
  complex z
!
  x = real(z)
  y = aimag(z)
  dx = x
  dy = y
  t = 1.d0 - dx*dx - dy*dy
  da = -0.5*atan2(-2.0*x, t)
  d = (1.0 - dy)**2 + dx*dx
  db = 0.25*alnrel(4.0*y/d)
  atn1 = da*x - db*y
  atn2 = da*y + db*x
  atn = cmplx(atn1, atn2)
  return
end
subroutine badd(m,n,a,ka,ml,mu,b,kb,nl,nu,c,kc,l,mcl,mcu,ierr)
!
!*******************************************************************************
!
!! BADD adds real banded matrices
!
  real a(ka,*), b(kb,*), c(kc,l)
!
!     addition of the diagonals below the main diagonals
!     and addition of the main diagonals
!
  ierr = 0
  if (nl - ml) 10,30,20
!
   10 if (ml >= l) go to 200
  mcl = ml
  ja = ml - nl
  jb = 0
  jc = ja
  jmax = nl + 1
  do 12 j = 1,jc
    do 11 i = 1,m
   11   c(i,j) = a(i,j)
   12 continue
  go to 60
!
   20 if (nl >= l) go to 210
  mcl = nl
  ja = 0
  jb = nl - ml
  jc = jb
  jmax = ml + 1
  do 22 j = 1,jc
    do 21 i = 1,m
   21   c(i,j) = b(i,j)
   22 continue
  go to 60
!
   30 mcl = ml
  if (ml == 0) go to 40
  imin = ml + 1
  do 32 j = 1,ml
    do 31 i = imin,m
    if (a(i,j) + b(i,j) /= 0.0) go to 50
   31   continue
  mcl = mcl - 1
   32 imin = imin - 1
!
   40 ja = ml
  jb = ml
  jc = 0
  jmax = 1
  go to 60
!
   50 ja = j - 1
  jb = ja
  jc = 0
  jmax = ml + 1 - ja
  if (jmax > l) go to 220
!
   60 do 62 j = 1,jmax
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 61 i = 1,m
   61   c(i,jc) = a(i,ja) + b(i,jb)
   62 continue
!
!     addition of the diagonals above the main diagonals
!
  if (nu - mu) 100,140,120
!
  100 if (jc + mu > l) go to 230
  mcu = mu
  if (nu == 0) go to 110
  do 102 j = 1,nu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 101 i = 1,m
  101   c(i,jc) = a(i,ja) + b(i,jb)
  102 continue
!
  110 jmax = mu - nu
  do 112 j = 1,jmax
  ja = ja + 1
  jc = jc + 1
    do 111 i = 1,m
  111   c(i,jc) = a(i,ja)
  112 continue
  return
!
  120 if (jc + nu > l) go to 240
  mcu = nu
  if (mu == 0) go to 130
  do 122 j = 1,mu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 121 i = 1,m
  121   c(i,jc) = a(i,ja) + b(i,jb)
  122 continue
!
  130 jmax = nu - mu
  do 132 j = 1,jmax
  jb = jb + 1
  jc = jc + 1
    do 131 i = 1,m
  131   c(i,jc) = b(i,jb)
  132 continue
  return
!
  140 mcu = mu
  if (mu == 0) return
  la = ml + mu + 1
  lb = nl + nu + 1
  do 142 j = 1,mu
  imax = min (m,n-mcu)
    do 141 i = 1,imax
    if (a(i,la) + b(i,lb) /= 0.0) go to 150
  141   continue
  mcu = mcu - 1
  la = la - 1
  142 lb = lb - 1
  return
!
  150 if (jc + mcu > l) go to 250
  do 152 j = 1,mcu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 151 i = 1,m
  151   c(i,jc) = a(i,ja) + b(i,jb)
  152 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = ml + 1
  return
  210 ierr = nl + 1
  return
  220 ierr = jmax
  return
  230 ierr = jc + mu
  return
  240 ierr = jc + nu
  return
  250 ierr = jc + mcu
  return
end
subroutine balanc ( nm, n, a, low, igh, scale )
!
!*******************************************************************************
!
!! BALANC balances a real matrix before eigenvalue calculations.
!
!
!  Discussion:
!
!    This subroutine balances a real matrix and isolates eigenvalues
!    whenever possible.
!
!    Suppose that the principal submatrix in rows LOW through IGH
!    has been balanced, that P(J) denotes the index interchanged
!    with J during the permutation step, and that the elements
!    of the diagonal matrix used are denoted by D(I,J).  Then
!
!      SCALE(J) = P(J),    J = 1,...,LOW-1,
!               = D(J,J),  J = LOW,...,IGH,
!               = P(J)     J = IGH+1,...,N.
!
!    The order in which the interchanges are made is N to IGH+1,
!    then 1 to LOW-1.
!
!    Note that 1 is returned for LOW if IGH is zero formally.
!
!  Reference:
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of A, which must
!    be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Input/output, real A(NM,N), the N by N matrix.  On output,
!    the matrix has been balanced.
!
!    Output, integer LOW, IGH, indicate that A(I,J) is equal to zero if
!    (1) I is greater than J and
!    (2) J=1,...,LOW-1 or I=IGH+1,...,N.
!
!    Output, real SCALE(N), contains information determining the
!    permutations and scaling factors used.
!
  integer nm
  integer n
!
  real a(nm,n)
  real b2
  real c
  real f
  real g
  integer i
  integer iexc
  integer igh
  integer j
  integer k
  integer l
  integer low
  integer m
  logical noconv
  real r
  real radix
  real s
  real scale(n)
!
  radix = 16.0E+00

  iexc = 0
  j = 0
  m = 0

  b2 = radix**2
  k = 1
  l = n
  go to 100

20 continue

  scale(m) = j

  if ( j /= m ) then

    do i = 1, l
      call r_swap ( a(i,j), a(i,m) )
    end do

    do i = k, n
      call r_swap ( a(j,i), a(m,i) )
    end do

  end if

50 continue

  if ( iexc == 2 ) go to 130
!
!  Search for rows isolating an eigenvalue and push them down.
!
80 continue

  if ( l == 1 ) then
    low = k
    igh = l
    return
  end if

  l = l - 1

100 continue

  do j = l, 1, -1

     do i = 1, l
       if ( i /= j ) then
         if ( a(j,i) /= 0.0E+00 ) then
           go to 120
         end if
       end if
     end do

     m = l
     iexc = 1
     go to 20

120  continue

  end do

  go to 140
!
!  Search for columns isolating an eigenvalue and push them left.
!
130 continue

  k = k + 1

140 continue

  do j = k, l

    do i = k, l
      if ( i /= j ) then
        if ( a(i,j) /= 0.0E+00 ) then
          go to 170
        end if
      end if
    end do

    m = k
    iexc = 2
    go to 20

170 continue

  end do
!
!  Balance the submatrix in rows K to L.
!
  scale(k:l) = 1.0E+00
!
!  Iterative loop for norm reduction.
!
  noconv = .true.

  do while ( noconv )

    noconv = .false.

    do i = k, l

      c = 0.0E+00
      r = 0.0E+00

      do j = k, l
        if ( j /= i ) then
          c = c + abs ( a(j,i) )
          r = r + abs ( a(i,j) )
        end if
      end do
!
!  Guard against zero C or R due to underflow.
!
      if ( c /= 0.0E+00 .and. r /= 0.0E+00 ) then

        g = r / radix
        f = 1.0E+00
        s = c + r

        do while ( c < g )
          f = f * radix
          c = c * b2
        end do

        g = r * radix

        do while ( c >= g )
          f = f / radix
          c = c / b2
        end do
!
!  Balance.
!
        if ( ( c + r ) / f < 0.95E+00 * s ) then

          g = 1.0E+00 / f
          scale(i) = scale(i) * f
          noconv = .true.

          a(i,k:n) = a(i,k:n) * g
          a(1:l,i) = a(1:l,i) * f

        end if

      end if

    end do

  end do

  low = k
  igh = l

  return
end
subroutine balbak(nm,n,low,igh,scale,m,z)
!
!*******************************************************************************
!
!! BALBAK is a translation of the algol procedure balbak,
!     num. math. 13, 293-304(1969) by parlett and reinsch.
!     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
!
!     this subroutine forms the eigenvectors of a real general
!     matrix by back transforming those of the corresponding
!     balanced matrix determined by  balanc.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by  balanc,
!
!        scale contains information determining the permutations
!          and scaling factors used by  balanc,
!
!        m is the number of columns of z to be back transformed,
!
!        z contains the real and imaginary parts of the eigen-
!          vectors to be back transformed in its first m columns.
!
!     on output-
!
!        z contains the real and imaginary parts of the
!          transformed eigenvectors in its first m columns.
!
  integer i,j,k,m,n,ii,nm,igh,low
  real scale(n),z(nm,m)
  real s
!-----------------------------------------------------------------------
  if (m == 0) go to 200
  if (igh == low) go to 120
!
  do 110 i = low, igh
     s = scale(i)
!     ********** left hand eigenvectors are back transformed
!                if the foregoing statement is replaced by
!                s=1.0/scale(i). **********
     do 100 j = 1, m
  100    z(i,j) = z(i,j) * s
!
  110 continue
!     ********- for i=low-1 step -1 until 1,
!               igh+1 step 1 until n do -- **********
  120 do 140 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 140
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 140
!
     do 130 j = 1, m
        s = z(i,j)
        z(i,j) = z(k,j)
        z(k,j) = s
  130    continue
!
  140 continue
!
  200 return
end
subroutine balinv (nz,n,z,low,igh,scale)
!
!*******************************************************************************
!
!! BALINV inverts the similarity transforms used by BALANC.
!
!        given a matrix a of order n. balanc transforms a into
!     the matrix b by the similarity transformation
!             b = d**(-1)*transpose(p)*a*p*d
!     where d is a diagonal matrix and p a permutation matrix.
!     the information concerning d and p is stored in igh, low,
!     and scale. the order in which the interchanges were made
!     is n to igh + 1, and then 1 to low - 1.
!
!        z is a matrix of order n. balinv transforms z into the
!     matrix w using the inverse similarity transform
!             w = p*d*z*d**(-1)*transpose(p)
!
!     on input-
!
!        nz is the row dimension of the matrix z in the calling
!          program,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by  balanc,
!
!        scale contains information determining the permutations
!          and scaling factors used by  balanc,
!
!     on output-
!
!        z contains the transformed matrix w
!
  integer i,j,k,n,ii,nz,igh,low
  real z(nz,n),scale(n)
  real s
!-----------------------------------------------------------------------
!
  if (igh == low) go to 30
!
  do 11 i = low, igh
  s = scale(i)
     do 10 j = 1, n
   10    z(i,j) = z(i,j) * s
   11 continue
!
  do 21 j = low, igh
  s = 1.0/scale(j)
     do 20 i = 1, n
   20    z(i,j) = z(i,j) * s
   21 continue
!
!     ********- for i=low-1 step -1 until 1,
!               igh+1 step 1 until n do -- **********
!
   30 do 60 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 60
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 60
!
     do 40 j = 1, n
        s = z(i,j)
        z(i,j) = z(k,j)
   40       z(k,j) = s
!
     do 50 j = 1, n
        s = z(j,i)
        z(j,i) = z(j,k)
   50       z(j,k) = s
   60 continue
  return
end
subroutine banfac ( w, nroww, nrow, nbandl, nbandu, iflag )
!
!*******************************************************************************
!
!! BANFAC computes the LU factorization of a banded matrix.
!
!  from  * a practical guide to splines *  by c. de boor
!  returns in  w  the lu-factorization (without pivoting) of the banded
!  matrix  a  of order  nrow  with  (nbandl + 1 + nbandu) bands or diag-
!  onals in the work array  w .
!
!  Input
!
!  w.....work array of size  (nroww,nrow)  containing the interesting
!        part of a banded matrix  a , with the diagonals or bands of  a
!        stored in the rows of  w , while columns of  a  correspond to
!        columns of  w . this is the storage mode used in  linpack  and
!        results in efficient innermost loops.
!           explicitly,  a  has  nbandl  bands below the diagonal
!                            +     1     (main) diagonal
!                            +   nbandu  bands above the diagonal
!        and thus, with    middle = nbandu + 1,
!          a(i+j,j)  is in  w(i+middle,j)  for i=-nbandu,...,nbandl
!                                              j=1,...,nrow .
!        for example, the interesting entries of a (1,2)-banded matrix
!        of order  9  would appear in the first  1+1+2 = 4  rows of  w
!        as follows.
!                          13 24 35 46 57 68 79
!                       12 23 34 45 56 67 78 89
!                    11 22 33 44 55 66 77 88 99
!                    21 32 43 54 65 76 87 98
!
!        all other entries of  w  not identified in this way with an en-
!        try of  a  are never referenced .
!  nroww.....row dimension of the work array  w .
!        must be  >=  nbandl + 1 + nbandu  .
!  nbandl.....number of bands of  a  below the main diagonal
!  nbandu.....number of bands of  a  above the main diagonal .
!
!******  o u t p u t  ******
!  iflag.....integer indicating success( = 1) or failure ( = 2) .
!     if  iflag = 1, then
!  w.....contains the lu-factorization of  a  into a unit lower triangu-
!        lar matrix  l  and an upper triangular matrix  u (both banded)
!        and stored in customary fashion over the corresponding entries
!        of  a . this makes it possible to solve any particular linear
!        system  a*x = b  for  x  by a
!              call banslv ( w, nroww, nrow, nbandl, nbandu, b )
!        with the solution x  contained in  b  on return .
!     if  iflag = 2, then
!        one of  nrow-1, nbandl,nbandu failed to be nonnegative, or else
!        one of the potential pivots was found to be zero indicating
!        that  a  does not have an lu-factorization. this implies that
!        a  is singular in case it is totally positive .
!
!******  m e t h o d  ******
!     gauss elimination  w i t h o u t  pivoting is used. the routine is
!  intended for use with matrices  a  which do not require row inter-
!  changes during factorization, especially for the  t o t a l l y
!  p o s i t i v e  matrices which occur in spline calculations.
!     the routine should not be used for an arbitrary banded matrix.
!
  real w(nroww,nrow),   factor,pivot
!
  iflag = 1
  middle = nbandu + 1
!                         w(middle,.) contains the main diagonal of  a .
  nrowm1 = nrow - 1
  if (nrowm1)                       999,900,1
1 if (nbandl > 0)                go to 10
!                a is upper triangular. check that diagonal is nonzero .
  do 5 i=1,nrowm1
     if (w(middle,i) == 0.)       go to 999
5    continue
                                    go to 900
   10 if (nbandu > 0)                go to 20
!              a is lower triangular. check that diagonal is nonzero and
!                 divide each column by its diagonal .
  do 15 i=1,nrowm1
     pivot = w(middle,i)
     if(pivot == 0.)              go to 999
     jmax = min (nbandl, nrow - i)
     jbeg = middle + 1
     jend = middle + jmax
     do 15 j=jbeg,jend
   15       w(j,i) = w(j,i)/pivot
                                    go to 900
!
!        a  is not just a triangular matrix. construct lu factorization
   20 do 50 i=1,nrowm1
!                                  w(middle,i)  is pivot for i-th step .
     pivot = w(middle,i)
     if (pivot == 0.)             go to 999
!                 jmax  is the number of (nonzero) entries in column  i
!                     below the diagonal .
     jmax = min (nbandl,nrow - i)
!              divide each entry in column  i  below diagonal by pivot .
     jbeg = middle + 1
     jend = middle + jmax
     do 32 j=jbeg,jend
   32       w(j,i) = w(j,i)/pivot
!                 kmax  is the number of (nonzero) entries in row  i  to
!                     the right of the diagonal .
     kmax = min (nbandu,nrow - i)
!                  subtract  a(i,i+k)*(i-th column) from (i+k)-th column
!                  (below row  i ) .
     do 40 k=1,kmax
        ipk = i + k
        midmk = middle - k
        factor = w(midmk,ipk)
        do 40 j=1,jmax
           mj = middle + j
           mdj = midmk + j
   40          w(mdj,ipk) = w(mdj,ipk) - w(mj,i)*factor
   50    continue
!                                       check the last diagonal entry .
  900 if (w(middle,nrow) /= 0.)       return
  999 iflag = 2
                                    return
end
subroutine banslv ( w, nroww, nrow, nbandl, nbandu, b )
!
!*******************************************************************************
!
!! BANSLV solves a linear system factored by BANFAC.
!
!  from  * a practical guide to splines *  by c. de boor
!  companion routine to  banfac . it returns the solution  x  of the
!  linear system  a*x = b  in place of  b , given the lu-factorization
!  for  a  in the workarray  w .
!
!******  i n p u t  ******
!  w, nroww,nrow,nbandl,nbandu.....describe the lu-factorization of a
!        banded matrix  a  of roder  nrow  as constructed in  banfac .
!        for details, see  banfac .
!  b.....right side of the system to be solved .
!
!******  o u t p u t  ******
!  b.....contains the solution  x , of order  nrow .
!
!******  m e t h o d  ******
!     (with  a = l*u, as stored in  w,) the unit lower triangular system
!  l(u*x) = b  is solved for  y = u*x, and  y  stored in  b . then the
!  upper triangular system  u*x = y  is solved for  x  . the calcul-
!  ations are so arranged that the innermost loops stay within columns.
!
  real w(nroww,nrow),b(nrow)
  middle = nbandu + 1
  if (nrow == 1)                  go to 49
  nrowm1 = nrow - 1
  if (nbandl == 0)                go to 30
!                                 forward pass
!            for i=1,2,...,nrow-1, subtract  right side(i)*(i-th column
!            of  l )  from right side  (below i-th row) .
  do 21 i=1,nrowm1
     jmax = min (nbandl, nrow-i)
     do 21 j=1,jmax
        ipj = i + j
        mpj = middle + j
   21       b(ipj) = b(ipj) - b(i)*w(mpj,i)
!                                 backward pass
!            for i=nrow,nrow-1,...,1, divide right side(i) by i-th diag-
!            onal entry of  u, then subtract  right side(i)*(i-th column
!            of  u)  from right side  (above i-th row).
   30 if (nbandu > 0)                go to 40
!                                a  is lower triangular .
  do 31 i=1,nrow
   31    b(i) = b(i)/w(1,i)
                                    return
   40 i = nrow
   41    b(i) = b(i)/w(middle,i)
     jmax = min (nbandu,i-1)
     do 45 j=1,jmax
        imj = i - j
        mmj = middle - j
   45       b(imj) = b(imj) - b(i)*w(mmj,i)
     i = i - 1
     if (i > 1)                  go to 41
   49 b(1) = b(1)/w(middle,1)
                                    return
end
subroutine basiz(degree,npts,dimen,npolys,error)
!
!*******************************************************************************
!
!! BASIZ finds the size of a basis required for polynomial approximation.
!
  integer top,bot,degree,npts,dimen,npolys,error,i,rowlen
!
!     ***************
!     purpose
!     -------
!
!     if  degree  >= 0 then
!       find the size of a basis required either to
!       1) approximate the data with a polynomial of degree
!          given by the parameter  degree
!       or to
!       2) span the space of polynomials of degree <= the
!          smallest degree of polynomial which interpolates the
!          data.
!       in case 1  error  = 0.
!       in case 2  error  = 1.
!     else
!       if  npolys  >= 1 then
!          if npolys > npts then
!             set  npolys  =  npts , find the smallest degree of a
!             polynomial  which  interpolates  the  data,  and set
!              error  = 1.
!          else
!             find the largest degree  degree  of a polynomial  in
!             a  basis of  npolys  polynomials generated according
!             to our ordering and set  error  = 0.
!       else
!           error  = 2
!
!     this subroutine is called by  allot .  it is not  called  by
!     the user directly.
!
!     date last modified
!     ---- ---- --------
!     october 16, 1984
!     ****************
!
  error = 0
  if ( npts >= 1 .and. dimen >= 1 ) go to 10
     error = 3
     return
!
 10   continue
  if ( degree < 0 ) go to 30
!
    rowlen = 1
    npolys = 1
    top = dimen - 1
    bot = 0
    if ( degree < 1 )  go to 30
      do 20 i=1,degree
        top = top + 1
        bot = bot + 1
        rowlen = (rowlen*top)/bot
        npolys = npolys + rowlen
   20     continue
!
   30 continue
  if ( npolys >= 1 ) go to 40
        error = 2
        return
   40 continue
  if ( npolys < npts ) go to 50
        npolys = npts
        error = 1
   50 continue
  rowlen = 1
  i = 1
  degree = 0
  top = dimen - 1
  bot = 0
   60 continue
  if ( i >= npolys )  go to 70
      top = top + 1
      bot = bot + 1
      rowlen = (rowlen*top)/bot
      i = i + rowlen
      degree = degree + 1
      if ( i < npolys )  go to 60
   70 continue
  return
end
function basym(a, b, lambda, eps)
!
!*******************************************************************************
!
!! BASYM carries out asymptotic expansion for ix(a,b) for large a and b.
!
!
!     lambda = (a + b)*y - b  and eps is the tolerance used.
!     it is assumed that lambda is nonnegative and that
!     a and b are greater than or equal to 15.
!
  real basym
  real j0, j1, lambda
  real a0(21), b0(21), c(21), d(21)
!------------------------
!     ****** num is the maximum value that n can take in the do loop
!            ending at statement 50. it is required that num be even.
!            the arrays a0, b0, c, d have dimension num + 1.
!
                  data num/20/
!------------------------
!     e0 = 2/sqrt(pi)
!     e1 = 2**(-3/2)
!------------------------
  data e0/1.12837916709551/, e1/.353553390593274/
!------------------------
  basym = 0.0
  if (a >= b) go to 10
     h = a/b
     r0 = 1.0/(1.0 + h)
     r1 = (b - a)/b
     w0 = 1.0/sqrt(a*(1.0 + h))
     go to 20
   10 h = b/a
  r0 = 1.0/(1.0 + h)
  r1 = (b - a)/a
  w0 = 1.0/sqrt(b*(1.0 + h))
!
   20 f = a*rlog1(-lambda/a) + b*rlog1(lambda/b)
  t = exp(-f)
  if (t == 0.0) return
  z0 = sqrt(f)
  z = 0.5*(z0/e1)
  z2 = f + f
!
  a0(1) = (2.0/3.0)*r1
  c(1) = - 0.5*a0(1)
  d(1) = - c(1)
  j0 = (0.5/e0)*erfc1(1,z0)
  j1 = e1
  sum = j0 + d(1)*w0*j1
!
  s = 1.0
  h2 = h*h
  hn = 1.0
  w = w0
  znm1 = z
  zn = z2
  do 50 n = 2, num, 2
     hn = h2*hn
     a0(n) = 2.0*r0*(1.0 + h*hn)/(n + 2.0)
     np1 = n + 1
     s = s + hn
     a0(np1) = 2.0*r1*s/(n + 3.0)
!
     do 41 i = n, np1
     r = -0.5*(i + 1.0)
     b0(1) = r*a0(1)
     do 31 m = 2, i
        bsum = 0.0
        mm1 = m - 1
        do 30 j = 1, mm1
           mmj = m - j
   30          bsum = bsum + (j*r - mmj)*a0(j)*b0(mmj)
   31       b0(m) = r*a0(m) + bsum/m
     c(i) = b0(i)/(i + 1.0)
!
     dsum = 0.0
     im1 = i - 1
     do 40 j = 1, im1
        imj = i - j
   40       dsum = dsum + d(imj)*c(j)
   41    d(i) = -(dsum + c(i))
!
     j0 = e1*znm1 + (n - 1.0)*j0
     j1 = e1*zn + n*j1
     znm1 = z2*znm1
     zn = z2*zn
     w = w0*w
     t0 = d(n)*w*j0
     w = w0*w
     t1 = d(np1)*w*j1
     sum = sum + (t0 + t1)
     if ((abs(t0) + abs(t1)) <= eps*sum) go to 60
   50    continue
!
   60 u = exp(-bcorr(a,b))
  basym = e0*t*u*sum
  return
end
subroutine bchfac ( w, nbands, nrow, diag )
!
!*******************************************************************************
!
!! BCHFAC computes the Cholesky factorization of a banded matrix.
!
!  from  * a practical guide to splines *  by c. de boor
!  constructs cholesky factorization
!                     c  =  l * d * l-transpose
!  with l unit lower triangular and d diagonal, for given matrix c of
!  order  n r o w , in case  c  is (symmetric) positive semidefinite
!  and  b a n d e d , having  n b a n d s  diagonals at and below the
!  main diagonal.
!
!******  i n p u t  ******
!  nrow.....is the order of the matrix  c .
!  nbands.....indicates its bandwidth, i.e.,
!          c(i,j) = 0 for abs(i-j) > nbands .
!  w.....workarray of size (nbands,nrow)  containing the  nbands  diago-
!        nals in its rows, with the main diagonal in row  1 . precisely,
!        w(i,j)  contains  c(i+j-1,j), i=1,...,nbands, j=1,...,nrow.
!          for example, the interesting entries of a seven diagonal sym-
!        metric matrix  c  of order  9  would be stored in  w  as
!
!                       11 22 33 44 55 66 77 88 99
!                       21 32 43 54 65 76 87 98
!                       31 42 53 64 75 86 97
!                       41 52 63 74 85 96
!
!        all other entries of  w  not identified in this way with an en-
!        try of  c  are never referenced .
!  diag.....is a work array of length  nrow .
!
!******  o u t p u t  ******
!  w.....contains the cholesky factorization  c = l*d*l-transp, with
!        w(1,i) containing  1/d(i,i)
!        and  w(i,j)  containing  l(i-1+j,j), i=2,...,nbands.
!
!******  m e t h o d  ******
!   gauss elimination, adapted to the symmetry and bandedness of  c , is
!   used .
!     near zero pivots are handled in a special way. the diagonal ele-
!  ment c(n,n) = w(1,n) is saved initially in  diag(n), all n. at the n-
!  th elimination step, the current pivot element, viz.  w(1,n), is com-
!  pared with its original value, diag(n). if, as the result of prior
!  elimination steps, this element has been reduced by about a word
!  length, (i.e., if w(1,n)+diag(n) <= diag(n)), then the pivot is de-
!  clared to be zero, and the entire n-th row is declared to be linearly
!  dependent on the preceding rows. this has the effect of producing
!   x(n) = 0  when solving  c*x = b  for  x, regardless of  b. justific-
!  ation for this is as follows. in contemplated applications of this
!  program, the given equations are the normal equations for some least-
!  squares approximation problem, diag(n) = c(n,n) gives the norm-square
!  of the n-th basis function, and, at this point,  w(1,n)  contains the
!  norm-square of the error in the least-squares approximation to the n-
!  th basis function by linear combinations of the first n-1 . having
!  w(1,n)+diag(n) <= diag(n) signifies that the n-th function is lin-
!  early dependent to machine accuracy on the first n-1 functions, there
!  fore can safely be left out from the basis of approximating functions
!     the solution of a linear system
!                       c*x = b
!   is effected by the succession of the following  t w o  calls ...
!     call bchfac ( w, nbands, nrow, diag )       , to get factorization
!     call bchslv ( w, nbands, nrow, b, x )            , to solve for x.
!
  real w(nbands,nrow),diag(nrow),   ratio
  if (nrow > 1)                  go to 9
  if (w(1,1) > 0.) w(1,1) = 1./w(1,1)
                                    return
!                                        store diagonal of  c  in  diag.
9 do 10 n=1,nrow
   10    diag(n) = w(1,n)
!                                                        factorization .
  do 20 n=1,nrow
     if (w(1,n)+diag(n) > diag(n)) go to 15
     do 14 j=1,nbands
   14       w(j,n) = 0.
                                    go to 20
   15    w(1,n) = 1./w(1,n)
     imax = min (nbands-1,nrow - n)
     if (imax < 1)               go to 20
     jmax = imax
     do 18 i=1,imax
        ratio = w(i+1,n)*w(1,n)
        npi = n + i
        do 17 j=1,jmax
           ipj = i + j
   17          w(j,npi) = w(j,npi) - w(ipj,n)*ratio
        jmax = jmax - 1
   18       w(i+1,n) = ratio
   20    continue
                                    return
end
subroutine bchslv ( w, nbands, nrow, b )
!
!*******************************************************************************
!
!! BCHSLV solves a linear system factored by BCHFAC.
!
!  from  * a practical guide to splines *  by c. de boor
!  solves the linear system     c*x = b   of order  n r o w  for  x
!  provided  w  contains the cholesky factorization for the banded (sym-
!  metric) positive definite matrix  c  as constructed in the subroutine
!    b c h f a c  (quo vide).
!
!******  i n p u t  ******
!  nrow.....is the order of the matrix  c .
!  nbands.....indicates the bandwidth of  c .
!  w.....contains the cholesky factorization for  c , as output from
!        subroutine bchfac  (quo vide).
!  b.....the vector of length  n r o w  containing the right side.
!
!******  o u t p u t  ******
!  b.....the vector of length  n r o w  containing the solution.
!
!******  m e t h o d  ******
!  with the factorization  c = l*d*l-transpose  available, where  l  is
!  unit lower triangular and  d  is diagonal, the triangular system
!  l*y = b  is solved for  y (forward substitution), y is stored in  b,
!  the vector  d**(-1)*y is computed and stored in  b, then the triang-
!  ular system  l-transpose*x = d**(-1)*y is solved for  x (backsubstit-
!  ution).
  real w(nbands,nrow),b(nrow)
  if (nrow > 1)                  go to 21
  b(1) = b(1)*w(1,1)
                                    return
!
!                 forward substitution. solve l*y = b for y, store in b.
   21 nbndm1 = nbands - 1
  do 30 n=1,nrow
     jmax = min (nbndm1,nrow-n)
     if (jmax < 1)               go to 30
     do 25 j=1,jmax
        jpn = j + n
   25       b(jpn) = b(jpn) - w(j+1,n)*b(n)
   30    continue
!
!     backsubstitution. solve l-transp.x = d**(-1)*y  for x, store in b.
  n = nrow
   31    b(n) = b(n)*w(1,n)
     jmax = min (nbndm1,nrow-n)
     if (jmax < 1)               go to 40
     do 35 j=1,jmax
        jpn = j + n
   35       b(n) = b(n) - w(j+1,n)*b(jpn)
   40    n = n-1
  if (n > 0)                       go to 31
                                    return
end
function bcorr (a0, b0)
!
!*******************************************************************************
!
!! BCORR evaluates a correction term used to approximate log ( gamma ( x ) ).
!
!     evaluation of  del(a0) + del(b0) - del(a0 + b0)  where
!     ln(gamma(a)) = (a - 0.5)*ln(a) - a + 0.5*ln(2*pi) + del(a).
!     it is assumed that a0 >= 8 and b0 >= 8.
!
!
  real bcorr
  data c0/.833333333333333e-01/, c1/-.277777777760991e-02/, &
       c2/.793650666825390e-03/, c3/-.595202931351870e-03/, &
       c4/.837308034031215e-03/, c5/-.165322962780713e-02/
!
  a = amin1(a0, b0)
  b = max ( a0, b0)
!
  h = a/b
  c = h/(1.0 + h)
  x = 1.0/(1.0 + h)
  x2 = x*x
!
!                set sn = (1 - x**n)/(1 - x)
!
  s3 = 1.0 + (x + x2)
  s5 = 1.0 + (x + x2*s3)
  s7 = 1.0 + (x + x2*s5)
  s9 = 1.0 + (x + x2*s7)
  s11 = 1.0 + (x + x2*s9)
!
!                set w = del(b) - del(a + b)
!
  t = (1.0/b)**2
  w = ((((c5*s11*t + c4*s9)*t + c3*s7)*t + c2*s5)*t + c1*s3)*t + c0
  w = w*(c/b)
!
!                   compute  del(a) + w
!
  t = (1.0/a)**2
  bcorr = (((((c5*t + c4)*t + c3)*t + c2)*t + c1)*t + c0)/a + w
  return
end
subroutine besi ( x, alpha, kode, n, y, nz )
!
!*******************************************************************************
!
!! BESI computes a sequence of I Bessel functions.
!
!     written by d. e. amos and s. l. daniel, january,1975.
!
!     reference
!         sand-75-0152
!
!         cdc 6600 subroutines ibess and jbess for Bessel functions
!         i(nu,x) and j(nu,x), x >= 0, nu >= 0  by d.e. amos, s.l.
!         daniel, m.k. weston. acm trans math software,3,pp 76-92
!         (1977)
!
!         tables of Bessel functions of moderate or large orders,
!         npl mathematical tables, vol. 6, by f.w.j. olver, her
!         majesty-s stationery office, london, 1962.
!
!     abstract
!         besi computes an n member sequence of i Bessel functions
!         i/sub(alpha+k-1)/(x), k=1,...,n or scaled Bessel functions
!         exp(-x)*i/sub(alpha+k-1)/(x), k=1,...,n for non-negative alpha
!         and x. a combination of the power series, the asymptotic
!         expansion for x to infinity, and the uniform asymptotic
!         expansion for nu to infinity are applied over subdivisions of
!         the (nu,x) plane. for values not covered by one of these
!         formulae, the order is incremented by an integer so that one
!         of these formulae apply. backward recursion is used to reduce
!         orders by integer values. the asymptotic expansion for x to
!         infinity is used only when the entire sequence (specifically
!         the last member) lies within the region covered by the
!         expansion. leading terms of these expansions are used to test
!         for over or underflow where appropriate. if a sequence is
!         requested and the last member would underflow, the result is
!         set to zero and the next lower order tried, etc., until a
!         member comes on scale or all are set to zero. an overflow
!         cannot occur with scaling.
!
!         besi calls asik, gamln, and ipmpar
!
!     description of arguments
!
!         input
!           x      - x >= 0.0e0
!           alpha  - order of first member of the sequence,
!                    alpha >= 0.0e0
!           kode   - a parameter to indicate the scaling option
!                    kode=1 returns
!                           y(k)=        i/sub(alpha+k-1)/(x),
!                                k=1,...,n
!                    kode=2 returns
!                           y(k)=exp(-x)*i/sub(alpha+k-1)/(x),
!                                k=1,...,n
!           n      - number of members in the sequence, n >= 1
!
!         output
!           y      - a vector whose first n components contain
!                    values for i/sub(alpha+k-1)/(x) or scaled
!                    values for exp(-x)*i/sub(alpha+k-1)/(x),
!                    k=1,...,n depending on kode
!           nz     - error indicator
!                    nz= 0     normal return-computation completed
!                    nz=-1     x is less than 0.0
!                    nz=-2     alpha is less than 0.0
!                    nz=-3     n is less than 1
!                    nz=-4     kode is not 1 or 2
!                    nz=-5     x is too large for kode=1
!                    nz > 0   last nz components of y set to 0.0
!                              because of underflow
!
!     error conditions
!         improper input arguments - a fatal error
!         overflow with kode=1 - a fatal error
!         underflow - a non-fatal error(nz > 0)
!
  integer i, ialp, in, inlim, is, i1, i2, k, kk, km, kode, kt, &
   n, nn, ns, nz
  integer ipmpar
  real ain, ak, akm, alpha, ans, ap, arg, atol, tolln, dfn, &
   dtm, dx, earg, elim, etx, flgik,fn, fnf, fni,fnp1,fnu,gln,ra, &
   rttpi, s, sx, sxo2, s1, s2, t, ta, tb, temp, tfn, tm, tol, &
   trx, t2, x, xo2, xo2l, y, z
  real gamln
  dimension y(n), temp(3)
  data rttpi           / 3.98942280401433e-01/
  data inlim           /          80         /
!
!     ipmpar(8) replaces ipmpar(5) in a double precision code
!     ipmpar(9) replaces ipmpar(6) in a double precision code
!
!     definition of the tolerances tol and elim
!
  tb = ipmpar(4)
  ta = epsilon ( ta ) / tb
  if (tb == 2.0e0) go to 1
  if (tb == 8.0e0) go to 2
  if (tb == 16.0e0) go to 3
  tb = alog(tb)
  go to 5
1 tb = .69315e0
  go to 5
2 tb = 2.07944e0
  go to 5
3 tb = 2.77259e0
!
5 tol = max ( ta,1.e-15)
  i1 = ipmpar(5)
  i2 = ipmpar(6)
!     ln(10**3) = 6.90776
  elim = real(-i2)*tb - 6.90776e0
!     tolln = -ln(tol)
  tolln = real(i1)*tb
  tolln = amin1(tolln,34.5388e0)
!
!
!
  nz = 0
  kt = 1
  if (n-1) 590, 10, 20
   10 kt = 2
   20 nn = n
  if (kode < 1 .or. kode > 2) go to 570
  if (x) 600, 30, 80
   30 if (alpha) 580, 40, 50
   40 y(1) = 1.0e0
  if (n == 1) return
  i1 = 2
  go to 60
   50 i1 = 1
   60 do 70 i=i1,n
    y(i) = 0.0e0
   70 continue
  return
   80 continue
  if (alpha < 0.0e0) go to 580
!
  ialp = int(alpha)
  fni = real(ialp+n-1)
  fnf = alpha - real(ialp)
  dfn = fni + fnf
  fnu = dfn
  in = 0
  xo2 = x*0.5e0
  sxo2 = xo2*xo2
  etx = real(kode-1)
  sx = etx*x
!
!     decision tree for region where series, asymptotic expansion for x
!     to infinity and asymptotic expansion for nu to infinity are
!     applied.
!
  if (sxo2 <= (fnu+1.0e0)) go to 90
  if (x <= 12.0e0) go to 110
  fn = 0.55e0*fnu*fnu
  fn = max ( 17.0e0,fn)
  if (x >= fn) go to 430
  ans = max ( 36.0e0-fnu,0.0e0)
  ns = int(ans)
  fni = fni + real(ns)
  dfn = fni + fnf
  fn = dfn
  is = kt
  km = n - 1 + ns
  if (km > 0) is = 3
  go to 120
   90 fn = fnu
  fnp1 = fn + 1.0e0
  xo2l = alog(xo2)
  is = kt
  if (x <= 0.5e0) go to 230
  ns = 0
  100 fni = fni + real(ns)
  dfn = fni + fnf
  fn = dfn
  fnp1 = fn + 1.0e0
  is = kt
  if (n-1+ns > 0) is = 3
  go to 230
  110 xo2l = alog(xo2)
  ns = int(sxo2-fnu)
  go to 100
  120 continue
!
!     overflow test on uniform asymptotic expansion
!
  if (kode == 2) go to 130
  if (alpha < 1.0e0) go to 150
  z = x/alpha
  ra = sqrt(1.0e0+z*z)
  gln = alog((1.0e0+ra)/z)
  t = ra*(1.0e0-etx) + etx/(z+ra)
  arg = alpha*(t-gln)
  if (arg > elim) go to 610
  if (km == 0) go to 140
  130 continue
!
!     underflow test on uniform asymptotic expansion
!
  z = x/fn
  ra = sqrt(1.0e0+z*z)
  gln = alog((1.0e0+ra)/z)
  t = ra*(1.0e0-etx) + etx/(z+ra)
  arg = fn*(t-gln)
  140 if (arg < (-elim)) go to 280
  go to 190
  150 if (x > elim) go to 610
  go to 130
!
!     uniform asymptotic expansion for nu to infinity
!
  160 if (km/=0) go to 170
  y(1) = temp(3)
  return
  170 temp(1) = temp(3)
  in = ns
  kt = 1
  i1 = 0
  180 continue
  is = 2
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if(i1 == 2) go to 350
  z = x/fn
  ra = sqrt(1.0e0+z*z)
  gln = alog((1.0e0+ra)/z)
  t = ra*(1.0e0-etx) + etx/(z+ra)
  arg = fn*(t-gln)
  190 continue
  i1 = iabs(3-is)
  i1 = max (i1,1)
  flgik = 1.0e0
  call asik(x,fn,kode,flgik,ra,arg,i1,tol,temp(is))
  go to (180, 350, 510), is
!
!     series for (x/2)**2 <= nu+1
!
  230 continue
  gln = gamln(fnp1)
  arg = fn*xo2l - gln - sx
  if (arg < (-elim)) go to 300
  earg = exp(arg)
  240 continue
  s = 1.0e0
  if (x < tol) go to 260
  ak = 3.0e0
  t2 = 1.0e0
  t = 1.0e0
  s1 = fn
  do 250 k=1,17
    s2 = t2 + s1
    t = t*sxo2/s2
    s = s + t
    if (abs(t) < tol) go to 260
    t2 = t2 + ak
    ak = ak + 2.0e0
    s1 = s1 + fn
  250 continue
  260 continue
  temp(is) = s*earg
  go to (270, 350, 500), is
  270 earg = earg*fn/xo2
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  is = 2
  go to 240
!
!     set underflow value and update parameters
!
  280 y(nn) = 0.0e0
  nn = nn - 1
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if (nn-1) 340, 290, 130
  290 kt = 2
  is = 2
  go to 130
  300 y(nn) = 0.0e0
  nn = nn - 1
  fnp1 = fn
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if (nn-1) 340, 310, 320
  310 kt = 2
  is = 2
  320 if (sxo2 <= fnp1) go to 330
  go to 130
  330 arg = arg - xo2l + alog(fnp1)
  if (arg < (-elim)) go to 300
  go to 230
  340 nz = n - nn
  return
!
!     backward recursion section
!
  350 continue
  nz = n - nn
  360 continue
  if(kt == 2) go to 420
  s1 = temp(1)
  s2 = temp(2)
  trx = 2.0e0/x
  dtm = fni
  tm = (dtm+fnf)*trx
  if (in == 0) go to 390
!     backward recur to index alpha+nn-1
  do 380 i=1,in
    s = s2
    s2 = tm*s2 + s1
    s1 = s
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
  380 continue
  y(nn) = s1
  if (nn == 1) return
  y(nn-1) = s2
  if (nn == 2) return
  go to 400
  390 continue
!     backward recur from index alpha+nn-1 to alpha
  y(nn) = s1
  y(nn-1) = s2
  if (nn == 2) return
  400 k = nn + 1
  do 410 i=3,nn
    k = k - 1
    y(k-2) = tm*y(k-1) + y(k)
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
  410 continue
  return
  420 y(1) = temp(2)
  return
!
!     asymptotic expansion for x to infinity
!
  430 continue
  earg = rttpi/sqrt(x)
  if (kode == 2) go to 440
  if (x > elim) go to 610
  earg = earg*exp(x)
  440 etx = 8.0e0*x
  is = kt
  in = 0
  fn = fnu
  450 dx = fni + fni
  tm = 0.0e0
  if (fni == 0.0e0 .and. abs(fnf) < tol) go to 460
  tm = 4.0e0*fnf*(fni+fni+fnf)
  460 continue
  dtm = dx*dx
  s1 = etx
  trx = dtm - 1.0e0
  dx = -(trx+tm)/etx
  t = dx
  s = 1.0e0 + dx
  atol = tol*abs(s)
  s2 = 1.0e0
  ak = 8.0e0
  do 470 k=1,25
    s1 = s1 + etx
    s2 = s2 + ak
    dx = dtm - s2
    ap = dx + tm
    t = -t*ap/s1
    s = s + t
    if (abs(t) <= atol) go to 480
    ak = ak + 8.0e0
  470 continue
  480 temp(is) = s*earg
  if(is == 2) go to 360
  is = 2
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  go to 450
!
!     backward recursion with normalization by
!     asymptotic expansion for nu to infinity or power series.
!
  500 continue
!     computation of last order for series normalization
  akm = max ( 3.0e0-fn,0.0e0)
  km = int(akm)
  tfn = fn + real(km)
  ta = (gln+tfn-0.9189385332e0-0.0833333333e0/tfn)/(tfn+0.5e0)
  ta = xo2l - ta
  tb = -(1.0e0-1.0e0/tfn)/tfn
  ain = tolln/(-ta+sqrt(ta*ta-tolln*tb)) + 1.5e0
  in = int(ain)
  in = in + km
  go to 520
  510 continue
!     computation of last order for asymptotic expansion normalization
  t = 1.0e0/(fn*ra)
  ain = tolln/(gln+sqrt(gln*gln+t*tolln)) + 1.5e0
  in = int(ain)
  if (in > inlim) go to 160
  520 continue
  trx = 2.0e0/x
  dtm = fni + real(in)
  tm = (dtm+fnf)*trx
  ta = 0.0e0
  tb = tol
  kk = 1
  530 continue
!
!     backward recur unindexed
!
  do 540 i=1,in
    s = tb
    tb = tm*tb + ta
    ta = s
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
  540 continue
!     normalization
  if (kk/=1) go to 550
  ta = (ta/tb)*temp(3)
  tb = temp(3)
  kk = 2
  in = ns
  if (ns/=0) go to 530
  550 y(nn) = tb
  nz = n - nn
  if (nn == 1) return
  tb = tm*tb + ta
  k = nn - 1
  y(k) = tb
  if (nn == 2) return
  dtm = dtm - 1.0e0
  tm = (dtm+fnf)*trx
  km = k - 1
!
!     backward recur indexed
!
  do 560 i=1,km
    y(k-1) = tm*y(k) + y(k+1)
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
    k = k - 1
  560 continue
  return
!
!
!
  570 continue
  nz = -4
  return
  580 continue
  nz = -2
  return
  590 continue
  nz = -3
  return
  600 continue
  nz = -1
  return
  610 continue
  nz = -5
  return
end
subroutine besi0_values ( n, x, fx )
!
!*******************************************************************************
!
!! BESI0_VALUES returns some values of the I0 Bessel function for testing.
!
!
!  Modified:
!
!    19 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    1.0000000E+00, 1.0100250E+00, 1.0404018E+00, 1.0920453E+00, &
    1.1665149E+00, 1.2660658E+00, 1.3937256E+00, 1.5533951E+00, &
    1.7499807E+00, 1.9895593E+00, 2.2795852E+00, 3.2898391E+00, & 
    4.8807925E+00, 7.3782035E+00, 11.301922E+00, 17.481172E+00, &
    27.239871E+00, 67.234406E+00, 427.56411E+00, 2815.7167E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.0E+00,  0.2E+00,  0.4E+00,  0.6E+00, &
    0.8E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
    1.6E+00,  1.8E+00,  2.0E+00,  2.5E+00, &
    3.0E+00,  3.5E+00,  4.0E+00,  4.5E+00, &
    5.0E+00,  6.0E+00,  8.0E+00, 10.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine besi1_values ( n, x, fx )
!
!*******************************************************************************
!
!! BESI1_VALUES returns some values of the I1 Bessel function for testing.
!
!
!  Modified:
!
!    22 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.00000000E+00, 0.10050083E+00, 0.20402675E+00, 0.31370403E+00, &
    0.43286480E+00, 0.56515912E+00, 0.71467794E+00, 0.88609197E+00, &
    1.0848107E+00,  1.3171674E+00,  1.5906369E+00,  2.5167163E+00, &
    3.9533700E+00,  6.2058350E+00,  9.7594652E+00,  15.389221E+00, &
    24.335643E+00,  61.341937E+00,  399.87313E+00,  2670.9883E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.0E+00,  0.2E+00,  0.4E+00,  0.6E+00, &
    0.8E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
    1.6E+00,  1.8E+00,  2.0E+00,  2.5E+00, &
    3.0E+00,  3.5E+00,  4.0E+00,  4.5E+00, &
    5.0E+00,  6.0E+00,  8.0E+00, 10.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine besin_values ( n, nu, x, fx )
!
!*******************************************************************************
!
!! BESIN_VALUES returns some values of the IN Bessel function for testing.
!
!
!  Modified:
!
!    29 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, integer NU, the order of the function.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 28
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    5.0166876E-03,   1.3574767E-01,   6.8894844E-01,   1.2764661E+00, &
    2.2452125E+00,   17.505615E+00,   2281.5189E+00,   3.9312785E+07, &
    2.216842492E-02, 2.127399592E-01, 1.033115017E+01, 1.758380717E+01, &
    2.67776414E+20,  2.714631560E-04, 9.825679323E-03, 2.157974547E+00, &
    7.771882864E+02, 2.27854831E+20,  2.752948040E-10, 3.016963879E-07, &
    4.580044419E-03, 2.189170616E+01, 1.07159716E+20,  3.966835986E-25, &
    4.310560576E-19, 5.024239358E-11, 1.250799736E-04, 5.44200840E+18 /)
  integer n
  integer nu
  integer, save, dimension ( nmax ) :: nvec = (/ &
     2,  2,  2,  2, &
     2,  2,  2,  2, &
     3,  3,  3,  3, &
     3,  5,  5,  5, &
     5,  5, 10, 10, &
    10, 10, 10, 20, &
    20, 20, 20, 20 /)
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.2E+00,  1.0E+00,  2.0E+00,  2.5E+00, &
     3.0E+00,  5.0E+00, 10.0E+00, 20.0E+00, &
     1.0E+00,  2.0E+00,  5.0E+00, 10.0E+00, &
    50.0E+00,  1.0E+00,  2.0E+00,  5.0E+00, &
    10.0E+00, 50.0E+00,  1.0E+00,  2.0E+00, &
     5.0E+00, 10.0E+00, 50.0E+00,  1.0E+00, &
     2.0E+00,  5.0E+00, 10.0E+00, 50.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    nu = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  nu = nvec(n)
  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine besj ( x, alpha, n, y, nz )
!
!*******************************************************************************
!
!! BESJ computes a sequence of J Bessel functions.
!
!     written by d.e. amos, s.l. daniel and m.k. weston, january, 1975.
!
!     references
!         sand-75-0147
!
!         cdc 6600 subroutines ibess and jbess for Bessel functions
!         i(nu,x) and j(nu,x), x >= 0, nu >= 0  by d.e. amos, s.l.
!         daniel, m.k. weston. acm trans math software,3,pp 76-92
!         (1977)
!
!         tables of Bessel functions of moderate or large orders,
!         npl mathematical tables, vol. 6, by f.w.j. olver, her
!         majesty-s stationery office, london, 1962.
!
!     abstract
!         besj computes an n member sequence of j Bessel functions
!         j/sub(alpha+k-1)/(x), k=1,...,n for non-negative alpha and x.
!         a combination of the power series, the asymptotic expansion
!         for x to infinity and the uniform asymptotic expansion for
!         nu to infinity are applied over subdivisions of the (nu,x)
!         plane. for values of (nu,x) not covered by one of these
!         formulae, the order is incremented or decremented by integer
!         values into a region where one of the formulae apply. backward
!         recursion is applied to reduce orders by integer values except
!         where the entire sequence lies in the oscillatory region. in
!         this case forward recursion is stable and values from the
!         asymptotic expansion for x to infinity start the recursion
!         when it is efficient to do so. leading terms of the series and
!         uniform expansion are tested for underflow. if a sequence is
!         requested and the last member would underflow, the result is
!         set to zero and the next lower order tried, etc., until a
!         member comes on scale or all members are set to zero. overflow
!         cannot occur.
!
!         besj calls asjy, jairy, gamln, and ipmpar
!
!     description of arguments
!
!         input
!           x      - x >= 0.0e0
!           alpha  - order of first member of the sequence,
!                    alpha >= 0.0e0
!           n      - number of members in the sequence, n >= 1
!
!         output
!           y      - a vector whose first n components contain
!                    values for j/sub(alpha+k-1)/(x), k=1,...,n
!           nz     - error indicator
!                    nz=0      normal return - computation completed
!                    nz=-1     x is less than 0.0
!                    nz=-2     alpha is less than 0.0
!                    nz=-3     n is less than 1
!                    nz > 0   last nz components of y set to 0.0
!                              because of underflow
!
!     error conditions
!         improper input arguments - a fatal error
!         underflow  - a non-fatal error (nz > 0)
!
  external jairy
  integer i,ialp,idalp,iflw,in,inlim,is,i1,i2,k,kk,km,kt,n,nn, &
          ns,nz
  integer ipmpar
  real       ak,akm,alpha,ans,ap,arg,coef,dalpha,dfn,dtm,earg, &
             elim,etx,fidal,flgjy,fn,fnf,fni,fnp1,fnu,fnulim, &
             gln,pdf,pidt,pp,rden,relb,rttp,rtwo,rtx,rzden, &
             s,sa,sb,sxo2,s1,s2,t,ta,tau,tb,temp,tfn,tm,tol, &
             tolln,trx,tx,t1,t2,wk,x,xo2,xo2l,y
  real gamln
  dimension y(n), temp(3), fnulim(2), pp(4), wk(7)
  data rtwo,pdf,rttp,pidt                    / 1.34839972492648e+00, &
   7.85398163397448e-01, 7.97884560802865e-01, 1.57079632679490e+00/
  data  pp(1),  pp(2),  pp(3),  pp(4)        / 8.72909153935547e+00, &
   2.65693932265030e-01, 1.24578576865586e-01, 7.70133747430388e-04/
  data inlim           /      150            /
  data fnulim(1), fnulim(2) /      100.0e0,     60.0e0     /
!     -------------------
!     ipmpar(8) replaces ipmpar(5) in a double precision code
!     ipmpar(9) replaces ipmpar(6) in a double precision code
!
!     definition of the tolerances tol and elim
!
  tb = ipmpar(4)
  ta = epsilon ( ta ) / tb
  if (tb == 2.0e0) go to 1
  if (tb == 8.0e0) go to 2
  if (tb == 16.0e0) go to 3
  tb = alog(tb)
  go to 5
1 tb = .69315e0
  go to 5
2 tb = 2.07944e0
  go to 5
3 tb = 2.77259e0
!
5 tol = max ( ta,1.e-15)
  i1 = ipmpar(5)
  i2 = ipmpar(6)
!     ln(10**3) = 6.90776
  elim = real(-i2)*tb - 6.90776e0
!     tolln = -ln(tol)
  tolln = real(i1)*tb
  tolln = amin1(tolln,34.5388e0)
!
!
!
  nz = 0
  kt = 1
  if (n-1) 720, 10, 20
   10 kt = 2
   20 nn = n
  if (x) 730, 30, 80
   30 if (alpha) 710, 40, 50
   40 y(1) = 1.0e0
  if (n == 1) return
  i1 = 2
  go to 60
   50 i1 = 1
   60 do 70 i=i1,n
    y(i) = 0.0e0
   70 continue
  return
   80 continue
  if (alpha < 0.0e0) go to 710
!
  ialp = int(alpha)
  fni = real(ialp+n-1)
  fnf = alpha - real(ialp)
  dfn = fni + fnf
  fnu = dfn
  xo2 = x*0.5e0
  sxo2 = xo2*xo2
!
!     decision tree for region where series, asymptotic expansion for x
!     to infinity and asymptotic expansion for nu to infinity are
!     applied.
!
  if (sxo2 <= (fnu+1.0e0)) go to 90
  ta = max ( 20.0e0,fnu)
  if (x > ta) go to 120
  if (x > 12.0e0) go to 110
  xo2l = alog(xo2)
  ns = int(sxo2-fnu) + 1
  go to 100
   90 fn = fnu
  fnp1 = fn + 1.0e0
  xo2l = alog(xo2)
  is = kt
  if (x <= 0.50e0) go to 330
  ns = 0
  100 fni = fni + real(ns)
  dfn = fni + fnf
  fn = dfn
  fnp1 = fn + 1.0e0
  is = kt
  if (n-1+ns > 0) is = 3
  go to 330
  110 ans = max ( 36.0e0-fnu,0.0e0)
  ns = int(ans)
  fni = fni + real(ns)
  dfn = fni + fnf
  fn = dfn
  is = kt
  if (n-1+ns > 0) is = 3
  go to 130
  120 continue
  rtx = sqrt(x)
  tau = rtwo*rtx
  ta = tau + fnulim(kt)
  if (fnu <= ta) go to 480
  fn = fnu
  is = kt
!
!     uniform asymptotic expansion for nu to infinity
!
  130 continue
  i1 = iabs(3-is)
  i1 = max (i1,1)
  flgjy = 1.0e0
  call asjy(jairy,x,fn,flgjy,i1,tol,elim,temp(is),wk,iflw)
  if(iflw/=0) go to 380
  go to (320, 450, 620), is
  310 temp(1) = temp(3)
  kt = 1
  320 is = 2
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if(i1 == 2) go to 450
  go to 130
!
!     series for (x/2)**2 <= nu+1
!
  330 continue
  gln = gamln(fnp1)
  arg = fn*xo2l - gln
  if (arg < (-elim)) go to 400
  earg = exp(arg)
  340 continue
  s = 1.0e0
  if (x < tol) go to 360
  ak = 3.0e0
  t2 = 1.0e0
  t = 1.0e0
  s1 = fn
  do 350 k=1,17
    s2 = t2 + s1
    t = -t*sxo2/s2
    s = s + t
    if (abs(t) < tol) go to 360
    t2 = t2 + ak
    ak = ak + 2.0e0
    s1 = s1 + fn
  350 continue
  360 continue
  temp(is) = s*earg
  go to (370, 450, 610), is
  370 earg = earg*fn/xo2
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  is = 2
  go to 340
!
!     set underflow value and update parameters
!
  380 y(nn) = 0.0e0
  nn = nn - 1
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if (nn-1) 440, 390, 130
  390 kt = 2
  is = 2
  go to 130
  400 y(nn) = 0.0e0
  nn = nn - 1
  fnp1 = fn
  fni = fni - 1.0e0
  dfn = fni + fnf
  fn = dfn
  if (nn-1) 440, 410, 420
  410 kt = 2
  is = 2
  420 if (sxo2 <= fnp1) go to 430
  go to 130
  430 arg = arg - xo2l + alog(fnp1)
  if (arg < (-elim)) go to 400
  go to 330
  440 nz = n - nn
  return
!
!     backward recursion section
!
  450 continue
  nz = n - nn
  if (kt == 2) go to 470
!     backward recur from index alpha+nn-1 to alpha
  y(nn) = temp(1)
  y(nn-1) = temp(2)
  if (nn == 2) return
  trx = 2.0e0/x
  dtm = fni
  tm = (dtm+fnf)*trx
  k = nn + 1
  do 460 i=3,nn
    k = k - 1
    y(k-2) = tm*y(k-1) - y(k)
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
  460 continue
  return
  470 y(1) = temp(2)
  return
!
!     asymptotic expansion for x to infinity with forward recursion in
!     oscillatory region x > max(20, nu), provided the last member
!     of the sequence is also in the region.
!
  480 continue
  in = int(alpha-tau+2.0e0)
  if (in <= 0) go to 490
  idalp = ialp - in - 1
  kt = 1
  go to 500
  490 continue
  idalp = ialp
  in = 0
  500 is = kt
  fidal = real(idalp)
  dalpha = fidal + fnf
  arg = x - pidt*dalpha - pdf
  sa = sin(arg)
  sb = cos(arg)
  coef = rttp/rtx
  etx = 8.0e0*x
  510 continue
  dtm = fidal + fidal
  dtm = dtm*dtm
  tm = 0.0e0
  if (fidal == 0.0e0 .and. abs(fnf) < tol) go to 520
  tm = 4.0e0*fnf*(fidal+fidal+fnf)
  520 continue
  trx = dtm - 1.0e0
  t2 = (trx+tm)/etx
  s2 = t2
  relb = tol*abs(t2)
  t1 = etx
  s1 = 1.0e0
  fn = 1.0e0
  ak = 8.0e0
  do 530 k=1,13
    t1 = t1 + etx
    fn = fn + ak
    trx = dtm - fn
    ap = trx + tm
    t2 = -t2*ap/t1
    s1 = s1 + t2
    t1 = t1 + etx
    ak = ak + 8.0e0
    fn = fn + ak
    trx = dtm - fn
    ap = trx + tm
    t2 = t2*ap/t1
    s2 = s2 + t2
    if (abs(t2) <= relb) go to 540
    ak = ak + 8.0e0
  530 continue
  540 temp(is) = coef*(s1*sb-s2*sa)
  if(is == 2) go to 560
  550 fidal = fidal + 1.0e0
  dalpha = fidal + fnf
  is = 2
  tb = sa
  sa = -sb
  sb = tb
  go to 510
!
!     forward recursion section
!
  560 if (kt == 2) go to 470
  s1 = temp(1)
  s2 = temp(2)
  tx = 2.0e0/x
  tm = dalpha*tx
  if (in == 0) go to 580
!
!     forward recur to index alpha
!
  do 570 i=1,in
    s = s2
    s2 = tm*s2 - s1
    tm = tm + tx
    s1 = s
  570 continue
  if (nn == 1) go to 600
  s = s2
  s2 = tm*s2 - s1
  tm = tm + tx
  s1 = s
  580 continue
!
!     forward recur from index alpha to alpha+n-1
!
  y(1) = s1
  y(2) = s2
  if (nn == 2) return
  do 590 i=3,nn
    y(i) = tm*y(i-1) - y(i-2)
    tm = tm + tx
  590 continue
  return
  600 y(1) = s2
  return
!
!     backward recursion with normalization by
!     asymptotic expansion for nu to infinity or power series.
!
  610 continue
!     computation of last order for series normalization
  akm = max ( 3.0e0-fn,0.0e0)
  km = int(akm)
  tfn = fn + real(km)
  ta = (gln+tfn-0.9189385332e0-0.0833333333e0/tfn)/(tfn+0.5e0)
  ta = xo2l - ta
  tb = -(1.0e0-1.5e0/tfn)/tfn
  akm = tolln/(-ta+sqrt(ta*ta-tolln*tb)) + 1.5e0
  in = km + int(akm)
  go to 660
  620 continue
!     computation of last order for asymptotic expansion normalization
  gln = wk(3) + wk(2)
  if (wk(6) > 30.0e0) go to 640
  rden = (pp(4)*wk(6)+pp(3))*wk(6) + 1.0e0
  rzden = pp(1) + pp(2)*wk(6)
  ta = rzden/rden
  if (wk(1) < 0.10e0) go to 630
  tb = gln/wk(5)
  go to 650
  630 tb=(1.259921049e0+(0.1679894730e0+0.0887944358e0*wk(1))*wk(1)) &
   /wk(7)
  go to 650
  640 continue
  ta = 0.5e0*tolln/wk(4)
  ta=((0.0493827160e0*ta-0.1111111111e0)*ta+0.6666666667e0)*ta*wk(6)
  if (wk(1) < 0.10e0) go to 630
  tb = gln/wk(5)
  650 in = int(ta/tb+1.5e0)
  if (in > inlim) go to 310
  660 continue
  dtm = fni + real(in)
  trx = 2.0e0/x
  tm = (dtm+fnf)*trx
  ta = 0.0e0
  tb = tol
  kk = 1
  670 continue
!
!     backward recur unindexed
!
  do 680 i=1,in
    s = tb
    tb = tm*tb - ta
    ta = s
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
  680 continue
!     normalization
  if (kk/=1) go to 690
  ta = (ta/tb)*temp(3)
  tb = temp(3)
  kk = 2
  in = ns
  if (ns/=0) go to 670
  690 y(nn) = tb
  nz = n - nn
  if (nn == 1) return
  k = nn - 1
  y(k) = tm*tb - ta
  if (nn == 2) return
  dtm = dtm - 1.0e0
  tm = (dtm+fnf)*trx
  km = k - 1
!
!     backward recur indexed
!
  do 700 i=1,km
    y(k-1) = tm*y(k) - y(k+1)
    dtm = dtm - 1.0e0
    tm = (dtm+fnf)*trx
    k = k - 1
  700 continue
  return
!
!
!
  710 continue
  nz = -2
  return
  720 continue
  nz = -3
  return
  730 continue
  nz = -1
  return
end
subroutine besj0_values ( n, x, fx )
!
!*******************************************************************************
!
!! BESJ0_VALUES returns some values of the J0 Bessel function for testing.
!
!
!  Modified:
!
!    15 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 21
!
  real, save, dimension ( nmax ) :: bvec = (/ &
    -0.1775968E+00, -0.3971498E+00, -0.2600520E+00,  0.2238908E+00, &
     0.7651976E+00,  1.0000000E+00,  0.7651977E+00,  0.2238908E+00, &
    -0.2600520E+00, -0.3971498E+00, -0.1775968E+00,  0.1506453E+00, &
     0.3000793E+00,  0.1716508E+00, -0.0903336E+00, -0.2459358E+00, &
    -0.1711903E+00,  0.0476893E+00,  0.2069261E+00,  0.1710735E+00, &
    -0.0142245E+00 /)
  real fx
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    -5.0E+00, -4.0E+00, -3.0E+00, -2.0E+00, &
    -1.0E+00,  0.0E+00,  1.0E+00,  2.0E+00, &
     3.0E+00,  4.0E+00,  5.0E+00,  6.0E+00, &
     7.0E+00,  8.0E+00,  9.0E+00, 10.0E+00, &
    11.0E+00, 12.0E+00, 13.0E+00, 14.0E+00, &
    15.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = bvec(n)

  return
end
subroutine besj1_values ( n, x, fx )
!
!*******************************************************************************
!
!! BESJ1_VALUES returns some values of the J1 Bessel function for testing.
!
!
!  Modified:
!
!    15 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 21
!
  real, save, dimension ( nmax ) :: bvec = (/ &
    0.3275791E+00,  0.0660433E+00, -0.3390590E+00, -0.5767248E+00, &
   -0.4400506E+00,  0.0000000E+00,  0.4400506E+00,  0.5767248E+00, &
    0.3390590E+00, -0.0660433E+00, -0.3275791E+00, -0.2766839E+00, &
   -0.0046828E+00,  0.2346364E+00,  0.2453118E+00,  0.0434728E+00, &
   -0.1767853E+00, -0.2234471E+00, -0.0703181E+00,  0.1333752E+00, &
    0.2051040E+00 /)
  real fx
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    -5.0E+00, -4.0E+00, -3.0E+00, -2.0E+00, &
    -1.0E+00,  0.0E+00,  1.0E+00,  2.0E+00, &
     3.0E+00,  4.0E+00,  5.0E+00,  6.0E+00, &
     7.0E+00,  8.0E+00,  9.0E+00, 10.0E+00, &
    11.0E+00, 12.0E+00, 13.0E+00, 14.0E+00, &
    15.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = bvec(n)

  return
end
subroutine besjn_values ( n, nu, x, fx )
!
!*******************************************************************************
!
!! BESJN_VALUES returns some values of the JN Bessel function for testing.
!
!
!  Modified:
!
!    16 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, integer NU, the order of the function.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real, save, dimension ( nmax ) :: bvec = (/ &
     1.149034849E-01, 3.528340286E-01, 4.656511628E-02, 2.546303137E-01, &
    -5.971280079E-02, 2.497577302E-04, 7.039629756E-03, 2.611405461E-01, &
    -2.340615282E-01,-8.140024770E-02, 2.630615124E-10, 2.515386283E-07, &
     1.467802647E-03, 2.074861066E-01,-1.138478491E-01, 3.873503009E-25, &
     3.918972805E-19, 2.770330052E-11, 1.151336925E-05,-1.167043528E-01 /)
  real fx
  integer n
  integer nu
  real, save, dimension ( nmax ) :: nvec = (/ &
     2,  2,  2,  2, &
     2,  5,  5,  5, &
     5,  5, 10, 10, &
    10, 10, 10, 20, &
    20, 20, 20, 20 /)
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     1.0E+00,  2.0E+00,  5.0E+00, 10.0E+00, &
    50.0E+00,  1.0E+00,  2.0E+00,  5.0E+00, &
    10.0E+00, 50.0E+00,  1.0E+00,  2.0E+00, &
     5.0E+00, 10.0E+00, 50.0E+00,  1.0E+00, &  
     2.0E+00,  5.0E+00, 10.0E+00, 50.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    nu = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  nu = nvec(n)
  x = xvec(n)
  fx = bvec(n)

  return
end
function beta ( x, y )
!
!*******************************************************************************
!
!! BETA computes the Beta function.
!
!
!  Discussion:
!
!    The Beta function is defined as
!
!      BETA ( X, Y ) = GAMMA ( X ) * GAMMA ( Y ) / GAMMA ( X + Y ).
!
!  Modified:
!
!    19 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real X, Y, the arguments.
!
!    Output, real BETA, the value of the Beta function.
!
  real beta
  real betaln
  real x
  real y
!
  beta = exp ( betaln ( x, y ) )

  return
end
subroutine beta_inc_values ( n, a, b, x, fx )
!
!*******************************************************************************
!
!! BETA_INC_VALUES returns some values of the incomplete Beta function.
!
!
!  Discussion:
!
!    The incomplete Beta function may be written
!
!      BETA_INC(A,B,X) = Integral ( 0 <= T <= X ) 
!        T**(A-1) * (1-T)**(B-1) dT / BETA(A,B)
!
!    Thus,
!
!      BETA_INC(A,B,0.0) = 0.0
!      BETA_INC(A,B,1.0) = 1.0
!
!  Modified:
!
!    09 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real A, B, X, the arguments of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real a
  real, save, dimension ( nmax ) :: avec = (/ &
     0.5E+00,  0.5E+00,  0.5E+00,  1.0E+00, &
     1.0E+00,  1.0E+00,  1.0E+00,  5.0E+00, &
    10.0E+00, 10.0E+00, 10.0E+00, 10.0E+00, &
    20.0E+00, 20.0E+00, 20.0E+00, 20.0E+00, &
    20.0E+00, 30.0E+00, 30.0E+00, 40.0E+00 /)
  real b
  real, save, dimension ( nmax ) :: bvec = (/ &
     0.5E+00,  0.5E+00,  0.5E+00,  0.5E+00, &
     0.5E+00,  0.5E+00,  1.0E+00,  5.0E+00, &
     0.5E+00,  5.0E+00,  5.0E+00, 10.0E+00, &
     5.0E+00, 10.0E+00, 10.0E+00, 20.0E+00, &
    20.0E+00, 10.0E+00, 10.0E+00, 20.0E+00 /)
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.0637686E+00, 0.2048328E+00, 1.0000000E+00, 0.0050126E+00, &
    0.0513167E+00, 1.0000000E+00, 0.5000000E+00, 0.5000000E+00, &
    0.1516409E+00, 0.0897827E+00, 1.0000000E+00, 0.5000000E+00, &
    0.4598773E+00, 0.2146816E+00, 0.9507365E+00, 0.5000000E+00, &
    0.8979414E+00, 0.2241297E+00, 0.7586405E+00, 0.7001783E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.01E+00, 0.10E+00, 1.00E+00, 0.01E+00, &
    0.10E+00, 1.00E+00, 0.50E+00, 0.50E+00, &
    0.90E+00, 0.50E+00, 1.00E+00, 0.50E+00, &
    0.80E+00, 0.60E+00, 0.80E+00, 0.50E+00, &
    0.60E+00, 0.70E+00, 0.80E+00, 0.70E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    a = 0.0E+00
    b = 0.0E+00
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  a = avec(n)
  b = bvec(n)
  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine beta_values ( n, x, y, fxy )
!
!*******************************************************************************
!
!! BETA_VALUES returns some values of the Beta function for testing.
!
!
!  Modified:
!
!    18 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, Y, the arguments of the function.
!
!    Output, real FXY, the value of the function.
!
  integer, parameter :: nmax = 17
!
  real, save, dimension ( nmax ) :: fxvec = (/ &
    5.000000E+00, 2.500000E+00, 1.666667E+00, 1.250000E+00, &
    5.000000E+00, 2.500000E+00, 1.000000E+00, 1.666667E-01, &
    0.333333E-01, 7.142857E-03, 1.587302E-03, 0.238095E-01, &
    5.952381E-03, 1.984127E-03, 7.936508E-04, 3.607504E-04, &
    8.325008E-05 /)
  real fxy
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.2E+00, 0.4E+00, 0.6E+00, 0.8E+00, &
    1.0E+00, 1.0E+00, 1.0E+00, 2.0E+00, &
    3.0E+00, 4.0E+00, 5.0E+00, 6.0E+00, &
    6.0E+00, 6.0E+00, 6.0E+00, 6.0E+00, &
    7.0E+00 /)
  real y
  real, save, dimension ( nmax ) :: yvec = (/ &
    1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00, &
    0.2E+00, 0.4E+00, 1.0E+00, 2.0E+00, &
    3.0E+00, 4.0E+00, 5.0E+00, 2.0E+00, &
    3.0E+00, 4.0E+00, 5.0E+00, 6.0E+00, &
    7.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    y = 0.0E+00
    fxy = 0.0E+00
    return
  end if

  x = xvec(n)
  y = yvec(n)
  fxy = fxvec(n)

  return
end
function betaln ( x, y )
!
!*******************************************************************************
!
!! BETALN evaluates the logarithm of the beta function
!
!
!  Discussion:
!
!    The Beta function is defined as
!
!      BETA ( X, Y ) = GAMMA ( X ) * GAMMA ( Y ) / GAMMA ( X + Y ).
!
!  Modified:
!
!    19 May 2001
!
!  Parameters:
!
!    Input, real X, Y, the arguments.
!
!    Output, real BETALN, the logarithm of the Beta function.
!
  real a
  real b
  real betaln 
  real, parameter :: e = 0.918938533204673E+00
  integer i
  real x
  real y
!
  a = min ( x, y )
  b = max ( x, y )

  if ( a >= 8.0) go to 60
  if ( a >= 1.0) go to 20
!
!                   procedure when a < 1
!
  if ( b < 8.0 ) then
     betaln = gamln(a) + (gamln(b) - gamln(a + b))
  else
    betaln = gamln(a) + algdiv(a,b)
  end if

  return
!
!                procedure when 1 <= a < 8
!
   20 if (a > 2.0) go to 30
  if (b > 2.0) go to 21
     betaln = gamln(a) + gamln(b) - gsumln(a,b)
     return
   21 w = 0.0
  if (b < 8.0) go to 40
     betaln = gamln(a) + algdiv(a,b)
     return
!
!                reduction of a when b <= 1000
!
   30 continue

  if (b > 1000.0) go to 50
  n = a - 1.0
  w = 1.0
  do i = 1,n
     a = a - 1.0
     h = a/b
     w = w * (h/(1.0 + h))
  end do
  w = alog(w)
  if (b < 8.0) go to 40
  betaln = w + gamln(a) + algdiv(a,b)
  return
!
!                 reduction of b when b < 8
!
40 continue

  n = b - 1.0
  z = 1.0
  do i = 1,n
     b = b - 1.0
     z = z * (b/(a + b))
  end do
  betaln = w + alog(z) + (gamln(a) + (gamln(b) - gsumln(a,b)))
  return
!
!                reduction of a when b > 1000
!
   50 continue

  n = a - 1.0
  w = 1.0
  do i = 1,n
     a = a - 1.0
     w = w * (a/(1.0 + a/b))
  end do
  betaln = (alog(w) - n*alog(b)) + (gamln(a) + algdiv(a,b))
  return
!
!                   procedure when a >= 8
!
60 continue

  w = bcorr(a,b)
  h = a/b
  c = h/(1.0 + h)
  u = -(a - 0.5)*alog(c)
  v = b*alnrel(h)

  if (u > v) then
    betaln = (((-0.5*alog(b) + e) + w) - v) - u
  else
    betaln = (((-0.5*alog(b) + e) + w) - u) - v
  end if

  return
end
function bfrac(a, b, x, y, lambda, eps)
!
!*******************************************************************************
!
!! BFRAC continued fraction expansion for ix(a,b) when a,b > 1.
!
!     it is assumed that  lambda = (a + b)*y - b.
!
  real bfrac
  real brcomp
  real c
  real c0
  real c1
  real lambda
  real n
!
  bfrac = brcomp(a,b,x,y)

  if ( bfrac == 0.0 ) then
    return
  end if

  c = 1.0 + lambda
  c0 = b/a
  c1 = 1.0 + 1.0/a
  yp1 = y + 1.0
!
  n = 0.0
  p = 1.0
  s = a + 1.0
  an = 0.0
  bn = 1.0
  anp1 = 1.0
  bnp1 = c/c1
  r = c1/c
!
!        continued fraction calculation
!
   10    n = n + 1.0
     t = n/a
     w = n*(b - n)*x
     e = a/s
     alpha = (p*(p + c0)*e*e)*(w*x)
     e = (1.0 + t)/(c1 + t + t)
     beta = n + w/s + e*(c + n*yp1)
     p = 1.0 + t
     s = s + 2.0
!
!        update an, bn, anp1, and bnp1
!
     t = alpha*an + beta*anp1
     an = anp1
     anp1 = t
     t = alpha*bn + beta*bnp1
     bn = bnp1
     bnp1 = t
!
     r0 = r
     r = anp1/bnp1
     if (abs(r - r0) <= eps*r) go to 20
!
!        rescale an, bn, anp1, and bnp1
!
     an = an/bnp1
     bn = bn/bnp1
     anp1 = r
     bnp1 = 1.0
     go to 10
!
!                 termination
!
   20 bfrac = bfrac*r
  return
end
subroutine bgrat(a, b, x, y, w, eps, ierr)
!
!*******************************************************************************
!
!! BGRAT asymptotic expansion for ix(a,b) when a is larger than b.
!     the result of the expansion is added to w. it is assumed
!     that a >= 15 and b <= 1.  eps is the tolerance used.
!     ierr is a variable that reports the status of the results.
!
  real j, l, lnx, nu, n2
  real c(30), d(30)
!
  bm1 = (b - 0.5) - 0.5
  nu = a + 0.5*bm1
  if (y > 0.375) go to 10
     lnx = alnrel(-y)
     go to 11
   10 lnx = alog(x)
   11 z = -nu*lnx
  if (b*z == 0.0) go to 100
!
!                 computation of the expansion
!                 set r = exp(-z)*z**b/gamma(b)
!
  r = b*(1.0 + gam1(b))*exp(b*alog(z))
  r = r*exp(a*lnx)*exp(0.5*bm1*lnx)
  u = algdiv(b,a) + b*alog(nu)
  u = r*exp(-u)
  if (u == 0.0) go to 100
  call grat1(b,z,r,p,q,eps)
!
  v = 0.25*(1.0/nu)**2
  t2 = 0.25*lnx*lnx
  l = w/u
  j = q/r
  sum = j
  t = 1.0
  cn = 1.0
  n2 = 0.0
  do 22 n = 1,30
     bp2n = b + n2
     j = (bp2n*(bp2n + 1.0)*j + (z + bp2n + 1.0)*t)*v
     n2 = n2 + 2.0
     t = t*t2
     cn = cn/(n2*(n2 + 1.0))
     c(n) = cn
     s = 0.0
     if (n == 1) go to 21
        nm1 = n - 1
        coef = b - n
        do 20 i = 1,nm1
           s = s + coef*c(i)*d(n-i)
   20          coef = coef + b
   21    d(n) = bm1*cn + s/n
     dj = d(n)*j
     sum = sum + dj
     if (sum <= 0.0) go to 100
     if (abs(dj) <= eps*(sum + l)) go to 30
   22 continue
!
!                    add the results to w
!
   30 ierr = 0
  w = w + u*sum
  return
!
!               the expansion cannot be computed
!
  100 ierr = 1
  return
end
function bi ( x )
!
!*******************************************************************************
!
!! BI evaluation of the Airy function BI(X).
!
!
!     note... if x is a positive number where bi(x) is too large
!     to be computed, then bi(x) is set to 0.
!
!     x0 = 16**(2/3)
!     c = exp(2/3)
!
  real bi
  real x
!
  data x0/6.3496042078728/
  data c /1.94773404105468/
!
  data an0/ .614926627446001e+00/, an1/ .462726943978834e+00/, &
       an2/ .867811386408974e-02/, an3/ .974670609357959e-01/, &
       an4/ .370856545413908e-01/, an5/ .569193415071716e-03/, &
       an6/ .269172131237236e-02/, an7/ .746473849872868e-03/, &
       an8/ .105638036899269e-04/, an9/ .242726195973978e-04/, &
       an10/.557260250681542e-05/
  data ad0/ .100000000000000e+01/, ad1/ .234801779278695e-01/, &
       ad2/-.300487317759152e-02/, ad3/-.597414466459612e-02/
!-----------------------
  data bn0/ .614926627446001e+00/, bn1/ .548653374523520e+00/, &
       bn2/ .582684047163842e-01/, bn3/ .871954925712688e-01/, &
       bn4/ .508547058449004e-01/, bn5/ .361412623711710e-02/, &
       bn6/ .177269722794511e-02/, bn7/ .117774184027185e-02/, &
       bn8/ .627004834186143e-04/, bn9/ .774782269814080e-06/, &
       bn10/.118116474369315e-04/
  data bd0/ .100000000000000e+01/, bd1/ .163214622184402e+00/, &
       bd2/-.242285981710408e-01/, bd3/-.720554280297616e-02/
!-----------------------
  data pn0/.619911943572678e+00/, pn1/.100411558489626e+01/, &
       pn2/.563659963795768e+00/, pn3/.274925508033015e+00/, &
       pn4/.115641822943246e+00/, pn5/.120048517441127e-01/, &
       pn6/.501838091254330e-02/
  data pd0/.100000000000000e+01/, pd1/.159751878026937e+01/, &
       pd2/.104664867034140e+01/, pd3/.512560333664022e+00/, &
       pd4/.159144727666995e+00/, pd5/.394456748956258e-01/, &
       pd6/.529926873250079e-02/, pd7/.288921845412576e-03/
!-----------------------
  data qn0/.595123543430856e+00/, qn1/.652692120245803e+00/, &
       qn2/.436851872835894e+00/, qn3/.201626141057807e+00/, &
       qn4/.649535170626944e-01/, qn5/.171798867787816e-01/, &
       qn6/.287998748038892e-02/, qn7/.359634362348937e-03/
  data qd0/.100000000000000e+01/, qd1/.114259871204893e+01/, &
       qd2/.766390439057101e+00/, qd3/.348287281255683e+00/, &
       qd4/.117049276946157e+00/, qd5/.294545450289541e-01/, &
       qd6/.523951773968125e-02/, qd7/.622692248774973e-03/, &
       qd8/.674811395957744e-06/
!-----------------------
  data rn0 / .568067636505865e+00/, rn1 / .462183136291541e-01/, &
       rn2 / .268519638203645e+00/, rn3 / .199427104235673e-02/, &
       rn4 / .135599161332010e-03/, rn5 / .229937707171804e-04/, &
       rn6 / .697888081361175e-05/, rn7 / .153277172934286e-05/, &
       rn8 /-.149322381877245e-05/, rn9 /-.113533571972859e-05/, &
       rn10/ .740721412702102e-06/, rn11/-.120160431596119e-06/
  data rd0 / .100000000000000e+01/, rd1 / .741293424676788e-01/, &
       rd2 / .471695968238457e+00/
!-----------------------
  data sn0 /.564189583547757e+00/, sn1 / .112605519585866e+00/, &
       sn2 /.893329124921909e-03/, sn3 / .532139134120350e-04/, &
       sn4 /.592725458717738e-05/, sn5 / .921448923850546e-06/, &
       sn6 /.404558310611815e-06/, sn7 /-.660517686759109e-06/, &
       sn8 /.174667472383815e-05/, sn9 /-.287037710548882e-05/, &
       sn10/.322304072982791e-05/, sn11/-.231569499551950e-05/, &
       sn12/.963478964685941e-06/, sn13/-.173784488565533e-06/
  data sd0 /.100000000000000e+01/, sd1 / .193077670156841e+00/
!-----------------------------------------------------------------------
  if (x >= -1.0) go to 10
  call aimp (-x, r, phi)
  bi = r*cos(phi)
  return
!
   10 if (x >= 0.0) go to 20
  bi = ((((((((((an10*x + an9)*x + an8)*x + an7)*x &
               + an6)*x + an5)*x + an4)*x + an3)*x &
               + an2)*x + an1)*x + an0) / &
               (((ad3*x + ad2)*x + ad1)*x + ad0)
  return
!
   20 if (x > 1.0) go to 30
  bi = ((((((((((bn10*x + bn9)*x + bn8)*x + bn7)*x &
               + bn6)*x + bn5)*x + bn4)*x + bn3)*x &
               + bn2)*x + bn1)*x + bn0) / &
               (((bd3*x + bd2)*x + bd1)*x + bd0)
  return
!
   30 rtx = sqrt(x)
  if (x > 2.0) go to 40
  t = x - 1.0
  w = ((((((pn6*t + pn5)*t + pn4)*t + pn3)*t + pn2)*t &
                  + pn1)*t + pn0) / &
      (((((((pd7*t + pd6)*t + pd5)*t + pd4)*t + pd3)*t &
                   + pd2)*t + pd1)*t + pd0)
  bi = (w/sqrt(rtx)) * exp(2.0*x*rtx/3.0)
  return
!
   40 if (x > 4.0) go to 50
  t = x - 2.0
  w = (((((((qn7*t + qn6)*t + qn5)*t + qn4)*t + qn3)*t &
                   + qn2)*t + qn1)*t + qn0) / &
      ((((((((qd8*t + qd7)*t + qd6)*t + qd5)*t + qd4)*t &
                    + qd3)*t + qd2)*t + qd1)*t + qd0)
  bi = (w/sqrt(rtx)) * exp(2.0*x*rtx/3.0)
  return
!
   50 if (x > x0) go to 60
  t = 16.0/(x*rtx) - 1.0
  w = (((((((((((rn11*t + rn10)*t + rn9)*t + rn8)*t &
       + rn7)*t + rn6)*t + rn5)*t + rn4)*t + rn3)*t &
       + rn2)*t + rn1)*t + rn0) / &
        ((rd2*t + rd1)*t + rd0)
  bi = (w/sqrt(rtx)) * exp(2.0*x*rtx/3.0)
  return
!
   60 if (x*rtx > 1.5*exparg(0)) go to 70
  t = 16.0/(x*rtx)
  w = (((((((((((((sn13*t + sn12)*t + sn11)*t + sn10)*t &
           + sn9)*t + sn8)*t + sn7)*t + sn6)*t + sn5)*t &
           + sn4)*t + sn3)*t + sn2)*t + sn1)*t + sn0) / &
             (sd1*t + sd0)
  n = rtx
  n2 = n*n
  t = (x - n2)/(rtx + n)
  bi = (w/sqrt(rtx)) * c**(n2*n) * exp(2.0*t*(n*rtx + t*t/3.0))
  return
!
   70 bi = 0.0
  return
end
subroutine bia(ind,z,bi,bip,ierr)
!
!*******************************************************************************
!
!! BIA calculates the airy function bi and its derivative bip for
!     complex argument z by means of asymptotic expansions.
!
  complex z,bi,bip,z1,z2,z2r,zz,w,w2,s1,s2,s3,s4,e,zeta,si,cn, &
          cf1,cf2,ex3c,ex6,ex6c,cln2,alpha,beta,j,cz
  dimension c(30), d(30)
!------------------------
  data c(1)  /.100000000000000e+01/, c(2)  /.694444444444444e-01/, &
       c(3)  /.371334876543210e-01/, c(4)  /.379930591278006e-01/, &
       c(5)  /.576491904126697e-01/, c(6)  /.116099064025515e+00/, &
       c(7)  /.291591399230751e+00/, c(8)  /.877666969510017e+00/, &
       c(9)  /.307945303017317e+01/, c(10) /.123415733323452e+02/, &
       c(11) /.556227853659171e+02/, c(12) /.278465080777603e+03/, &
       c(13) /.153316943201280e+04/, c(14) /.920720659972641e+04/, &
       c(15) /.598925135658791e+05/, c(16) /.419524875116551e+06/, &
       c(17) /.314825741786683e+07/, c(18) /.251989198716024e+08/, &
       c(19) /.214288036963680e+09/, c(20) /.192937554918249e+10/
  data c(21) /.183357669378906e+11/, c(22) /.183418303528833e+12/, &
       c(23) /.192647115897045e+13/, c(24) /.211969993886476e+14/, &
       c(25) /.243826826879716e+15/, c(26) /.292659921929793e+16/, &
       c(27) /.365903070126431e+17/, c(28) /.475768102036307e+18/, &
       c(29) /.642404935790194e+19/, c(30) /.899520742705838e+20/
!------------------------
  data d(1)  / .100000000000000e+01/, d(2)  /-.972222222222222e-01/, &
       d(3)  /-.438850308641975e-01/, d(4)  /-.424628307898948e-01/, &
       d(5)  /-.626621634920323e-01/, d(6)  /-.124105896027275e+00/, &
       d(7)  /-.308253764901079e+00/, d(8)  /-.920479992412945e+00/, &
       d(9)  /-.321049358464862e+01/, d(10) /-.128072930807356e+02/, &
       d(11) /-.575083035139143e+02/, d(12) /-.287033237109221e+03/, &
       d(13) /-.157635730333710e+04/, d(14) /-.944635482309593e+04/, &
       d(15) /-.613357066638521e+05/, d(16) /-.428952400400069e+06/, &
       d(17) /-.321453652140086e+07/, d(18) /-.256979083839113e+08/, &
       d(19) /-.218293420832160e+09/, d(20) /-.196352378899103e+10/
  data d(21) /-.186439310881072e+11/, d(22) /-.186352996385294e+12/, &
       d(23) /-.195588293238984e+13/, d(24) /-.215064446351972e+14/, &
       d(25) /-.247236992290621e+15/, d(26) /-.296588243029521e+16/, &
       d(27) /-.370624400063547e+17/, d(28) /-.481678264794522e+18/, &
       d(29) /-.650098408075106e+19/, d(30) /-.909919826436541e+20/
!-------------------------
!     sqt3 = sqrt(3)
!     ex3c = exp(-i*pi/3)
!     ex6 = exp(i*pi/6)
!     ex6c = exp(-i*pi/6)
!     cln2 = 0.5*i*ln(2)
!     c1 = pi**(-1/2)
!     c2 = (2*pi)**(-1/2)
!     c3 = 2**(-1/2)
!--------------------------
  data sqt3/1.73205080756888/
  data ex3c/(5.e-01, -8.66025403784439e-01)/
  data ex6/(8.66025403784439e-01, 5.e-01)/
  data ex6c/(8.66025403784439e-01, -5.e-01)/
  data cln2/(0.0, 3.46573590279973e-01)/
  data c1/5.64189583547756e-01/
  data c2/3.98942280401433e-01/
  data c3/7.07106781186548e-01/
!--------------------------
!
!     eps and xm are machine dependent constants. eps is the
!     smallest number such that 1.0 + eps > 1.0, xpos is the
!     largest positive number for which exp(xm) can be computed,
!     and xneg is the negative number of largest magnitude for
!     which exp(x) does not underflow.
!
                  eps = epsilon ( eps )
                  xpos = exparg(0)
                  xneg = exparg(1)
!
!------------------------
  ierr = 0
  x = real(z)
  y = aimag(z)
  if (x < abs(y)*sqt3) go to 30
!
!          -----  abs(arg(z)) <= pi/6  ----
!
  z1 = csqrt(z)
  z2 = csqrt(z1)
  z2r = 1.0/z2
  call crec(x, y, u, v)
  w = 1.5*cmplx(u, v)/z1
  u = abs(real(w))
  v = abs(aimag(w))
  t = max ( u, v)
  if (ind /= 0) go to 10
     if (t == 0.0) go to 90
        u1 = u/t
        v1 = v/t
        r = u*u1 + v*v1
        if (u1 >= r*xpos .or. v1 >= 0.1*r/eps) go to 90
           zeta = z1*z/1.5
           e = cexp(zeta)
!
   10 m = 20
  t = max ( x, abs(y))
  if (t > 30.0) m = 8
  s1 = cmplx(c(m), 0.0)
  s2 = cmplx(d(m), 0.0)
  i = m
  do 20 k = 2,m
     i = i - 1
     s1 = c(i) + w*s1
     s2 = d(i) + w*s2
   20 continue
!
  bi = c1*z2r*s1
  bip = c1*z2*s2
  if (ind /= 0) return
     bi = e*bi
     bip = e*bip
     return
   30 if (x < 0.0) go to 50
!
!          ----  pi/6 < abs(arg(z)) <= pi/2  ----
!
  cz = z
  if (y < 0.0) cz = conjg(cz)
  zz = cz*ex3c
  z1 = csqrt(zz)
  z2 = csqrt(z1)
  z2r = 1.0/z2
  cf1 = c1*z2r*ex6
  cf2 = c1*z2*ex6c
  call crec(real(zz), aimag(zz), u, v)
  w = 1.5*cmplx(u, v)/z1
  u = abs(real(w))
  v = abs(aimag(w))
  t = max ( u, v)
!
  if (t == 0.0) go to 90
     u1 = u/t
     v1 = v/t
     r = u*u1 + v*v1
     if (ind /= 0) go to 40
        if (v1 >= r*xpos .or. u1 >= 0.1*r/eps) go to 90
           zeta = z1*zz/1.5
           cn = ccos(zeta - cln2)
           si = csin(zeta - cln2)
           go to 70
!
!        e = exp(-2*i*(zeta - cln2)) if abs(arg(zz)) <= pi/3
!        e = exp( 2*i*(zeta - cln2)) if abs(arg(zz)) > pi/3
!
   40    e = (0.0, 0.0)
     j = (0.0, -1.0)
     s = 1.0
     ce = 1.0
     cf = 0.5
     if (aimag(zz) <= 0.0) go to 44
        s = -1.0
        ce = 0.5
        cf = 2.0
   44    if (v1 >= 0.5*r*abs(xneg)) go to 45
     if (u1 >= 0.05*r/eps) go to 90
     zeta = z1*zz/1.5
     e = cf*cexp(2.0*s*j*zeta)
   45    cn = ce*c3*(1 + e)
     si = ce*s*c3*(1 - e)*j
     go to 70
!
!                  ----  real(z) < 0  ----
!
   50 zz = -z
  if (y < 0.0) zz = conjg(zz)
  z1 = csqrt(zz)
  z2 = csqrt(z1)
  z2r = 1.0/z2
  cf1 = c2*z2r
  cf2 = c2*z2
  call crec(real(zz), aimag(zz), u, v)
  w = 1.5*cmplx(u, v)/z1
  u = abs(real(w))
  v = abs(aimag(w))
  t = max ( u, v)
!
  if (t == 0.0) go to 90
     u1 = u/t
     v1 = v/t
     r = u*u1 + v*v1
     if (ind /= 0) go to 60
        if (v1 >= r*xpos .or. u1 >= 0.1*r/eps) go to 90
           zeta = z1*zz/1.5
           cn = ccos(zeta)
           si = csin(zeta)
           go to 70
   60    e = (0.0, 0.0)
     j = (0.0, -1.0)
     if (v1 >= 0.5*r*abs(xneg)) go to 65
     if (u1 >= 0.05*r/eps) go to 90
     zeta = z1*zz/1.5
     e = cexp(2.0*j*zeta)
   65    cn = 0.5*(1.0 + e)
     si = 0.5*(1.0 - e)*j
!
   70 w2 = w*w
  m = 15
  t = max ( abs(x), abs(y))
  if (t > 30.0) m = 5
     m2 = m + m
     i = m2 - 1
     s1 = cmplx(c(i), 0.0)
     s2 = cmplx(c(m2), 0.0)
     s3 = cmplx(d(i), 0.0)
     s4 = cmplx(d(m2), 0.0)
     do 80 k = 2,m
        i = i - 1
        s2 = c(i) - s2*w2
        s4 = d(i) - s4*w2
        i = i - 1
        s1 = c(i) - s1*w2
        s3 = d(i) - s3*w2
   80    continue
     s2 = w*s2
     s4 = w*s4
     if (x >= 0.0) go to 81
        alpha = s1 + s2
        beta = s2 - s1
        go to 82
   81    alpha = s1 - s2
     beta = s1 + s2
   82    bi = cf1*(alpha*cn + beta*si)
     if (x >= 0.0) go to 83
        alpha = s3 - s4
        beta = s3 + s4
        go to 84
   83    alpha = s3 + s4
     beta = s4 - s3
   84    bip = cf2*(alpha*cn + beta*si)
     if (y >= 0.0) return
     bi = conjg(bi)
     bip = conjg(bip)
     return
!
!            return with zero values if scaling is needed.
!
   90 bi = (0.0, 0.0)
  bip = (0.0, 0.0)
  ierr = 1
  return
end
function bie(x)
!
!*******************************************************************************
!
!! BIE computes the scaled Airy function BI(X).
!
!
!             bie(x) = exp(-zeta)*bi(x)  when x >= 0
!             bie(x) = bi(x)             when x < 0
!
!             zeta = (2/3) * x**(3/2)
!
!-----------------------------------------------------------------------
  real bie
!
!     x0 = 16**(2/3)
!-----------------------
  data x0/6.3496042078728/
!-----------------------
  data an0/ .614926627446001e+00/, an1/ .462726943978834e+00/, &
       an2/ .867811386408974e-02/, an3/ .974670609357959e-01/, &
       an4/ .370856545413908e-01/, an5/ .569193415071716e-03/, &
       an6/ .269172131237236e-02/, an7/ .746473849872868e-03/, &
       an8/ .105638036899269e-04/, an9/ .242726195973978e-04/, &
       an10/.557260250681542e-05/
  data ad0/ .100000000000000e+01/, ad1/ .234801779278695e-01/, &
       ad2/-.300487317759152e-02/, ad3/-.597414466459612e-02/
!-----------------------
  data bn0/ .614926627446001e+00/, bn1/ .548653374523520e+00/, &
       bn2/ .582684047163842e-01/, bn3/ .871954925712688e-01/, &
       bn4/ .508547058449004e-01/, bn5/ .361412623711710e-02/, &
       bn6/ .177269722794511e-02/, bn7/ .117774184027185e-02/, &
       bn8/ .627004834186143e-04/, bn9/ .774782269814080e-06/, &
       bn10/.118116474369315e-04/
  data bd0/ .100000000000000e+01/, bd1/ .163214622184402e+00/, &
       bd2/-.242285981710408e-01/, bd3/-.720554280297616e-02/
!-----------------------
  data pn0/.619911943572678e+00/, pn1/.100411558489626e+01/, &
       pn2/.563659963795768e+00/, pn3/.274925508033015e+00/, &
       pn4/.115641822943246e+00/, pn5/.120048517441127e-01/, &
       pn6/.501838091254330e-02/
  data pd0/.100000000000000e+01/, pd1/.159751878026937e+01/, &
       pd2/.104664867034140e+01/, pd3/.512560333664022e+00/, &
       pd4/.159144727666995e+00/, pd5/.394456748956258e-01/, &
       pd6/.529926873250079e-02/, pd7/.288921845412576e-03/
!-----------------------
  data qn0/.595123543430856e+00/, qn1/.652692120245803e+00/, &
       qn2/.436851872835894e+00/, qn3/.201626141057807e+00/, &
       qn4/.649535170626944e-01/, qn5/.171798867787816e-01/, &
       qn6/.287998748038892e-02/, qn7/.359634362348937e-03/
  data qd0/.100000000000000e+01/, qd1/.114259871204893e+01/, &
       qd2/.766390439057101e+00/, qd3/.348287281255683e+00/, &
       qd4/.117049276946157e+00/, qd5/.294545450289541e-01/, &
       qd6/.523951773968125e-02/, qd7/.622692248774973e-03/, &
       qd8/.674811395957744e-06/
!-----------------------
  data rn0 / .568067636505865e+00/, rn1 / .462183136291541e-01/, &
       rn2 / .268519638203645e+00/, rn3 / .199427104235673e-02/, &
       rn4 / .135599161332010e-03/, rn5 / .229937707171804e-04/, &
       rn6 / .697888081361175e-05/, rn7 / .153277172934286e-05/, &
       rn8 /-.149322381877245e-05/, rn9 /-.113533571972859e-05/, &
       rn10/ .740721412702102e-06/, rn11/-.120160431596119e-06/
  data rd0 / .100000000000000e+01/, rd1 / .741293424676788e-01/, &
       rd2 / .471695968238457e+00/
!-----------------------
  data sn0 /.564189583547757e+00/, sn1 / .112605519585866e+00/, &
       sn2 /.893329124921909e-03/, sn3 / .532139134120350e-04/, &
       sn4 /.592725458717738e-05/, sn5 / .921448923850546e-06/, &
       sn6 /.404558310611815e-06/, sn7 /-.660517686759109e-06/, &
       sn8 /.174667472383815e-05/, sn9 /-.287037710548882e-05/, &
       sn10/.322304072982791e-05/, sn11/-.231569499551950e-05/, &
       sn12/.963478964685941e-06/, sn13/-.173784488565533e-06/
  data sd0 /.100000000000000e+01/, sd1 / .193077670156841e+00/
!-----------------------------------------------------------------------
  if (x >= -1.0) go to 10
  call aimp (-x, r, phi)
  bie = r*cos(phi)
  return
!
   10 if (x >= 0.0) go to 20
  bie = ((((((((((an10*x + an9)*x + an8)*x + an7)*x &
                + an6)*x + an5)*x + an4)*x + an3)*x &
                + an2)*x + an1)*x + an0) / &
                (((ad3*x + ad2)*x + ad1)*x + ad0)
  return
!
   20 if (x > 1.0) go to 30
  bie = ((((((((((bn10*x + bn9)*x + bn8)*x + bn7)*x &
                + bn6)*x + bn5)*x + bn4)*x + bn3)*x &
                + bn2)*x + bn1)*x + bn0) / &
                (((bd3*x + bd2)*x + bd1)*x + bd0)
  if (x > 1.e-20) bie = bie * exp(-2.0*x*sqrt(x)/3.0)
  return
!
   30 rtx = sqrt(x)
  if (x > 2.0) go to 40
  t = x - 1.0
  w = ((((((pn6*t + pn5)*t + pn4)*t + pn3)*t + pn2)*t &
                  + pn1)*t + pn0) / &
      (((((((pd7*t + pd6)*t + pd5)*t + pd4)*t + pd3)*t &
                   + pd2)*t + pd1)*t + pd0)
  bie = w/sqrt(rtx)
  return
!
   40 if (x > 4.0) go to 50
  t = x - 2.0
  w = (((((((qn7*t + qn6)*t + qn5)*t + qn4)*t + qn3)*t &
                   + qn2)*t + qn1)*t + qn0) / &
      ((((((((qd8*t + qd7)*t + qd6)*t + qd5)*t + qd4)*t &
                    + qd3)*t + qd2)*t + qd1)*t + qd0)
  bie = w/sqrt(rtx)
  return
!
   50 if (x > x0) go to 60
  t = 16.0/(x*rtx) - 1.0
  w = (((((((((((rn11*t + rn10)*t + rn9)*t + rn8)*t &
       + rn7)*t + rn6)*t + rn5)*t + rn4)*t + rn3)*t &
       + rn2)*t + rn1)*t + rn0) / &
        ((rd2*t + rd1)*t + rd0)
  bie = w/sqrt(rtx)
  return
!
   60 if (x > 1.e20) go to 70
  t = 16.0/(x*rtx)
  w = (((((((((((((sn13*t + sn12)*t + sn11)*t + sn10)*t &
           + sn9)*t + sn8)*t + sn7)*t + sn6)*t + sn5)*t &
           + sn4)*t + sn3)*t + sn2)*t + sn1)*t + sn0) / &
             (sd1*t + sd0)
  bie = w/sqrt(rtx)
  return
!
   70 bie = sn0/sqrt(rtx)
  return
end
subroutine bii(ind, z, bi, bip, ierr)
!
!*******************************************************************************
!
!! BII calculates the airy function bi and its derivative bip
!     for complex argument z in the intermediate range 1  <= 
!     cabs(z) <= 10.0.
!
  complex z, bi, bip, z1, z2, zm, w1, w2, w1m, w2m, e, e1
!
!     c1 = 1/sqrt(3)
!     sqt3 = sqrt(3)
!
  data c1/5.77350269189626e-01/
  data sqt3/1.73205080756888e+00/
!
  ierr = 0
  x = real(z)
  y = aimag(z)
  r = cpabs(x, y)
  z1 = csqrt(z)
  z2 = z1*z/1.5
  e = cexp(-z2)
  e1 = 1.0/e
  if(real(z) < 0.0) go to 10
!
!               ----  real(z) >= 0  ----
!
  if (r < 8.9) go to 5
  a = 0.156*r - 0.913
  if (abs(y) < a*x .or. abs(y) > 0.58*x) go to 40
5    call ia(z2, w1, w2, w1m, w2m)
     bi = c1*z1*(w1 + w1m)
     bip = c1*z*(w2 + w2m)
     if (ind == 0) return
     go to 20
!
!               ----  real(z) < 0  ----
!
   10 if (r < 8.1) go to 15
  if (abs(y) < 3.89*abs(x)) go to 40
   15    zm = -z
     z1 = csqrt(zm)
     z2 = z1*zm/1.5
     call ja(z2, w1, w2, w1m, w2m)
     bi = c1*z1*(w1m -w1)
     bip = c1*zm*(w2m + w2)
     if (ind == 0) return
   20    if (x >= c1*abs(y)) go to 30
        bi = bi*e1
        bip = bip*e1
        return
   30    bi = bi*e
     bip = bip*e
     return
   40 call bia(ind, z, bi, bip, ierr)
  return
end
subroutine bim ( z, cn, w )
!
!*******************************************************************************
!
!! BIM calculates the modified Bessel function of the first kind
!     for real order cn > -1 and complex argument z by means
!     of the maclaurin expansion.  w is replaced by the
!     calculated value.
!
  real m
  complex z, w, sz, t
!------------------
  anorm(z) = max ( abs(real(z)),abs(aimag(z)))
  eps = epsilon ( eps )
  sz = 0.25*z*z
!
!     initialization of maclaurin expansion
!
  m = 1.0
  t = sz/(cn + 1.0)
  w = t
!
!     summation of maclaurin expansion
!
   10    m = m + 1.0
     d = m*(cn + m)
     t = t*(sz/d)
     w = w + t
     if(anorm(t) > eps*anorm(w)) go to 10
!
  w = w + 1.0
  return
end
subroutine bjm ( z, cn, w )
!
!*******************************************************************************
!
!! BJM calculates the Bessel function of the first kind
!     for real order cn > -1 and complex argument z by means
!     of the maclaurin expansion.  w is replaced by the
!     calculated value.
!-------------------------------------------------------------
  real m
  complex z, w, sz, t
!------------------
  anorm(z) = max ( abs(real(z)),abs(aimag(z)))
  eps = epsilon ( eps )
  sz = -0.25*z*z
!
!     initialization of maclaurin expansion
!
  m = 1.0
  t = sz/(cn + 1.0)
  w = t
!
!     summation of maclaurin expansion
!
   10    m = m + 1.0
     d = m*(cn + m)
     t = t*(sz/d)
     w = w + t
     if(anorm(t) > eps*anorm(w)) go to 10
!
  w = w + 1.0
  return
end
subroutine blkord (n, ia, ja, r, c, ib, num, iwk, ierr)
!
!*******************************************************************************
!
!! BLKORD reorders a sparse matrix into block triangular form.
!
  integer ia(*), ja(*), r(n), c(n), ib(n)
!     integer iwk(5*n)
  integer iwk(*)
!
  np1 = n + 1
  length = ia(np1) - ia(1)
  do 10 i = 1,n
     iwk(i) = ia(i+1) - ia(i)
   10 continue
  call mc21a(n,ja,length,ia,iwk(1),r,num,iwk(np1))
  ierr = n - num
  if (ierr /= 0) return
!
  do 20 i = 1,n
     li = r(i)
     iwk(i) = ia(li)
     npi = n + i
     iwk(npi) = ia(li+1) - ia(li)
   20 continue
  call mc13d(n,ja,length,iwk(1),iwk(np1),c,ib,num,iwk(2*n+1))
!
  do 30 i = 1,n
     li = c(i)
     iwk(i) = r(li)
   30 continue
  do 31 i = 1,n
     r(i) = iwk(i)
   31 continue
  return
end
subroutine blktr1 (n,an,bn,cn,m,am,bm,cm,idimy,y,b,w1,w2,w3,wd, &
                     ww,wu,prdct,cprdct)
!
!*******************************************************************************
!
!! BLKTR1 solves a block triangular linear system.
!
! b  contains the roots of all the b polynomials
! w1,w2,w3,wd,ww,wu  are all working arrays
! prdct is either prodp or prod0 depending on whether the boundary
! conditions in the m direction are periodic or not
! cprdct is either cprodp or cprod0 which are the complex versions
! of prodp and prod0. these are called in the event that some
! of the roots of the b sub p polynomial are complex
!
!
  dimension       an(*)      ,bn(*)      ,cn(*)      ,am(*)      , &
                  bm(*)      ,cm(*)      ,b(*)       ,w1(*)      , &
                  w2(*)      ,w3(*)      ,wd(*)      ,ww(*)      , &
                  wu(*)      ,y(idimy,*)
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
! begin reduction phase
!
  kdo = k-1
  do  90 l=1,kdo
     ir = l-1
     i2 = 2**ir
     i1 = i2/2
     i3 = i2+i1
     i4 = i2+i2
     irm1 = ir-1
     call indxb (i2,ir,im2,nm2)
     call indxb (i1,irm1,im3,nm3)
     call indxb (i3,irm1,im1,nm1)
     call prdct (nm2,b(im2),nm3,b(im3),nm1,b(im1),0,dum,y(1,i2),w3, &
                 m,am,bm,cm,wd,ww,wu)
     if = 2**k
     do  80 i=i4,if,i4
        if (i-nm)  10, 10, 80
   10       ipi1 = i+i1
        ipi2 = i+i2
        ipi3 = i+i3
        call indxc (i,ir,idxc,nc)
        if (i-if)  20, 80, 80
   20       call indxa (i,ir,idxa,na)
        call indxb (i-i1,irm1,im1,nm1)
        call indxb (ipi2,ir,ip2,np2)
        call indxb (ipi1,irm1,ip1,np1)
        call indxb (ipi3,irm1,ip3,np3)
        call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w3,w1,m,am, &
                    bm,cm,wd,ww,wu)
        if (ipi2-nm)  50, 50, 30
   30       do  40 j=1,m
           w3(j) = 0.
           w2(j) = 0.
   40       continue
        go to  60
   50       call prdct (np2,b(ip2),np1,b(ip1),np3,b(ip3),0,dum, &
                    y(1,ipi2),w3,m,am,bm,cm,wd,ww,wu)
        call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w3,w2,m,am, &
                    bm,cm,wd,ww,wu)
   60       do  70 j=1,m
           y(j,i) = w1(j)+w2(j)+y(j,i)
   70       continue
   80    continue
   90 continue
  if (npp) 320,100,320
!
!     the periodic case is treated using the capacitance matrix method
!
  100 if = 2**k
  i = if/2
  i1 = i/2
  call indxb (i-i1,k-2,im1,nm1)
  call indxb (i+i1,k-2,ip1,np1)
  call indxb (i,k-1,iz,nz)
  call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,y(1,i),w1,m,am, &
              bm,cm,wd,ww,wu)
  izr = i
  do 110 j=1,m
     w2(j) = w1(j)
  110 continue
  do 130 ll=2,k
     l = k-ll+1
     ir = l-1
     i2 = 2**ir
     i1 = i2/2
     i = i2
     call indxc (i,ir,idxc,nc)
     call indxb (i,ir,iz,nz)
     call indxb (i-i1,ir-1,im1,nm1)
     call indxb (i+i1,ir-1,ip1,np1)
     call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w1,w1,m,am,bm, &
                 cm,wd,ww,wu)
     do 120 j=1,m
        w1(j) = y(j,i)+w1(j)
  120    continue
     call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w1,w1,m,am, &
                 bm,cm,wd,ww,wu)
  130 continue
  do 180 ll=2,k
     l = k-ll+1
     ir = l-1
     i2 = 2**ir
     i1 = i2/2
     i4 = i2+i2
     ifd = if-i2
     do 170 i=i2,ifd,i4
        if (i-i2-izr) 170,140,170
  140       if (i-nm) 150,150,180
  150       call indxa (i,ir,idxa,na)
        call indxb (i,ir,iz,nz)
        call indxb (i-i1,ir-1,im1,nm1)
        call indxb (i+i1,ir-1,ip1,np1)
        call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w2,w2,m,am, &
                    bm,cm,wd,ww,wu)
        do 160 j=1,m
           w2(j) = y(j,i)+w2(j)
  160       continue
        call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w2,w2,m, &
                    am,bm,cm,wd,ww,wu)
        izr = i
        if (i-nm) 170,190,170
  170    continue
  180 continue
  190 do 200 j=1,m
     y(j,nm+1) = y(j,nm+1)-cn(nm+1)*w1(j)-an(nm+1)*w2(j)
  200 continue
  call indxb (if/2,k-1,im1,nm1)
  call indxb (if,k-1,ip,np)
  if (ncmplx) 210,220,210
  210 call cprdct (nm+1,b(ip),nm1,b(im1),0,dum,0,dum,y(1,nm+1), &
               y(1,nm+1),m,am,bm,cm,w1,w3,ww)
  go to 230
  220 call prdct (nm+1,b(ip),nm1,b(im1),0,dum,0,dum,y(1,nm+1), &
              y(1,nm+1),m,am,bm,cm,wd,ww,wu)
  230 do 240 j=1,m
     w1(j) = an(1)*y(j,nm+1)
     w2(j) = cn(nm)*y(j,nm+1)
     y(j,1) = y(j,1)-w1(j)
     y(j,nm) = y(j,nm)-w2(j)
  240 continue
  do 260 l=1,kdo
     ir = l-1
     i2 = 2**ir
     i4 = i2+i2
     i1 = i2/2
     i = i4
     call indxa (i,ir,idxa,na)
     call indxb (i-i2,ir,im2,nm2)
     call indxb (i-i2-i1,ir-1,im3,nm3)
     call indxb (i-i1,ir-1,im1,nm1)
     call prdct (nm2,b(im2),nm3,b(im3),nm1,b(im1),0,dum,w1,w1,m,am, &
                 bm,cm,wd,ww,wu)
     call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),w1,w1,m,am,bm, &
                 cm,wd,ww,wu)
     do 250 j=1,m
        y(j,i) = y(j,i)-w1(j)
  250    continue
  260 continue
!
  izr = nm
  do 310 l=1,kdo
     ir = l-1
     i2 = 2**ir
     i1 = i2/2
     i3 = i2+i1
     i4 = i2+i2
     irm1 = ir-1
     do 300 i=i4,if,i4
        ipi1 = i+i1
        ipi2 = i+i2
        ipi3 = i+i3
        if (ipi2-izr) 270,280,270
  270       if (i-izr) 300,310,300
  280       call indxc (i,ir,idxc,nc)
        call indxb (ipi2,ir,ip2,np2)
        call indxb (ipi1,irm1,ip1,np1)
        call indxb (ipi3,irm1,ip3,np3)
        call prdct (np2,b(ip2),np1,b(ip1),np3,b(ip3),0,dum,w2,w2,m, &
                    am,bm,cm,wd,ww,wu)
        call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),w2,w2,m,am, &
                    bm,cm,wd,ww,wu)
        do 290 j=1,m
           y(j,i) = y(j,i)-w2(j)
  290       continue
        izr = i
        go to 310
  300    continue
  310 continue
!
! begin back substitution phase
!
  320 do 440 ll=1,k
     l = k-ll+1
     ir = l-1
     irm1 = ir-1
     i2 = 2**ir
     i1 = i2/2
     i4 = i2+i2
     ifd = if-i2
     do 430 i=i2,ifd,i4
        if (i-nm) 330,330,430
  330       imi1 = i-i1
        imi2 = i-i2
        ipi1 = i+i1
        ipi2 = i+i2
        call indxa (i,ir,idxa,na)
        call indxc (i,ir,idxc,nc)
        call indxb (i,ir,iz,nz)
        call indxb (imi1,irm1,im1,nm1)
        call indxb (ipi1,irm1,ip1,np1)
        if (i-i2) 340,340,360
  340       do 350 j=1,m
           w1(j) = 0.
  350       continue
        go to 370
  360       call prdct (nm1,b(im1),0,dum,0,dum,na,an(idxa),y(1,imi2), &
                    w1,m,am,bm,cm,wd,ww,wu)
  370       if (ipi2-nm) 400,400,380
  380       do 390 j=1,m
           w2(j) = 0.
  390       continue
        go to 410
  400       call prdct (np1,b(ip1),0,dum,0,dum,nc,cn(idxc),y(1,ipi2), &
                    w2,m,am,bm,cm,wd,ww,wu)
  410       do 420 j=1,m
           w1(j) = y(j,i)+w1(j)+w2(j)
  420       continue
        call prdct (nz,b(iz),nm1,b(im1),np1,b(ip1),0,dum,w1,y(1,i), &
                    m,am,bm,cm,wd,ww,wu)
  430    continue
  440 continue
  return
end
subroutine blktri (iflg,np,n,an,bn,cn,mp,m,am,bm,cm,idimy,y, &
                     ierror,w)
!
!***********************************************************************
!
!! BLKTRI ???
!
!          version  2  october 1976  including errata  october 1976
!
!         documentation for this program is given in
!
!        efficient fortran subprograms for the solution of
!            elliptic partial differential equations
!
!                              by
!
!          paul swarztrauber   and  roland sweet
!
!             technical note tn/ia-109   july 1975
!
!       national center for atmospheric research  boulder,colorado 80307
!
!        which is sponsored by the national science foundation
!
!
!     subroutine blktri solves a system of linear equations of the form
!
!          an(j)*x(i,j-1) + am(i)*x(i-1,j) + (bn(j)+bm(i))*x(i,j)
!
!          + cn(j)*x(i,j+1) + cm(i)*x(i+1,j) = y(i,j)
!
!               for i = 1,2,...,m  and  j = 1,2,...,n.
!
!     i+1 and i-1 are evaluated modulo m and j+1 and j-1 modulo n, i.e.,
!
!          x(i,0) = x(i,n),  x(i,n+1) = x(i,1),
!          x(0,j) = x(m,j),  x(m+1,j) = x(1,j).
!
!     these equations usually result from the discretization of
!     separable elliptic equations.  boundary conditions may be
!     dirichlet, neumann, or periodic.
!
!
!     * * * * * * * * * *     on input
!
!     iflg
!       = 0  initialization only.  certain quantities that depend on np,
!                                  n, an, bn, and cn are computed and
!                                  stor1d in the work array  w.
!       = 1  the quantities that were computed in the initialization are
!            used to obtain the solution x(i,j).
!
!       note   a call with iflg=0 takes approximately one half the time
!              time as a call with iflg = 1  .  however, the
!              initialization does not have to be repeated unless np, n,
!              an, bn, or cn change.
!
!     np
!       = 0  if an(1) and cn(n) are not zero, which corresponds to
!            periodic bounary conditions.
!       = 1  if an(1) and cn(n) are zero.
!
!     n
!       the number of unknowns in the j-direction. n must be greater
!       than 2. the operation count is proportional to mnlog2(n), hence
!       n should be selected less than or equal to m.
!
!     an,bn,cn
!       one-dimensional arrays of length n that specify the coefficients
!       in the linear equations given above.
!
!     mp
!       = 0  if am(1) and cm(m) are not zero, which corresponds to
!            periodic boundary conditions.
!       = 1  if am(1) = cm(m) = 0  .
!
!     m
!       the number of unknowns in the i-direction. m must be greater
!       than 2.
!
!     am,bm,cm
!       one-dimensional arrays of length m that specify the coefficients
!       in the linear equations given above.
!
!     idimy
!       the row (or first) dimension of the two-dimensional array y as
!       it appears in the program calling blktri.  this parameter is
!       used to specify the variable dimension of y.  idimy must be at
!       least m.
!
!     y
!       a two-dimensional array that specifies the values of the right
!       side of the linear system of equations given above.  y must be
!       dimensioned at least m*n.
!
!     w
!       a one-dimensional array that must be provided by the user for
!       work space.
!             if np=1 define k=int(log2(n))+1 and set l=2**(k+1) then
!                     w must have dimension (k-2)*l+k+4+max(2n,6m)
!
!             if np=0 define k=int(log2(n-1))+1 and set l=2**(k+1) then
!                     w must have dimension (k-2)*l+k+4+2n+max(2n,6m)
!
!       **important** for purposes of checking, the required dimension
!                     of w is computed by blktri and stor1d in w(1)
!                     in floating point format.
!
!     * * * * * * * * * *     on output
!
!     y
!       contains the solution x.
!
!     ierror
!       an error flag that indicates invalid input parameters.  except
!       for number zero, a solution is not attempted.
!
!       = 0  no error.
!       = 1  m is less than 5
!       = 2  n is less than 3.
!       = 3  idimy is less than m.
!       = 4  blktri failed while computing results that depend on the
!            coefficient arrays an, bn, cn.  check these arrays.
!       = 5  an(j)*cn(j-1) is less than 0 for some j. possible reasons
!            for this condition are
!            1. the arrays an and cn are not correct
!            2. too large a grid spacing was used in the discretization
!               of the elliptic equation
!            3. the linear equations resulted from a partial
!               differential equation which was not elliptic
!
!     w
!       contains intermediate values that must not be destroyed if
!       blktri will be called again with iflg = 1  .
!
!
!
  dimension       an(*)      ,bn(*)      ,cn(*)      ,am(*)      , &
                  bm(*)      ,cm(*)      ,y(idimy,*) ,w(*)
  external        prod0      ,prodp      ,cprod0     ,cprodp
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
! test m and n for the proper form
!
  nm = n
  ierror = 0
  if (m-5)  10, 20, 20
   10 ierror = 1
  go to 190
   20 if (nm-3)  30, 40, 40
   30 ierror = 2
  go to 190
   40 if (idimy-m)  50, 60, 60
   50 ierror = 3
  go to 190
   60 nh = n
  npp = np
  if (npp)  70, 80, 70
   70 nh = nh+1
   80 ik = 2
  k = 1
   90 ik = ik+ik
  k = k+1
  if (nh-ik) 100,100, 90
  100 nl = ik
  ik = ik+ik
  nl = nl-1
  iwah = (k-2)*ik+k+6
  if (npp) 110,120,110
!
!     divide w into working sub arrays
!
  110 iw1 = iwah
  iwbh = iw1+nm
  w(1) = real(iw1-1+max (2*nm,6*m))
  go to 130
  120 iwbh = iwah+nm+nm
  iw1 = iwbh
  w(1) = real(iw1-1+max (2*nm,6*m))
  nm = nm-1
!
! subroutine compb computes the roots of the b polynomials
!
  130 if (ierror) 190,140,190
  140 iw2 = iw1+m
  iw3 = iw2+m
  iwd = iw3+m
  iww = iwd+m
  iwu = iww+m
  if (iflg) 160,150,160
  150 call compb (nl,ierror,an,bn,cn,w(2),w(iwah),w(iwbh))
  go to 190
  160 if (mp) 170,180,170
!
! subroutine blktr1 solves the linear system
!
  170 call blktr1 (nl,an,bn,cn,m,am,bm,cm,idimy,y,w(2),w(iw1),w(iw2), &
               w(iw3),w(iwd),w(iww),w(iwu),prod0,cprod0)
  go to 190
  180 call blktr1 (nl,an,bn,cn,m,am,bm,cm,idimy,y,w(2),w(iw1),w(iw2), &
               w(iw3),w(iwd),w(iww),w(iwu),prodp,cprodp)
  190 continue
  return
end
function blnd(a,b)
!
!***********************************************************************
!
!! BLND ???
!
  real blnd
  real logam
!
  if (a > 20.0) go to 10
     blnd = (logam(a) - logam(a + b)) + logam(b + 1.0)
     return
   10 blnd = algdiv(b,a) + logam(b + 1.0)
  return
end
subroutine blsq(m,n,a,ka,ml,mu,damp,u,x,atol,btol,conlim,itnlim, &
                       istop,itn,acond,rnorm,xnorm,w)
!
!***********************************************************************
!
!! BLSQ solves a linear system using least squares.
!
  integer m,n,ka,ml,mu,itnlim,istop
  real    a(ka,n),damp,u(m),x(n),atol,btol,conlim, &
          acond,rnorm,xnorm,w(*)
!
!
!     blsq finds a solution x to the following problems ...
!
!     1. unsymmetric equations --    solve  a*x = b
!
!     2. linear least squares  --    solve  a*x = b
!                                    in the least-squares sense
!
!     3. damped least squares  --    solve  (   a    )*x = ( b )
!                                           ( damp*i )     ( 0 )
!                                    in the least-squares sense
!
!     where a is a matrix with m rows and n columns, b an m-vector,
!     and damp a scalar. (all quantities are real.) the matrix a is
!     a banded matrix stored in band form.
!
!     the rhs vector b is input via u, and is subsequently overwritten.
!
!
!     note. blsq uses an iterative method to approximate the solution.
!     the number of iterations required to reach a certain accuracy
!     depends strongly on the scaling of the problem. poor scaling of
!     the rows or columns of a should therefore be avoided whenever
!     possible.
!
!     for example, in problem 1 the solution is unaltered by
!     row-scaling.  if a row of a is very small or large compared to
!     the other rows of a, the corresponding row of (a  b) should be
!     scaled up or down.
!
!     in problems 1 and 2, the solution x is easily recovered
!     following column scaling. in the absence of better information,
!     the nonzero columns of a should be scaled so that they all have
!     the same euclidean norm (e.g.  1.0).
!
!     in problem 3, there is no freedom to re-scale if damp is
!     nonzero. however, the value of damp should be assigned only
!     after attention has been paid to the scaling of a.
!
!     the parameter damp is intended to help regularize
!     ill-conditioned systems, by preventing the true solution from
!     being very large. another aid to regularization is provided by
!     the parameter acond, which may be used to terminate iterations
!     before the computed solution becomes very large.
!
!
!     notation
!     --------
!
!     the following quantities are used in discussing the subroutine
!     parameters...
!
!     abar   =  (   a    ),          bbar  =  ( b )
!               ( damp*i )                    ( 0 )
!
!     r      =  b  -  a*x,           rbar  =  bbar  -  abar*x
!
!     rnorm  =  sqrt( norm(r)**2  +  damp**2 * norm(x)**2 )
!            =  norm( rbar )
!
!     relpr  =  the smallest floating point number for which
!               1 + relpr > 1.
!
!     blsq   minimizes the function rnorm with respect to x.
!
!
!     parameters
!     ----------
!
!     m       input      the number of rows in a.
!
!     n       input      the number of columns in a.
!
!     a       input      the matrix a stored in band form.
!
!     ka      input      the number of rows in the dimension statement
!                        for a in the calling program.
!
!     ml      input      the lower band width of a.
!
!     mu      input      the upper band width of a.
!
!     damp    input      the damping parameter for problem 3 above.
!                        (damp  should be 0.0 for problems 1 and 2.)
!                        if the system  a*x = b  is incompatible, values
!                        of damp in the range 0 to sqrt(relpr)*norm(a)
!                        will probably have a negligible effect.
!                        larger values of damp will tend to decrease
!                        the norm of x and to reduce the number of
!                        iterations required by blsq.
!
!                        the work per iteration and the storage needed
!                        by blsq are the same for all values of damp.
!
!     u(m)    input      the rhs vector b. be aware that u is
!                        over-written by blsq.
!
!     x(n)    output     returns the computed solution x.
!
!     atol    input      an estimate of the relative error in the data
!                        defining the matrix a. for example,
!                        if a is accurate to about 6 digits, set
!                        atol = 1.0e-6 .
!
!     btol    input      an estimate of the relative error in the data
!                        defining the rhs vector b. for example,
!                        if b is accurate to about 6 digits, set
!                        btol = 1.0e-6 .
!
!     conlim  input      an upper limit on cond(abar), the apparent
!                        condition number of the matrix abar.
!                        iterations will be terminated if a computed
!                        estimate of cond(abar) exceeds conlim.
!                        this is intended to prevent certain small or
!                        zero singular values of a or abar from
!                        coming into effect and causing unwanted growth
!                        in the computed solution.
!
!                        conlim and damp may be used separately or
!                        together to regularize ill-conditioned systems.
!
!                        normally, conlim should be in the range
!                        1000  to  1/relpr.
!                        suggested value --
!                        conlim = 1/(100*relpr)  for compatible systems,
!                        conlim = 1/(10*sqrt(relpr))  for least squares.
!
!             note. if the user is not concerned about the parameters
!             atol, btol, and conlim, any or all of them may be set
!             to zero. the effect will be the same as the values
!             relpr, relpr, and  1/relpr  respectively.
!
!     itnlim  input      an upper limit on the number of iterations.
!                        suggested value --
!                        itnlim = n/2     for well conditioned systems,
!                        itnlim = 4*n     otherwise.
!
!     istop   output     an integer giving the reason for termination...
!
!                0       x = 0  is the exact solution.
!                        no iterations were performed.
!
!                1       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is sufficiently
!                        small, given the values of atol and btol.
!
!                2       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is sufficiently accurate,
!                        given the value of atol.
!
!                3       an estimate of cond(abar) has exceeded
!                        conlim. the system  a*x = b  appears to be
!                        ill-conditioned.
!
!                4       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is as small as
!                        seems reasonable on this machine.
!
!                5       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is as accurate as seems
!                        reasonable on this machine.
!
!                6       cond(abar) seems to be so large that there is
!                        not much point in doing further iterations,
!                        given the precision of this machine.
!
!                7       the iteration limit itnlim was reached.
!
!
!     itn     output     the number of iterations that were performed.
!
!     acond   output     an estimate of cond(abar), the condition
!                        number of abar.
!
!     rnorm   output     an estimate of the final value of norm(rbar),
!                        the function being minimized (see notation
!                        above). this will be small if  a*x = b  has
!                        a solution.
!
!     xnorm   output     an estimate of the norm of the final
!                        solution vector x.
!
!     w(2*n)             workspace
!
!     anorm   local      an estimate of the frobenius norm of abar.
!                        this is the square root of the sum of squares
!                        of the elements of abar.
!                        if damp is small and if the columns of a
!                        have all been scaled to have length  1.0,
!                        anorm should increase to roughly sqrt(n).
!
!     arnorm  local      an estimate of the final value of
!                        norm( abar(transpose)*rbar ), the norm of
!                        the residual for the usual normal equations.
!                        this should be small in all cases. (arnorm
!                        will often be smaller than the true value
!                        computed from the output vector x.)
!
!
!     subroutines and functions used
!     ------------------------------
!
!                normlz,bvprd1,btprd1
!     blas       scopy,snrm2,sscal  (see lawson et al. below)
!                (snrm2 is used only in normlz)
!     fortran    abs,sqrt
!
!
!     references
!     ----------
!
!     paige, c.c. and saunders, m.a.  lsqr, an algorithm for sparse
!        linear equations and sparse least squares.
!        acm transactions on mathematical software 8, 1 (march 1982).
!
!     lawson, c.l., hanson, r.j., kincaid, d.r. and krogh, f.t.
!        basic linear algebra subprograms for fortran usage.
!        acm transactions on mathematical software 5, 3 (sept 1979),
!        308-323 and 324-325.
!
!     local variables
!
  integer    i,itn,nconv,nstop
  real       alfa,anorm,arnorm,bbnorm,beta,bnorm, &
             cs,cs1,cs2,ctol,dampsq,ddnorm,delta, &
             gamma,gambar,one,phi,phibar,psi, &
             res1,res2,rho,rhobar,rhbar1,rhbar2,rhs,rtol, &
             sn,sn1,sn2,t,tau,test1,test2,test3, &
             theta,t1,t2,t3,xxnorm,z,zbar,zero
!
!
!     initialize.
!
  zero   = 0.0
  one    = 1.0
  ctol   = zero
  if (conlim > zero) ctol = one/conlim
  dampsq = damp**2
  anorm  = zero
  acond  = zero
  bbnorm = zero
  ddnorm = zero
  res2   = zero
  xnorm  = zero
  xxnorm = zero
  cs2    = -one
  sn2    = zero
  z      = zero
  itn    = 0
  istop  = 0
  nstop  = 0
!
  do 10 i = 1, n
     w(i) = zero
     x(i) = zero
   10 continue
!
!     set up the first vectors for the bidiagonalization.
!     these satisfy   beta*u = b,   alfa*w = a(transpose)*u.
!
  call normlz(m,u,beta)
  call btprd1(m,n,a,ka,ml,mu,u,w)
  call normlz(n,w,alfa)
  call scopy (n,w,1,w(n+1),1)
!
  rhobar = alfa
  phibar = beta
  bnorm  = beta
  rnorm  = beta
  arnorm = alfa*beta
  if (arnorm <= zero) go to 800
!
!     main iteration loop.
!
  100 itn = itn + 1
!
!     perform the next step of the bidiagonalization to obtain the
!     next  beta, u, alfa, w.  these satisfy the relations
!                beta*u  =  a*w  -  alfa*u,
!                alfa*w  =  a(transpose)*u  -  beta*w.
!
  call sscal (m,(-alfa),u,1)
  call bvprd1(m,n,a,ka,ml,mu,w,u)
  call normlz(m,u,beta)
  bbnorm = bbnorm + alfa**2 + beta**2 + dampsq
  call sscal (n,(-beta),w,1)
  call btprd1(m,n,a,ka,ml,mu,u,w)
  call normlz(n,w,alfa)
!
!
!     use a plane rotation to eliminate the damping parameter.
!     this alters the diagonal (rhobar) of the lower-bidiagonal matrix.
!
  rhbar2 = rhobar**2 + dampsq
  rhbar1 = sqrt(rhbar2)
  cs1    = rhobar/rhbar1
  sn1    = damp/rhbar1
  psi    = sn1*phibar
  phibar = cs1*phibar
!
!
!     use a plane rotation to eliminate the subdiagonal element (beta)
!     of the lower-bidiagonal matrix, giving an upper-bidiagonal matrix.
!
  rho    = sqrt(rhbar2 + beta**2)
  cs     = rhbar1/rho
  sn     = beta/rho
  theta  =  sn*alfa
  rhobar = -cs*alfa
  phi    =  cs*phibar
  phibar =  sn*phibar
  tau    =  sn*phi
!
!
!     update x and w(n+1),...,w(2*n)
!
  t1 =    phi/rho
  t2 = -theta/rho
  t3 =    one/rho
!
  do 200 i = 1, n
     npi   = n + i
     t     = w(npi)
     x(i)  = t1*t + x(i)
     w(npi)= t2*t + w(i)
     t     =(t3*t)**2
     ddnorm= t + ddnorm
  200 continue
!
!
!     use a plane rotation on the right to eliminate the
!     super-diagonal element (theta) of the upper-bidiagonal matrix.
!     then use the result to estimate norm(x).
!
  delta  =  sn2*rho
  gambar = -cs2*rho
  rhs    = phi - delta*z
  zbar   = rhs/gambar
  xnorm  = sqrt(xxnorm + zbar**2)
  gamma  = sqrt(gambar**2 + theta**2)
  cs2    = gambar/gamma
  sn2    = theta/gamma
  z      = rhs/gamma
  xxnorm = xxnorm + z**2
!
!
!     test for convergence.
!     first, estimate the norm and condition of the matrix abar,
!     and the norms of rbar and abar(transpose)*rbar.
!
  anorm  = sqrt(bbnorm)
  acond  = anorm*sqrt(ddnorm)
  res1   = phibar**2
  res2   = res2 + psi**2
  rnorm  = sqrt(res1 + res2)
  arnorm = alfa*abs(tau)
!
!     now use these norms to estimate certain other quantities,
!     some of which will be small near a solution.
!
  test1  = rnorm/bnorm
  test2  = arnorm/(anorm*rnorm)
  test3  = one/acond
  t1     = test1/(one + anorm*xnorm/bnorm)
  rtol   = btol +  atol*anorm*xnorm/bnorm
!
!     the following tests guard against extremely small values of
!     atol, btol, or ctol.  (the user may have set any or all of
!     the parameters atol, btol, conlim to zero.)
!     the effect is equivalent to the normal tests using
!     atol = relpr,  btol = relpr,  conlim = 1/relpr.
!
  t3 = one + test3
  t2 = one + test2
  t1 = one + t1
  if (itn >= itnlim) istop = 7
  if (t3  <= one   ) istop = 6
  if (t2  <= one   ) istop = 5
  if (t1  <= one   ) istop = 4
!
!     allow for tolerances set by the user.
!
  if (test3 <= ctol) istop = 3
  if (test2 <= atol) istop = 2
  if (test1 <= rtol) istop = 1
!
!     stop if appropriate.
!     the convergence criteria are required to be met on  nconv
!     consecutive iterations, where  nconv  is set below.
!     suggested value --   nconv = 1, 2  or  3.
!
  if (istop == 0) nstop = 0
  if (istop == 0) go to 100
  nconv = 1
  nstop = nstop + 1
  if (nstop < nconv  .and.  itn  <  itnlim) istop = 0
  if (istop == 0) go to 100
!
!     end of iteration loop.
!
  800 return
end
subroutine bpose(a,ka,m,n,ml,mu,b,kb)
!
!***********************************************************************
!
!! BPOSE transposes a real banded matrix.
!
  real a(ka,*),b(kb,*)
!
  l = ml + mu + 1
  lp1 = l + 1
  if (mu == 0) go to 40
!
!     defining the first mu columns of b
!
  ndiag = mu
  do 31 j = 1,mu
     lj = lp1 - j
!
     do 10 i = 1,ndiag
   10    b(i,j) = 0.0
!
     imax = min (m,n-ndiag)
     do 20 i = 1,imax
     ii = ndiag + i
   20    b(ii,j) = a(i,lj)
!
     if (ii == n) go to 31
     imin = ii + 1
     do 30 i = imin,n
   30    b(i,j) = 0.0
   31 ndiag = ndiag - 1
!
!     defining the remaining columns of b
!
   40 jmin = mu + 1
  ndiag = 0
  do 61 j = jmin,l
     lj = lp1 - j
!
     imax = min (m-ndiag,n)
     do 50 i = 1,imax
     ii = ndiag + i
   50    b(i,j) = a(ii,lj)
!
     if (imax == n) go to 61
     imin = imax + 1
     do 60 i = imin,n
   60    b(i,j) = 0.0
   61 ndiag = ndiag + 1
  return
end
subroutine bprod(m,n,l,a,ka,ml,mu,b,kb,nl,nu,c,kc,nc,mcl,mcu,ierr)
!
!***********************************************************************
!
!! BPROD multiplies real banded matrices
!
  real a(ka,*), b(kb,*), c(kc,nc)
  double precision dsum
!
  ierr = 0
  mlp1 = ml + 1
  nlp1 = nl + 1
  npml = n + ml
  npnu = n + nu
  mcl = min (m-1,ml+nl)
  if (mcl == 0) go to 100
!
!     find the first nonzero lower diagonal
!
  maxd = mcl
  do 21 ndiag = 1,maxd
  imj = maxd + 1 - ndiag
  jmax = min (l,m-imj,npml-imj)
    do 11 j = 1,jmax
    i = j + imj
    dsum = 0.d0
    if (j > npnu) go to 11
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 10 k = kmin,kmax
      dsum = dsum + dble(a(i,kk))*dble(b(k,jj))
      kk = kk + 1
   10     jj = jj - 1
   11   c(i,1) = dsum
!
  jmax = min (jmax,npnu)
    do 20 j = 1,jmax
    i = j + imj
    if (c(i,1) /= 0.0) go to 30
   20   continue
   21 mcl = mcl - 1
  go to 100
!
   30 if (mcl >= nc) go to 200
  c(1,1) = 0.0
  if (mcl == 1) go to 100
!
!     compute the remaining lower diagonals
!
  jc = 1
  mind = ndiag + 1
  do 42 ndiag = mind,maxd
  jc = jc + 1
  imj = maxd + 1 - ndiag
  jmax = min (l,m-imj,npml-imj)
    do 41 j = 1,jmax
    i = j + imj
    dsum = 0.d0
    if (j > npnu) go to 41
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 40 k = kmin,kmax
      dsum = dsum + dble(a(i,kk))*dble(b(k,jj))
      kk = kk + 1
   40     jj = jj - 1
   41   c(i,jc) = dsum
   42 continue
!
!     insert zeros in the upper left corner
!
  imax = mcl
  do 51 j = 1,mcl
    do 50 i = 1,imax
   50   c(i,j) = 0.0
   51 imax = imax - 1
!
!     find the last nonzero upper diagonal
!
  100 jc = mcl + 1
  mcu = min (l-1,mu+nu)
  if (mcu == 0) go to 140
!
  maxd = mcu
  do 121 ndiag = 1,maxd
  jmi = maxd + 1 - ndiag
  imax = min (m,l-jmi,npml)
    do 111 i = 1,imax
    j = i + jmi
    dsum = 0.d0
    if (j > npnu) go to 111
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 110 k = kmin,kmax
      dsum = dsum + dble(a(i,kk))*dble(b(k,jj))
      kk = kk + 1
  110     jj = jj - 1
  111   c(i,jc) = dsum
!
  imax1 = min (imax,npnu-jmi)
    do 120 i = 1,imax1
    if (c(i,jc) /= 0.0) go to 130
  120   continue
  121 mcu = mcu - 1
  go to 140
!
  130 last = jc + mcu
  if (last > nc) go to 210
  do 131 i = 1,imax
  131 c(i,last) = c(i,jc)
!
!     compute the main diagonal and the remaining upper diagonals
!
  140 maxd = max (1,mcu)
  do 143 ndiag = 1,maxd
  jmi = ndiag - 1
  imax = min (m,l-jmi,npml)
    do 142 i = 1,imax
    j = i + jmi
    dsum = 0.d0
    if (j > npnu) go to 142
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 141 k = kmin,kmax
      dsum = dsum + dble(a(i,kk))*dble(b(k,jj))
      kk = kk + 1
  141     jj = jj - 1
  142   c(i,jc) = dsum
  143 jc = jc + 1
!
!     insert zeros in the lower right corner
!
  jmax = mcl + mcu + 1
  imin = l - mcu + 1
  imax = min (m,npml)
  if (imin > imax) go to 160
!
  jmin = max (1,jmax-imax+imin)
  j = jmax
  do 151 jj = jmin,jmax
    do 150 i = imin,imax
  150   c(i,j) = 0.0
  imin = imin + 1
  151 j = j - 1
!
!     store zeros in the final m-imax rows
!
  160 if (imax == m) return
  imin = imax + 1
  do 162 j = 1,jmax
    do 161 i = imin,m
  161   c(i,j) = 0.0
  162 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = mcl + 1
  return
  210 ierr = last
  return
end
function bpser(a, b, x, eps)
!
!***********************************************************************
!
!! BPSER power series expansion for evaluating ix(a,b) when b <= 1
!     or b*x <= 0.7.  eps is the tolerance used.
!
  real bpser
  real n
!
  bpser = 0.0
  if (x == 0.0) return
!-----------------------------------------------------------------------
!            compute the factor x**a/(a*beta(a,b))
!-----------------------------------------------------------------------
  a0 = amin1(a,b)
  if (a0 < 1.0) go to 10
     z = a*alog(x) - betaln(a,b)
     bpser = exp(z)/a
     go to 70
   10 b0 = max ( a,b)
  if (b0 >= 8.0) go to 60
  if (b0 > 1.0) go to 40
!
!            procedure for a0 < 1 and b0 <= 1
!
  bpser = x**a
  if (bpser == 0.0) return
!
  apb = a + b
  if (apb > 1.0) go to 20
     z = 1.0 + gam1(apb)
     go to 30
   20 u = dble(a) + dble(b) - 1.d0
  z = (1.0 + gam1(u))/apb
!
   30 c = (1.0 + gam1(a))*(1.0 + gam1(b))/z
  bpser = bpser*c*(b/apb)
  go to 70
!
!         procedure for a0 < 1 and 1  <  b0  <  8
!
   40 u = gamln1(a0)
  m = b0 - 1.0
  if (m < 1) go to 50
  c = 1.0
  do 41 i = 1,m
     b0 = b0 - 1.0
   41    c = c*(b0/(a0 + b0))
  u = alog(c) + u
!
   50 z = a*alog(x) - u
  b0 = b0 - 1.0
  apb = a0 + b0
  if (apb > 1.0) go to 51
     t = 1.0 + gam1(apb)
     go to 52
   51 u = dble(a0) + dble(b0) - 1.d0
  t = (1.0 + gam1(u))/apb
   52 bpser = exp(z)*(a0/a)*(1.0 + gam1(b0))/t
  go to 70
!
!            procedure for a0 < 1 and b0 >= 8
!
   60 u = gamln1(a0) + algdiv(a0,b0)
  z = a*alog(x) - u
  bpser = (a0/a)*exp(z)
   70 if (bpser == 0.0 .or. a <= 0.1*eps) return
!
!                     compute the series
!
  sum = 0.0
  n = 0.0
  c = 1.0
  tol = eps/a
  100    n = n + 1.0
     c = c*(0.5 + (0.5 - b/n))*x
     w = c/(a + n)
     sum = sum + w
     if (abs(w) > tol) go to 100
  bpser = bpser*(1.0 + a*sum)
  return
end
subroutine bratio ( a, b, x, y, w, w1, ierr )
!
!***********************************************************************
!
!! BRATIO evaluates the incomplete beta function IX(A,B).
!
!
!     it is assumed that a and b are nonnegative, and that x <= 1
!     and y = 1 - x.  bratio assigns w and w1 the values
!
!                      w  = ix(a,b)
!                      w1 = 1 - ix(a,b)
!
!     ierr is a variable that reports the status of the results.
!     if no input errors are detected then ierr is set to 0 and
!     w and w1 are computed. otherwise, if an error is detected,
!     then w and w1 are assigned the value 0 and ierr is set to
!     one of the following values ...
!
!        ierr = 1  if a or b is negative
!        ierr = 2  if a = b = 0
!        ierr = 3  if x < 0 or x > 1
!        ierr = 4  if y < 0 or y > 1
!        ierr = 5  if x + y /= 1
!        ierr = 6  if x = a = 0
!        ierr = 7  if y = b = 0
!
!  Author:
!
!    Alfred Morris,
!    Naval Surface Weapons Center,
!    Dahlgren, Virginia
!
  real lambda
!
  eps = epsilon ( eps )
  w = 0.0
  w1 = 0.0
  if (a < 0.0 .or. b  <  0.0) go to 300
  if (a == 0.0 .and. b == 0.0) go to 310
  if (x < 0.0 .or. x > 1.0) go to 320
  if (y < 0.0 .or. y > 1.0) go to 330
  z = dble(x) + dble(y) - 1.d0
  if (abs(z) > eps) go to 340
!
  ierr = 0
  if (x == 0.0) go to 200
  if (y == 0.0) go to 210
  if (a == 0.0) go to 211
  if (b == 0.0) go to 201
!
  ind = 0
  a0 = a
  b0 = b
  x0 = x
  y0 = y
  eps = max ( eps, 1.e-15)
  if (amin1(a0, b0) > 1.0) go to 30
!
!             procedure for a0 <= 1 or b0 <= 1
!
  if (x <= 0.5) go to 10
  ind = 1
  a0 = b
  b0 = a
  x0 = y
  y0 = x
!
   10 if (max ( a0, b0) > 1.0) go to 20
  if (a0 >= amin1(0.2, b0)) go to 100
  if (x0**a0 <= 0.9) go to 100
  if (x0 >= 0.3) go to 110
  n = 20
  go to 130
!
   20 if (b0 <= 1.0) go to 100
  if (x0 >= 0.3) go to 110
  if (x0 >= 0.1) go to 21
  if ((x0*b0)**a0 <= 0.7) go to 100
   21 if (b0 > 15.0) go to 131
  n = 20
  go to 130
!
!             procedure for a0 > 1 and b0  >  1
!
   30 if (a > b) go to 31
     lambda = a - (a + b)*x
     go to 32
   31 lambda = (a + b)*y - b
   32 if (lambda >= 0.0) go to 40
  ind = 1
  a0 = b
  b0 = a
  x0 = y
  y0 = x
  lambda = abs(lambda)
!
   40 if (b0 < 40.0 .and. b0*x0 <= 0.7) go to 100
  if (b0 < 40.0) go to 140
  if (a0 > b0) go to 50
     if (a0 <= 100.0) go to 120
     if (lambda > 0.03*a0) go to 120
     go to 180
   50 if (b0 <= 100.0) go to 120
  if (lambda > 0.03*b0) go to 120
  go to 180
!
!            evaluation of the appropriate algorithm
!
  100 w = bpser(a0, b0, x0, eps)
  w1 = 0.5 + (0.5 - w)
  go to 220
!
  110 w1 = bpser(b0, a0, y0, eps)
  w = 0.5 + (0.5 - w1)
  go to 220
!
  120 w = bfrac(a0, b0, x0, y0, lambda, 15.0*eps)
  w1 = 0.5 + (0.5 - w)
  go to 220
!
  130 w1 = bup(b0, a0, y0, x0, n, eps)
  b0 = b0 + n
  131 call bgrat(b0, a0, y0, x0, w1, 15.0*eps, ierr1)
  w = 0.5 + (0.5 - w1)
  go to 220
!
  140 n = b0
  b0 = b0 - n
  if (b0 /= 0.0) go to 141
     n = n - 1
     b0 = 1.0
  141 w = bup(b0, a0, y0, x0, n, eps)
  if (x0 > 0.7) go to 150
  w = w + bpser(a0, b0, x0, eps)
  w1 = 0.5 + (0.5 - w)
  go to 220
!
  150 if (a0 > 15.0) go to 151
     n = 20
     w = w + bup(a0, b0, x0, y0, n, eps)
     a0 = a0 + n
  151 call bgrat(a0, b0, x0, y0, w, 15.0*eps, ierr1)
  w1 = 0.5 + (0.5 - w)
  go to 220
!
  180 w = basym(a0, b0, lambda, 100.0*eps)
  w1 = 0.5 + (0.5 - w)
  go to 220
!
!               termination of the procedure
!
  200 if (a == 0.0) go to 350
  201 w = 0.0
  w1 = 1.0
  return
!
  210 if (b == 0.0) go to 360
  211 w = 1.0
  w1 = 0.0
  return
!
  220 if (ind == 0) return
  t = w
  w = w1
  w1 = t
  return
!
!                    error return
!
  300 ierr = 1
  return
  310 ierr = 2
  return
  320 ierr = 3
  return
  330 ierr = 4
  return
  340 ierr = 5
  return
  350 ierr = 6
  return
  360 ierr = 7
  return
end
function brcmp1 (mu, a, b, x, y)
!
!***********************************************************************
!
!! BRCMP1 evaluates  exp(mu) * (x**a*y**b/beta(a,b))
!
  real brcmp1
  real lambda, lnx, lny
!-----------------
!     const = 1/sqrt(2*pi)
!-----------------
  data const/.398942280401433/
!
  a0 = amin1(a,b)
  if (a0 >= 8.0) go to 100
!
  if (x > 0.375) go to 10
     lnx = alog(x)
     lny = alnrel(-x)
     go to 20
   10 if (y > 0.375) go to 11
     lnx = alnrel(-y)
     lny = alog(y)
     go to 20
   11 lnx = alog(x)
  lny = alog(y)
!
   20 z = a*lnx + b*lny
  if (a0 < 1.0) go to 30
  z = z - betaln(a,b)
  brcmp1 = esum(mu,z)
  return
!
!              procedure for a < 1 or b  <  1
!
   30 b0 = max ( a,b)
  if (b0 >= 8.0) go to 80
  if (b0 > 1.0) go to 60
!
!                   algorithm for b0 <= 1
!
  brcmp1 = esum(mu,z)
  if (brcmp1 == 0.0) return
!
  apb = a + b
  if (apb > 1.0) go to 40
     z = 1.0 + gam1(apb)
     go to 50
   40 u = dble(a) + dble(b) - 1.d0
  z = (1.0 + gam1(u))/apb
!
   50 c = (1.0 + gam1(a))*(1.0 + gam1(b))/z
  brcmp1 = brcmp1*(a0*c)/(1.0 + a0/b0)
  return
!
!                algorithm for 1 < b0  <  8
!
   60 u = gamln1(a0)
  n = b0 - 1.0
  if (n < 1) go to 70
  c = 1.0
  do 61 i = 1,n
     b0 = b0 - 1.0
     c = c*(b0/(a0 + b0))
   61 continue
  u = alog(c) + u
!
   70 z = z - u
  b0 = b0 - 1.0
  apb = a0 + b0
  if (apb > 1.0) go to 71
     t = 1.0 + gam1(apb)
     go to 72
   71 u = dble(a0) + dble(b0) - 1.d0
  t = (1.0 + gam1(u))/apb
   72 brcmp1 = a0*esum(mu,z)*(1.0 + gam1(b0))/t
  return
!
!                   algorithm for b0 >= 8
!
   80 u = gamln1(a0) + algdiv(a0,b0)
  brcmp1 = a0*esum(mu,z - u)
  return
!
!              procedure for a >= 8 and b >= 8
!
  100 if (a > b) go to 101
     h = a/b
     x0 = h/(1.0 + h)
     y0 = 1.0/(1.0 + h)
     lambda = a - (a + b)*x
     go to 110
  101 h = b/a
  x0 = 1.0/(1.0 + h)
  y0 = h/(1.0 + h)
  lambda = (a + b)*y - b
!
  110 e = -lambda/a
  if (abs(e) > 0.6) go to 111
     u = rlog1(e)
     go to 120
  111 u = e - alog(x/x0)
!
  120 e = lambda/b
  if (abs(e) > 0.6) go to 121
     v = rlog1(e)
     go to 130
  121 v = e - alog(y/y0)
!
  130 z = esum(mu,-(a*u + b*v))
  brcmp1 = const*sqrt(b*x0)*z*exp(-bcorr(a,b))
  return
end
function brcomp (a, b, x, y)
!
!***********************************************************************
!
!! BRCOMP evaluates x**a * y**b / beta(a,b).
!
  real brcomp
  real lambda, lnx, lny
!-----------------
!     const = 1/sqrt(2*pi)
!-----------------
  data const/.398942280401433/
!
  a0 = amin1(a,b)
  if (a0 >= 8.0) go to 100
!
  if (x > 0.375) go to 10
     lnx = alog(x)
     lny = alnrel(-x)
     go to 20
   10 if (y > 0.375) go to 11
     lnx = alnrel(-y)
     lny = alog(y)
     go to 20
   11 lnx = alog(x)
  lny = alog(y)
!
   20 z = a*lnx + b*lny
  if (a0 < 1.0) go to 30
  z = z - betaln(a,b)
  brcomp = exp(z)
  return
!
!              procedure for a < 1 or b  <  1
!-----------------------------------------------------------------------
   30 b0 = max ( a,b)
  if (b0 >= 8.0) go to 80
  if (b0 > 1.0) go to 60
!
!                   algorithm for b0 <= 1
!
  brcomp = exp(z)
  if (brcomp == 0.0) return
!
  apb = a + b
  if (apb > 1.0) go to 40
     z = 1.0 + gam1(apb)
     go to 50
   40 u = dble(a) + dble(b) - 1.d0
  z = (1.0 + gam1(u))/apb
!
   50 c = (1.0 + gam1(a))*(1.0 + gam1(b))/z
  brcomp = brcomp*(a0*c)/(1.0 + a0/b0)
  return
!
!                algorithm for 1 < b0  <  8
!
   60 u = gamln1(a0)
  n = b0 - 1.0
  if (n < 1) go to 70
  c = 1.0
  do 61 i = 1,n
     b0 = b0 - 1.0
     c = c*(b0/(a0 + b0))
   61 continue
  u = alog(c) + u
!
   70 z = z - u
  b0 = b0 - 1.0
  apb = a0 + b0
  if (apb > 1.0) go to 71
     t = 1.0 + gam1(apb)
     go to 72
   71 u = dble(a0) + dble(b0) - 1.d0
  t = (1.0 + gam1(u))/apb
   72 brcomp = a0*exp(z)*(1.0 + gam1(b0))/t
  return
!
!                   algorithm for b0 >= 8
!
   80 u = gamln1(a0) + algdiv(a0,b0)
  brcomp = a0*exp(z - u)
  return
!-----------------------------------------------------------------------
!              procedure for a >= 8 and b >= 8
!
  100 if (a > b) go to 101
     h = a/b
     x0 = h/(1.0 + h)
     y0 = 1.0/(1.0 + h)
     lambda = a - (a + b)*x
     go to 110
  101 h = b/a
  x0 = 1.0/(1.0 + h)
  y0 = h/(1.0 + h)
  lambda = (a + b)*y - b
!
  110 e = -lambda/a
  if (abs(e) > 0.6) go to 111
     u = rlog1(e)
     go to 120
  111 u = e - alog(x/x0)
!
  120 e = lambda/b
  if (abs(e) > 0.6) go to 121
     v = rlog1(e)
     go to 130
  121 v = e - alog(y/y0)
!
  130 z = exp(-(a*u + b*v))
  brcomp = const*sqrt(b*x0)*z*exp(-bcorr(a,b))
  return
end
subroutine bsl2 (t,n,k,tau,gtau,wgt,ntau,bcoef,wk,q,ierr)
!
!***********************************************************************
!
!! BSL2 produces the b-spline coefficients bcoef of the piecewise
!   polynomial p(x) of order k with knots t(i) (i=1,...,n+k) which
!   minimizes  sum(wgt(i)*(p(tau(i))-gtau(i))**2).
!
! ******  i n p u t  ******
!   t     knot sequence of length n+k.
!   n     dimension of the piecewise polynomial space.
!   k     order of the b-splines.
!   tau   array of length ntau containing data point abscissae.
!   gtau  array of length ntau containing data point ordinates.
!   wgt   array of length ntau containing the weights.
!   ntau  number of data points to be fitted.
!
! ******  o u t p u t  ******
!   bcoef array of length n containing the b-spline coefficients
!         of the l2 approximation.
!   ierr  integer specifying the status of the results. ierr = 0
!         if no input errors are detected. otherwise ierr = 1.
!
  real tau(ntau),gtau(ntau),wgt(ntau)
  real t(*),bcoef(n),wk(n),q(k,n)
  if (k < 1 .or. n < k) go to 100
  if (t(n) >= t(n+1)) go to 100
  x = t(k)
!
  do 11 j = 1,n
  bcoef(j) = 0.0
     do 10 i = 1,k
   10    q(i,j) = 0.0
   11 continue
!
  npk = n + k
  left = k
  leftmk = 0
  do 41 ll = 1,ntau
  if (tau(ll) < x) go to 100
  x = tau(ll)
!     *** find the index left such that
!             t(left) <= tau(ll) < t(left+1)
   20 if (left == n) go to 21
  if (tau(ll) < t(left+1)) go to 30
  left = left + 1
  leftmk = leftmk + 1
  go to 20
   21 if (tau(ll) > t(left+1)) go to 100
!
   30 call bspev(t,npk,tau(ll),left,0,k,wk,ierr)
!
  do 41 mm = 1,k
  dw = wk(mm)*wgt(ll)
  j = leftmk + mm
  bcoef(j) = dw*gtau(ll) + bcoef(j)
  i = 1
     do 40 jj = mm,k
     q(i,j) = wk(jj)*dw + q(i,j)
   40    i = i + 1
   41 continue
!
!        solve the normal equations
!
  call bchfac(q,k,n,wk)
  call bchslv(q,k,n,bcoef)
  return
!
!             error return
!
  100 ierr = 1
  return
end
subroutine bslv(m0,a,ka,n,ml,mu,b,iwk,ierr)
!
!***********************************************************************
!
!! BSLV employs gauss elimination with row interchanges to solve
!     the nxn banded linear system ax = b. the argument m0 specifies
!     if bslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) an lu decompo-
!     sition of a is obtained and then the equations are solved.
!     on subsequent calls (when m0/=0) the equations are solved
!     using the decomposition obtained on the initial call to bslv.
!
!
!     input arguments when m0=0 ---
!
!     a,ka      2-dimensional array of dimension (ka,m) where
!               ka >= n and m >= 2*ml+mu+1. the first ml+mu+1
!               columns contain the matrix a in banded form.
!
!     n         number of equations and unknowns.
!
!     ml        number of diagonals below the main diagonal.
!
!     mu        number of diagonals above the main diagonal.
!
!     b         array of n entries containing the right hand
!               side data.
!
!
!     output arguments when m0=0 ---
!
!     a         an upper tiangular matrix in band storage and
!               the multipliers which were used to obtain it.
!
!     b         the solution of the equations.
!
!     iwk       array of length n containing the pivot indices.
!
!     ierr      integer specifying the status of the results.
!               ierr=0 if the solution of ax = b is obtained.
!               otherwise ierr/=0.
!
!
!     after an initial call to bslv, the routine may be recalled
!     with m0/=0 for a new b. when m0/=0 it is assumed that
!     a,ka,n,ml,mu,iwk have not been modified. bslv retrieves the
!     lu decomposition which was obtained on the initial call to
!     bslv and solves the new equations ax = b. in this case ierr
!     is not referenced.
! ----------------------------------------------------------------------
  real a(ka,*),b(n)
  integer iwk(n)
  if (m0 /= 0) go to 10
!
!     error checking
!
  if (n <= 0 .or. n > ka) go to 100
  if (ml < 0 .or. ml >= n) go to 110
  if (mu < 0 .or. mu >= n) go to 120
!
!     obtain an lu decomposition of a
!
  call snbfa(a,ka,n,ml,mu,iwk,ierr)
  if (ierr /= 0) return
!
!     solve the system of equations
!
   10 call snbsl(a,ka,n,ml,mu,iwk,b,0)
  return
!
!     error return
!
  100 ierr = -1
  return
  110 ierr = -2
  return
  120 ierr = -3
  return
end
subroutine bslv1(m0,a,ka,n,ml,mu,b,iwk,ierr)
!
!***********************************************************************
!
!! BSLV1 employs gauss elimination with row interchanges to solve
!     the nxn banded linear system xa = b. the argument m0 specifies
!     if bslv1 is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) an lu decompo-
!     sition of a is obtained and then the equations are solved.
!     on subsequent calls (when m0/=0) the equations are solved
!     using the decomposition obtained on the initial call to bslv1.
!
!
!     input arguments when m0=0 ---
!
!     a,ka      2-dimensional array of dimension (ka,m) where
!               ka >= n and m >= 2*ml+mu+1. the first ml+mu+1
!               columns contain the matrix a in banded form.
!
!     n         number of equations and unknowns.
!
!     ml        number of diagonals below the main diagonal.
!
!     mu        number of diagonals above the main diagonal.
!
!     b         array of n entries containing the right hand
!               side data.
!
!
!     output arguments when m0=0 ---
!
!     a         an upper tiangular matrix in band storage and
!               the multipliers which were used to obtain it.
!
!     b         the solution of the equations.
!
!     iwk       array of length n containing the pivot indices.
!
!     ierr      integer specifying the status of the results.
!               ierr=0 if the solution of xa = b is obtained.
!               otherwise ierr/=0.
!
!
!     after an initial call to bslv1, the routine may be recalled
!     with m0/=0 for a new b. when m0/=0 it is assumed that
!     a,ka,n,ml,mu,iwk have not been modified. bslv retrieves the
!     lu decomposition which was obtained on the initial call to
!     bslv1 and solves the new equations xa = b. in this case ierr
!     is not referenced.
!
  real a(ka,*),b(n)
  integer iwk(n)
  if (m0 /= 0) go to 10
!
!     error checking
!
  if (n <= 0 .or. n > ka) go to 100
  if (ml < 0 .or. ml >= n) go to 110
  if (mu < 0 .or. mu >= n) go to 120
!
!     obtain an lu decomposition of a
!
  call snbfa(a,ka,n,ml,mu,iwk,ierr)
  if (ierr /= 0) return
!
!     solve the system of equations
!
   10 call snbsl(a,ka,n,ml,mu,iwk,b,1)
  return
!
!     error return
!
  100 ierr = -1
  return
  110 ierr = -2
  return
  120 ierr = -3
  return
end
subroutine bspev(t,k,x,i,m,n,b,ierr)
!
!***********************************************************************
!
!! BSPEV evaluation of b-splines
!
  real t(k),b(n)
  if (m < 0 .or. m >= n) go to 20
  if (t(i) >= t(i+1)) go to 21
  nm1 = n - 1
  if (i < nm1) go to 22
  if (k < i + nm1) go to 23
!
  ierr = 0
  j = m
  if (m >= 1) go to 10
  b(1) = 1.0
  if (n == 1) return
  j = 1
!
   10 s = 0.0
  do 11 l = 1,j
  il = i + l
  ilj = il - j
  term = b(l)/(t(il)-t(ilj))
  b(l) = s + (t(il)-x)*term
   11 s = (x-t(ilj))*term
  b(j+1) = s
  j = j + 1
  if (j < n) go to 10
  return
!
!          error return
!
   20 ierr = 1
  return
   21 ierr = 2
  return
   22 ierr = 3
  return
   23 ierr = 4
  return
end
subroutine bspp(t,bcoef,n,k,break,coef,l,wk)
!
!***********************************************************************
!
!! BSPP converts from b-spline representation to pp representation
!
!     input
!       t     knot sequence of length n+k
!       bcoef b-spline coefficient sequence of length n
!       n     length of bcoef
!       k     order of the b-splines
!
!     output
!       break breakpoint sequence, of length l+1, containing
!             (in increasing order) the distinct points of the
!             sequence t(k),...,t(n+1).
!       coef  kxl matrix where coef(i,j) = (i-1)st right derivative
!             of the pp at break(j) divided by factorial(i-1).
!       l     number of polynomials which form the pp
!
!     work area
!       wk    2-dimensional array of dimension (k,k+1)
!     ------------------
  real t(*),bcoef(n),break(*),coef(k,*),wk(k,*)
!     ------------------
  l = 0
  break(1) = t(k)
  if (k == 1) go to 100
  km1 = k - 1
  kp1 = k + 1
!
!          general k-th order case
!
  do 40 left = k,n
  if (t(left) == t(left+1)) go to 40
  l = l + 1
  break(l+1) = t(left+1)
  do 10 j = 1,k
     jj = left - k + j
   10 wk(j,1) = bcoef(jj)
!
  do 21 j = 1,km1
  jp1 = j + 1
  kmj = k - j
  do 20 i = 1,kmj
     il = i + left
     ilkj = il - kmj
     diff = t(il) - t(ilkj)
   20 wk(i,jp1) = (wk(i+1,j) - wk(i,j))/diff
   21 continue
!
  wk(1,kp1) = 1.0
  x = t(left)
  coef(k,l) = wk(1,k)
  a = 1.0
  do 32 j = 1,km1
  jp1 = j + 1
  s = 0.0
  do 30 i = 1,j
     il = i + left
     ilj = il - j
     term = wk(i,kp1)/(t(il)-t(ilj))
     wk(i,kp1) = s + (t(il)-x)*term
   30 s = (x-t(ilj))*term
  wk(jp1,kp1) = s
  s = 0.0
  kmj = k - j
  do 31 i = 1,jp1
   31 s = s + wk(i,kmj)*wk(i,kp1)
  a = (a*real(kmj))/float(j)
   32 coef(kmj,l) = a*s
!
   40 continue
  return
!
!          piecewise constant case
!
  100 do 110 left = k,n
  if (t(left) == t(left+1)) go to 110
  l = l + 1
  break(l+1) = t(left+1)
  coef(1,l) = bcoef(left)
  110 continue
  return
end
function bsrh (xll,xrr,iz,c,a,bh,f,sgn)
!
!***********************************************************************
!
!! BSRH ???
!
  dimension       a(*)       ,c(*)       ,bh(*)
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
  xl = xll
  xr = xrr
  dx = 0.5*abs(xr-xl)

   10 continue

  x = 0.5*(xl+xr)
  if ( sgn * f(x,iz,c,a,bh) )  30, 50, 20
   20 xr = x
  go to  40
   30 xl = x
   40 dx = .5*dx

  if ( cnv < dx ) then
    go to 10
  end if

   50 bsrh = .5*(xl+xr)

  return
end
subroutine bssli ( mo, a, in, w )
!
!***********************************************************************
!
!! BSSLI modified Bessel function of integral order
!
!     mo = mode of operation
!     a  = argument (complex number)
!     in = order (integer)
!     w  = function of first kind (complex number)
!
  complex a, w
  dimension az(2), fi(2)
  dimension cd(30), ce(30)
  dimension qz(2), rz(2), sz(2), zr(2)
  dimension ts(2), tm(2), rm(4), sm(4), aq(2), qf(2)
  data cd(1) / 0.00000000000000e00/,  cd(2) /-1.64899505142212e-2/, &
       cd(3) /-7.18621880068536e-2/,  cd(4) /-1.67086878124866e-1/, &
       cd(5) /-3.02582250219469e-1/,  cd(6) /-4.80613945245927e-1/, &
       cd(7) /-7.07075239357898e-1/,  cd(8) /-9.92995790539516e-1/, &
       cd(9) /-1.35583925612592e00/,  cd(10)/-1.82105907899132e00/, &
       cd(11)/-2.42482175310879e00/,  cd(12)/-3.21956655708750e00/, &
       cd(13)/-4.28658077248384e00/,  cd(14)/-5.77022816798128e00/, &
       cd(15)/-8.01371260952526e00/
  data cd(16)/ 0.00000000000000e00/,  cd(17)/-5.57742429879505e-3/, &
       cd(18)/-4.99112944172476e-2/,  cd(19)/-1.37440911652397e-1/, &
       cd(20)/-2.67233784710566e-1/,  cd(21)/-4.40380166808682e-1/, &
       cd(22)/-6.61813614872541e-1/,  cd(23)/-9.41861077665017e-1/, &
       cd(24)/-1.29754130468326e00/,  cd(25)/-1.75407696719816e00/, &
       cd(26)/-2.34755299882276e00/,  cd(27)/-3.13041332689196e00/, &
       cd(28)/-4.18397120563729e00/,  cd(29)/-5.65251799214994e00/, &
       cd(30)/-7.87863959810677e00/
  data ce(1) / 0.00000000000000e00/,  ce(2) /-4.80942336387447e-3/, &
       ce(3) /-1.31366200347759e-2/,  ce(4) /-1.94843834008458e-2/, &
       ce(5) /-2.19948900032003e-2/,  ce(6) /-2.09396625676519e-2/, &
       ce(7) /-1.74600268458650e-2/,  ce(8) /-1.27937813362085e-2/, &
       ce(9) /-8.05234421796592e-3/,  ce(10)/-4.15817375002760e-3/, &
       ce(11)/-1.64317738747922e-3/,  ce(12)/-4.49175585314709e-4/, &
       ce(13)/-7.28594765574007e-5/,  ce(14)/-5.38265230658285e-6/, &
       ce(15)/-9.93779048036289e-8/
  data ce(16)/ 0.00000000000000e00/,  ce(17)/ 7.53805779200591e-2/, &
       ce(18)/ 7.12293537403464e-2/,  ce(19)/ 6.33116224228200e-2/, &
       ce(20)/ 5.28240264523301e-2/,  ce(21)/ 4.13305359441492e-2/, &
       ce(22)/ 3.01350573947510e-2/,  ce(23)/ 2.01043439592720e-2/, &
       ce(24)/ 1.18552223068074e-2/,  ce(25)/ 5.86055510956010e-3/, &
       ce(26)/ 2.25465148267325e-3/,  ce(27)/ 6.08173041536336e-4/, &
       ce(28)/ 9.84215550625747e-5/,  ce(29)/ 7.32139093038089e-6/, &
       ce(30)/ 1.37279667384666e-7/
!     -------------------
  az(1)=real(a)
  az(2)=aimag(a)
  zs=az(1)*az(1)+az(2)*az(2)
  zm=sqrt(zs)
  pn=iabs(in)
  sn=+1.0
  if(az(1))002,003,003
  002 qz(1)=-az(1)
  qz(2)=-az(2)
  if(in == in/2*2)go to 004
  sn=-1.0
  go to 004
  003 qz(1)=az(1)
  qz(2)=az(2)
  004 if(zm <= 17.5+0.5*pn*pn)go to 005
  qn=pn
  go to 011
  005 qn=0.5*zm-0.5*abs(qz(1))+0.5*abs(0.5*zm-abs(qz(1)))
  if(pn <= qn)go to 006
  qn=+aint(0.0625*zs)
  if(pn <= qn)go to 039
  qn=pn
  go to 039
  006 if(zm <= 17.5)go to 007
  qn=+aint(sqrt(2.0*(zm-17.5)))
  go to 011
  007 if(zs-1.0)009,008,008
  008 if(-abs(az(1))+0.096*az(2)*az(2))009,010,010
  009 qn=aint(0.0625*zs)
  if(pn <= qn)go to 039
  qn=pn
  go to 039
  010 qn=0.0
  011 sz(1)=qz(1)
  sz(2)=qz(2)
  qm=sn*0.398942280401433
  zr(1)=sqrt(sz(1)+zm)
  zr(2)=sz(2)/zr(1)
  zr(1)=0.707106781186548*zr(1)
  zr(2)=0.707106781186548*zr(2)
  qf(1)=+qm*zr(1)/zm
  qf(2)=-qm*zr(2)/zm
  if(zm <= 17.5)go to 017
  012 rz(1)=+0.5*qz(1)/zs
  rz(2)=-0.5*qz(2)/zs
  an=qn*qn-0.25
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 014
  013 an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=an*ts(1)/pm
  tm(2)=an*ts(2)/pm
  014 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=an*ts(1)/pm
  tm(2)=an*ts(2)/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 015
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 016
  015 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 013
  016 ts(1)=sm(1)+sm(3)
  ts(2)=sm(2)+sm(4)
  sm(1)=sm(1)-sm(3)
  sm(2)=sm(2)-sm(4)
  sm(3)=ts(1)
  sm(4)=ts(2)
  go to 019
  017 sm(1)=1.0
  sm(2)=0.0
  sm(3)=1.0
  sm(4)=0.0
  m=15.0*qn+2.0
  n=15.0*qn+15.0
  do 018 i=m,n
  ts(1)=-qz(1)-cd(i)
  ts(2)=-qz(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  ts(1)=qz(1)-cd(i)
  ts(2)=qz(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  018 continue
  019 rm(1)=sm(1)
  rm(2)=sm(2)
  if(qz(1) >= 17.5)go to 023
  aq(1)=-2.0*qz(1)
  if(qz(2))020,021,021
  020 aq(2)=-2.0*qz(2)-3.14159265358979*(qn+0.5)
  go to 022
  021 aq(2)=-2.0*qz(2)+3.14159265358979*(qn+0.5)
  022 qm=exp(aq(1))
  ts(1)=qm*cos(aq(2))
  ts(2)=qm*sin(aq(2))
  rm(1)=rm(1)+ts(1)*sm(3)-ts(2)*sm(4)
  rm(2)=rm(2)+ts(1)*sm(4)+ts(2)*sm(3)
  023 if(qn == pn)go to 037
  rm(3)=rm(1)
  rm(4)=rm(2)
  qn=qn+1.0
  if(zm <= 17.5)go to 029
  024 an=qn*qn-0.25
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 026
  025 an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=an*ts(1)/pm
  tm(2)=an*ts(2)/pm
  026 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=an*ts(1)/pm
  tm(2)=an*ts(2)/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 027
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 028
  027 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 025
  028 ts(1)=sm(1)+sm(3)
  ts(2)=sm(2)+sm(4)
  sm(1)=sm(1)-sm(3)
  sm(2)=sm(2)-sm(4)
  sm(3)=ts(1)
  sm(4)=ts(2)
  go to 031
  029 sm(1)=1.0
  sm(2)=0.0
  sm(3)=1.0
  sm(4)=0.0
  m=15.0*qn+2.0
  n=15.0*qn+15.0
  do 030 i=m,n
  ts(1)=-qz(1)-cd(i)
  ts(2)=-qz(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  ts(1)=+qz(1)-cd(i)
  ts(2)=+qz(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  030 continue
  031 rm(1)=sm(1)
  rm(2)=sm(2)
  if(qz(1) >= 17.5)go to 036
  aq(1)=-2.0*qz(1)
  if(qz(2))032,033,033
  032 aq(2)=-2.0*qz(2)-3.14159265358979*(qn+0.5)
  go to 034
  033 aq(2)=-2.0*qz(2)+3.14159265358979*(qn+0.5)
  034 qm=exp(aq(1))
  ts(1)=qm*cos(aq(2))
  ts(2)=qm*sin(aq(2))
  rm(1)=rm(1)+ts(1)*sm(3)-ts(2)*sm(4)
  rm(2)=rm(2)+ts(1)*sm(4)+ts(2)*sm(3)
  go to 036
  035 tm(1)=-2.0*qn*qz(1)/zs
  tm(2)=+2.0*qn*qz(2)/zs
  ts(1)=tm(1)*rm(1)-tm(2)*rm(2)+rm(3)
  ts(2)=tm(1)*rm(2)+tm(2)*rm(1)+rm(4)
  rm(3)=rm(1)
  rm(4)=rm(2)
  rm(1)=ts(1)
  rm(2)=ts(2)
  qn=qn+1.0
  036 if(qn < pn)go to 035
  037 if(mo/=0)go to 038
  qm=exp(qz(1))
  tm(1)=qm*cos(qz(2))
  tm(2)=qm*sin(qz(2))
  ts(1)=tm(1)*rm(1)-tm(2)*rm(2)
  ts(2)=tm(1)*rm(2)+tm(2)*rm(1)
  rm(1)=ts(1)
  rm(2)=ts(2)
  038 fi(1)=qf(1)*rm(1)-qf(2)*rm(2)
  fi(2)=qf(1)*rm(2)+qf(2)*rm(1)
  w=cmplx(fi(1),fi(2))
  return
  039 sz(1)=0.25*(qz(1)*qz(1)-qz(2)*qz(2))
  sz(2)=0.5*qz(1)*qz(2)
  an=qn
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  040 an=an+1.0
  ts(1)=tm(1)/an
  ts(2)=tm(2)/an
  sm(3)=sm(3)+ts(1)
  sm(4)=sm(4)+ts(2)
  tm(1)=ts(1)*sz(1)-ts(2)*sz(2)
  tm(2)=ts(1)*sz(2)+ts(2)*sz(1)
  pm=pm+1.0
  tm(1)=tm(1)/pm
  tm(2)=tm(2)/pm
  if(abs(sm(1))+abs(tm(1))/=abs(sm(1)))go to 041
  if(abs(sm(2))+abs(tm(2)) == abs(sm(2)))go to 042
  041 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  go to 040
  042 sm(1)=sm(1)+1.0
  an=qn+1.0
  sm(3)=an*sm(3)
  sm(4)=an*sm(4)
  go to 044
  043 an=qn*(qn+1.0)
  tm(1)=sz(1)/an
  tm(2)=sz(2)/an
  ts(1)=+tm(1)*sm(3)-tm(2)*sm(4)
  ts(2)=+tm(1)*sm(4)+tm(2)*sm(3)
  sm(3)=sm(1)
  sm(4)=sm(2)
  sm(1)=sm(1)+ts(1)
  sm(2)=sm(2)+ts(2)
  qn=qn-1.0
  044 if(qn > pn)go to 043
  qf(1)=sn
  qf(2)=0.0
  qn=0.0
  go to 046
  045 qn=qn+1.0
  tm(1)=qf(1)*qz(1)-qf(2)*qz(2)
  tm(2)=qf(1)*qz(2)+qf(2)*qz(1)
  qf(1)=0.5*tm(1)/qn
  qf(2)=0.5*tm(2)/qn
  046 if(qn < pn)go to 045
  if(mo == 0)go to 047
  qm=exp(-qz(1))
  tm(1)=qm*cos(-qz(2))
  tm(2)=qm*sin(-qz(2))
  ts(1)=tm(1)*qf(1)-tm(2)*qf(2)
  ts(2)=tm(1)*qf(2)+tm(2)*qf(1)
  qf(1)=ts(1)
  qf(2)=ts(2)
  047 fi(1)=qf(1)*sm(1)-qf(2)*sm(2)
  fi(2)=qf(1)*sm(2)+qf(2)*sm(1)
  w=cmplx(fi(1),fi(2))
  return
end
subroutine bsslj ( a, in, w )
!
!***********************************************************************
!
!! BSSLJ ordinary Bessel function of integral order
!
!     a  = argument (complex number)
!     in = order (integer)
!     w  = function of first kind (complex number)
!
  complex a, w
  dimension az(2), fj(2)
  dimension cd(30), ce(30)
  dimension qz(2), rz(2), sz(2), zr(2)
  dimension ts(2), tm(2), rm(4), sm(4), aq(2), qf(2)
  data cd(1) / 0.00000000000000e00/,  cd(2) /-1.64899505142212e-2/, &
       cd(3) /-7.18621880068536e-2/,  cd(4) /-1.67086878124866e-1/, &
       cd(5) /-3.02582250219469e-1/,  cd(6) /-4.80613945245927e-1/, &
       cd(7) /-7.07075239357898e-1/,  cd(8) /-9.92995790539516e-1/, &
       cd(9) /-1.35583925612592e00/,  cd(10)/-1.82105907899132e00/, &
       cd(11)/-2.42482175310879e00/,  cd(12)/-3.21956655708750e00/, &
       cd(13)/-4.28658077248384e00/,  cd(14)/-5.77022816798128e00/, &
       cd(15)/-8.01371260952526e00/
  data cd(16)/ 0.00000000000000e00/,  cd(17)/-5.57742429879505e-3/, &
       cd(18)/-4.99112944172476e-2/,  cd(19)/-1.37440911652397e-1/, &
       cd(20)/-2.67233784710566e-1/,  cd(21)/-4.40380166808682e-1/, &
       cd(22)/-6.61813614872541e-1/,  cd(23)/-9.41861077665017e-1/, &
       cd(24)/-1.29754130468326e00/,  cd(25)/-1.75407696719816e00/, &
       cd(26)/-2.34755299882276e00/,  cd(27)/-3.13041332689196e00/, &
       cd(28)/-4.18397120563729e00/,  cd(29)/-5.65251799214994e00/, &
       cd(30)/-7.87863959810677e00/
  data ce(1) / 0.00000000000000e00/,  ce(2) /-4.80942336387447e-3/, &
       ce(3) /-1.31366200347759e-2/,  ce(4) /-1.94843834008458e-2/, &
       ce(5) /-2.19948900032003e-2/,  ce(6) /-2.09396625676519e-2/, &
       ce(7) /-1.74600268458650e-2/,  ce(8) /-1.27937813362085e-2/, &
       ce(9) /-8.05234421796592e-3/,  ce(10)/-4.15817375002760e-3/, &
       ce(11)/-1.64317738747922e-3/,  ce(12)/-4.49175585314709e-4/, &
       ce(13)/-7.28594765574007e-5/,  ce(14)/-5.38265230658285e-6/, &
       ce(15)/-9.93779048036289e-8/
  data ce(16)/ 0.00000000000000e00/,  ce(17)/ 7.53805779200591e-2/, &
       ce(18)/ 7.12293537403464e-2/,  ce(19)/ 6.33116224228200e-2/, &
       ce(20)/ 5.28240264523301e-2/,  ce(21)/ 4.13305359441492e-2/, &
       ce(22)/ 3.01350573947510e-2/,  ce(23)/ 2.01043439592720e-2/, &
       ce(24)/ 1.18552223068074e-2/,  ce(25)/ 5.86055510956010e-3/, &
       ce(26)/ 2.25465148267325e-3/,  ce(27)/ 6.08173041536336e-4/, &
       ce(28)/ 9.84215550625747e-5/,  ce(29)/ 7.32139093038089e-6/, &
       ce(30)/ 1.37279667384666e-7/
!     -------------------
  az(1)=real(a)
  az(2)=aimag(a)
  zs=az(1)*az(1)+az(2)*az(2)
  zm=sqrt(zs)
  pn=iabs(in)
  sn=+1.0
  if(in)002,003,003
  002 if(in == in/2*2)go to 003
  sn=-1.0
  003 if(az(1))004,005,005
  004 qz(1)=-az(1)
  qz(2)=-az(2)
  if(in == in/2*2)go to 006
  sn=-sn
  go to 006
  005 qz(1)=+az(1)
  qz(2)=+az(2)
  006 if(zm <= 17.5+0.5*pn*pn)go to 007
  qn=pn
  go to 013
  007 qn=0.5*zm-0.5*abs(qz(2))+0.5*abs(0.5*zm-abs(qz(2)))
  if(pn <= qn)go to 008
  qn=+aint(0.0625*zs)
  if(pn <= qn)go to 031
  qn=pn
  go to 031
  008 if(zm <= 17.5)go to 009
  qn=+aint(sqrt(2.0*(zm-17.5)))
  go to 013
  009 if(zs-1.0)011,010,010
  010 if(-abs(az(2))+0.096*az(1)*az(1))011,012,012
  011 qn=+aint(0.0625*zs)
  if(pn <= qn)go to 031
  qn=pn
  go to 031
  012 qn=0.0
  013 sz(1)=qz(1)
  sz(2)=qz(2)
  qm=sn*0.797884560802865
  zr(1)=sqrt(sz(1)+zm)
  zr(2)=sz(2)/zr(1)
  zr(1)=0.707106781186548*zr(1)
  zr(2)=0.707106781186548*zr(2)
  qf(1)=+qm*zr(1)/zm
  qf(2)=-qm*zr(2)/zm
  if(zm <= 17.5)go to 018
  014 rz(1)=+0.5*qz(1)/zs
  rz(2)=-0.5*qz(2)/zs
  an=qn*qn-0.25
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 016
  015 an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=-an*ts(1)/pm
  tm(2)=-an*ts(2)/pm
  016 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=+an*ts(1)/pm
  tm(2)=+an*ts(2)/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 017
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 020
  017 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 015
  go to 020
  018 sm(1)=1.0
  sm(2)=0.0
  sm(3)=1.0
  sm(4)=0.0
  m=15.0*qn+2.0
  n=15.0*qn+15.0
  do 019 i=m,n
  ts(1)=+qz(2)-cd(i)
  ts(2)=-qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  ts(1)=-qz(2)-cd(i)
  ts(2)=+qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  019 continue
  ts(1)=+0.5*(sm(2)-sm(4))
  ts(2)=-0.5*(sm(1)-sm(3))
  sm(1)=+0.5*(sm(1)+sm(3))
  sm(2)=+0.5*(sm(2)+sm(4))
  sm(3)=ts(1)
  sm(4)=ts(2)
  020 aq(1)=qz(1)-1.57079632679490*(qn+0.5)
  aq(2)=qz(2)
  ts(1)=+cos(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=-sin(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=sm(1)*ts(1)-sm(2)*ts(2)
  tm(2)=sm(1)*ts(2)+sm(2)*ts(1)
  ts(1)=+sin(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=+cos(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  rm(1)=tm(1)-sm(3)*ts(1)+sm(4)*ts(2)
  rm(2)=tm(2)-sm(3)*ts(2)-sm(4)*ts(1)
  if(qn == pn)go to 030
  rm(3)=rm(1)
  rm(4)=rm(2)
  qn=qn+1.0
  if(zm <= 17.5)go to 025
  021 an=qn*qn-0.25
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 023
  022 an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=-an*ts(1)/pm
  tm(2)=-an*ts(2)/pm
  023 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  an=an-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=+an*ts(1)/pm
  tm(2)=+an*ts(2)/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 024
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 027
  024 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 022
  go to 027
  025 sm(1)=1.0
  sm(2)=0.0
  sm(3)=1.0
  sm(4)=0.0
  m=15.0*qn+2.0
  n=15.0*qn+15.0
  do 026 i=m,n
  ts(1)=+qz(2)-cd(i)
  ts(2)=-qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  ts(1)=-qz(2)-cd(i)
  ts(2)=+qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  026 continue
  ts(1)=+0.5*(sm(2)-sm(4))
  ts(2)=-0.5*(sm(1)-sm(3))
  sm(1)=+0.5*(sm(1)+sm(3))
  sm(2)=+0.5*(sm(2)+sm(4))
  sm(3)=ts(1)
  sm(4)=ts(2)
  027 aq(1)=qz(1)-1.57079632679490*(qn+0.5)
  aq(2)=qz(2)
  ts(1)=+cos(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=-sin(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=sm(1)*ts(1)-sm(2)*ts(2)
  tm(2)=sm(1)*ts(2)+sm(2)*ts(1)
  ts(1)=+sin(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=+cos(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  rm(1)=tm(1)-sm(3)*ts(1)+sm(4)*ts(2)
  rm(2)=tm(2)-sm(3)*ts(2)-sm(4)*ts(1)
  go to 029
  028 tm(1)=+2.0*qn*qz(1)/zs
  tm(2)=-2.0*qn*qz(2)/zs
  ts(1)=tm(1)*rm(1)-tm(2)*rm(2)-rm(3)
  ts(2)=tm(1)*rm(2)+tm(2)*rm(1)-rm(4)
  rm(3)=rm(1)
  rm(4)=rm(2)
  rm(1)=ts(1)
  rm(2)=ts(2)
  qn=qn+1.0
  029 if(qn < pn)go to 028
  030 fj(1)=qf(1)*rm(1)-qf(2)*rm(2)
  fj(2)=qf(1)*rm(2)+qf(2)*rm(1)
  w=cmplx(fj(1),fj(2))
  return
  031 sz(1)=+0.25*(qz(1)*qz(1)-qz(2)*qz(2))
  sz(2)=+0.5*qz(1)*qz(2)
  an=qn
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  032 an=an+1.0
  ts(1)=+tm(1)/an
  ts(2)=+tm(2)/an
  sm(3)=sm(3)+ts(1)
  sm(4)=sm(4)+ts(2)
  tm(1)=-ts(1)*sz(1)+ts(2)*sz(2)
  tm(2)=-ts(1)*sz(2)-ts(2)*sz(1)
  pm=pm+1.0
  tm(1)=tm(1)/pm
  tm(2)=tm(2)/pm
  if(abs(sm(1))+abs(tm(1))/=abs(sm(1)))go to 033
  if(abs(sm(2))+abs(tm(2)) == abs(sm(2)))go to 034
  033 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  go to 032
  034 sm(1)=sm(1)+1.0
  an=qn+1.0
  sm(3)=an*sm(3)
  sm(4)=an*sm(4)
  go to 036
  035 an=qn*(qn+1.0)
  tm(1)=sz(1)/an
  tm(2)=sz(2)/an
  ts(1)=-tm(1)*sm(3)+tm(2)*sm(4)
  ts(2)=-tm(1)*sm(4)-tm(2)*sm(3)
  sm(3)=sm(1)
  sm(4)=sm(2)
  sm(1)=sm(1)+ts(1)
  sm(2)=sm(2)+ts(2)
  qn=qn-1.0
  036 if(qn > pn)go to 035
  qf(1)=sn
  qf(2)=0.0
  qn=0.0
  go to 038
  037 qn=qn+1.0
  tm(1)=qf(1)*qz(1)-qf(2)*qz(2)
  tm(2)=qf(1)*qz(2)+qf(2)*qz(1)
  qf(1)=0.5*tm(1)/qn
  qf(2)=0.5*tm(2)/qn
  038 if(qn < pn)go to 037
  fj(1)=qf(1)*sm(1)-qf(2)*sm(2)
  fj(2)=qf(1)*sm(2)+qf(2)*sm(1)
  w=cmplx(fj(1),fj(2))
  return
end
subroutine bsslk (mo, a, in, w)
!
!***********************************************************************
!
!! BSSLK modified Bessel function of integral order
!
!     mo = mode of operation
!     a  = argument (complex number)
!     in = order (integer)
!     w  = function of second kind (complex number)
!     -------------------
  complex a, w
  dimension az(2)
  dimension cd(30), ce(30)
  dimension sz(2), rz(2), zl(2)
  dimension ts(2), tm(2), sm(2), sl(2), sq(2), sr(2), aq(2), qf(2)
  data cd(1) / 0.00000000000000e00/,  cd(2) /-1.64899505142212e-2/, &
       cd(3) /-7.18621880068536e-2/,  cd(4) /-1.67086878124866e-1/, &
       cd(5) /-3.02582250219469e-1/,  cd(6) /-4.80613945245927e-1/, &
       cd(7) /-7.07075239357898e-1/,  cd(8) /-9.92995790539516e-1/, &
       cd(9) /-1.35583925612592e00/,  cd(10)/-1.82105907899132e00/, &
       cd(11)/-2.42482175310879e00/,  cd(12)/-3.21956655708750e00/, &
       cd(13)/-4.28658077248384e00/,  cd(14)/-5.77022816798128e00/, &
       cd(15)/-8.01371260952526e00/
  data cd(16)/ 0.00000000000000e00/,  cd(17)/-5.57742429879505e-3/, &
       cd(18)/-4.99112944172476e-2/,  cd(19)/-1.37440911652397e-1/, &
       cd(20)/-2.67233784710566e-1/,  cd(21)/-4.40380166808682e-1/, &
       cd(22)/-6.61813614872541e-1/,  cd(23)/-9.41861077665017e-1/, &
       cd(24)/-1.29754130468326e00/,  cd(25)/-1.75407696719816e00/, &
       cd(26)/-2.34755299882276e00/,  cd(27)/-3.13041332689196e00/, &
       cd(28)/-4.18397120563729e00/,  cd(29)/-5.65251799214994e00/, &
       cd(30)/-7.87863959810677e00/
  data ce(1) / 0.00000000000000e00/,  ce(2) /-4.80942336387447e-3/, &
       ce(3) /-1.31366200347759e-2/,  ce(4) /-1.94843834008458e-2/, &
       ce(5) /-2.19948900032003e-2/,  ce(6) /-2.09396625676519e-2/, &
       ce(7) /-1.74600268458650e-2/,  ce(8) /-1.27937813362085e-2/, &
       ce(9) /-8.05234421796592e-3/,  ce(10)/-4.15817375002760e-3/, &
       ce(11)/-1.64317738747922e-3/,  ce(12)/-4.49175585314709e-4/, &
       ce(13)/-7.28594765574007e-5/,  ce(14)/-5.38265230658285e-6/, &
       ce(15)/-9.93779048036289e-8/
  data ce(16)/ 0.00000000000000e00/,  ce(17)/ 7.53805779200591e-2/, &
       ce(18)/ 7.12293537403464e-2/,  ce(19)/ 6.33116224228200e-2/, &
       ce(20)/ 5.28240264523301e-2/,  ce(21)/ 4.13305359441492e-2/, &
       ce(22)/ 3.01350573947510e-2/,  ce(23)/ 2.01043439592720e-2/, &
       ce(24)/ 1.18552223068074e-2/,  ce(25)/ 5.86055510956010e-3/, &
       ce(26)/ 2.25465148267325e-3/,  ce(27)/ 6.08173041536336e-4/, &
       ce(28)/ 9.84215550625747e-5/,  ce(29)/ 7.32139093038089e-6/, &
       ce(30)/ 1.37279667384666e-7/
!     -------------------
  az(1)=real(a)
  az(2)=aimag(a)
  zs=az(1)*az(1)+az(2)*az(2)
  zl(1)=0.5*alog(zs)
  zl(2)=atan2(az(2),az(1))
  an=iabs(in)
  tm(1)=0.0
  tm(2)=0.0
  if(mo/=0)go to 002
  tm(1)=az(1)
  tm(2)=az(2)
  002 if(zs-1.0)020,020,003
  003 if(zs-289.0)004,010,010
  004 if(az(1)+0.096*az(2)*az(2))020,020,015
  010 qm=1.25331413731550*exp(-0.5*zl(1)-tm(1))
  qf(1)=qm*cos(-0.5*zl(2)-tm(2))
  qf(2)=qm*sin(-0.5*zl(2)-tm(2))
  if(an > 1.0)go to 012
  pn=an
  assign 011 to la
  go to 100
  011 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  012 pn=1.0
  assign 013 to la
  go to 100
  013 sq(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sq(2)=qf(1)*sm(2)+qf(2)*sm(1)
  pn=0.0
  assign 014 to la
  go to 100
  014 sr(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=qf(1)*sm(2)+qf(2)*sm(1)
  go to 026
  015 qm=1.25331413731550*exp(-0.5*zl(1)-tm(1))
  qf(1)=qm*cos(-0.5*zl(2)-tm(2))
  qf(2)=qm*sin(-0.5*zl(2)-tm(2))
  if(an > 1.0)go to 017
  pn=an
  assign 016 to lr
  go to 104
  016 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  017 pn=1.0
  assign 018 to lr
  go to 104
  018 sq(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sq(2)=qf(1)*sm(2)+qf(2)*sm(1)
  pn=0.0
  assign 019 to lr
  go to 104
  019 sr(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=qf(1)*sm(2)+qf(2)*sm(1)
  go to 026
  020 qf(1)=1.0
  qf(2)=0.0
  if(mo == 0)go to 021
  qm=exp(az(1))
  qf(1)=qm*cos(az(2))
  qf(2)=qm*sin(az(2))
  021 if(an > 1.0)go to 023
  pn=an
  assign 022 to lk
  go to 106
  022 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  023 pn=1.0
  assign 024 to lk
  go to 106
  024 sq(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sq(2)=qf(1)*sm(2)+qf(2)*sm(1)
  pn=0.0
  assign 025 to lk
  go to 106
  025 sr(1)=qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=qf(1)*sm(2)+qf(2)*sm(1)
  026 rz(1)=+az(1)/zs
  rz(2)=-az(2)/zs
  pn=0.0
  go to 028
  027 sq(1)=sr(1)
  sq(2)=sr(2)
  sr(1)=sm(1)
  sr(2)=sm(2)
  028 sm(1)=2.0*pn*(rz(1)*sr(1)-rz(2)*sr(2))+sq(1)
  sm(2)=2.0*pn*(rz(1)*sr(2)+rz(2)*sr(1))+sq(2)
  pn=pn+1.0
  if(pn < an)go to 027
  029 w=cmplx(sm(1),sm(2))
  return
  100 sm(1)=0.0
  sm(2)=0.0
  rz(1)=+0.5*az(1)/zs
  rz(2)=-0.5*az(2)/zs
  qn=(pn-0.5)*(pn+0.5)
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 102
  101 qn=qn-2.0*pm
  pm=pm+1.0
  ts(1)=rz(1)*tm(1)-rz(2)*tm(2)
  ts(2)=rz(1)*tm(2)+rz(2)*tm(1)
  tm(1)=qn*ts(1)/pm
  tm(2)=qn*ts(2)/pm
  if(abs(sm(1))+abs(tm(1))/=abs(sm(1)))go to 102
  if(abs(sm(2))+abs(tm(2)) == abs(sm(2)))go to 103
  102 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  if(pm < 36.0)go to 101
  103 go to la,(011,013,014)
  104 sm(1)=1.0
  sm(2)=0.0
  m=15.0*pn+2.0
  n=15.0*pn+15.0
  do 105 i=m,n
  ts(1)=az(1)-cd(i)
  ts(2)=az(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  105 continue
  go to lr,(016,018,019)
  106 aq(1)=1.0
  aq(2)=0.0
  rn=0.0
  sn=-1.0
  pm=0.0
  go to 108
  107 pm=pm+1.0
  rn=rn+0.5/pm
  sn=-sn
  ts(1)=0.5*(az(1)*aq(1)-az(2)*aq(2))
  ts(2)=0.5*(az(1)*aq(2)+az(2)*aq(1))
  aq(1)=ts(1)/pm
  aq(2)=ts(2)/pm
  108 if(pm < pn)go to 107
  sz(1)=0.25*(az(1)-az(2))*(az(1)+az(2))
  sz(2)=0.5*az(1)*az(2)
  sr(1)=0.0
  sr(2)=0.0
  ss=aq(1)*aq(1)+aq(2)*aq(2)
  tm(1)=+aq(1)/ss
  tm(2)=-aq(2)/ss
  pm=0.0
  go to 110
  109 tm(1)=tm(1)/(pn-pm)
  tm(2)=tm(2)/(pn-pm)
  sr(1)=sr(1)+0.5*tm(1)
  sr(2)=sr(2)+0.5*tm(2)
  pm=pm+1.0
  ts(1)=sz(1)*tm(1)-sz(2)*tm(2)
  ts(2)=sz(1)*tm(2)+sz(2)*tm(1)
  tm(1)=-ts(1)/pm
  tm(2)=-ts(2)/pm
  110 if(pm < pn)go to 109
  sm(1)=0.0
  sm(2)=0.0
  rm=1.0
  qm=0.0
  aq(1)=sn*aq(1)
  aq(2)=sn*aq(2)
  sl(1)=-0.115931515658412+zl(1)-rn
  sl(2)=+zl(2)
  pm=0.0
  go to 112
  111 qm=qm+rm
  pm=pm+1.0
  rm=0.25*zs*rm/(pm*(pn+pm))
  ts(1)=sz(1)*aq(1)-sz(2)*aq(2)
  ts(2)=sz(1)*aq(2)+sz(2)*aq(1)
  aq(1)=ts(1)/(pm*(pn+pm))
  aq(2)=ts(2)/(pm*(pn+pm))
  sl(1)=sl(1)-0.5/pm-0.5/(pn+pm)
  112 tm(1)=aq(1)*sl(1)-aq(2)*sl(2)
  tm(2)=aq(1)*sl(2)+aq(2)*sl(1)
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  if(qm+rm > qm)go to 111
  sm(1)=sr(1)+sm(1)
  sm(2)=sr(2)+sm(2)
  go to lk,(022,024,025)
end
subroutine bssly (a, in, w)
!
!***********************************************************************
!
!! BSSLY ordinary Bessel function of integral order
!
!     a  = argument (complex number)
!     in = order (integer)
!     w  = function of second kind (complex number)
!     -------------------
  complex a, w
  dimension az(2)
  dimension cd(30), ce(30)
  dimension qz(2), rz(2), sz(2), zl(2)
  dimension ts(2), tm(4), sm(4), sl(2), sq(2), sr(2), aq(2), qf(2)
  data cd(1) / 0.00000000000000e00/,  cd(2) /-1.64899505142212e-2/, &
       cd(3) /-7.18621880068536e-2/,  cd(4) /-1.67086878124866e-1/, &
       cd(5) /-3.02582250219469e-1/,  cd(6) /-4.80613945245927e-1/, &
       cd(7) /-7.07075239357898e-1/,  cd(8) /-9.92995790539516e-1/, &
       cd(9) /-1.35583925612592e00/,  cd(10)/-1.82105907899132e00/, &
       cd(11)/-2.42482175310879e00/,  cd(12)/-3.21956655708750e00/, &
       cd(13)/-4.28658077248384e00/,  cd(14)/-5.77022816798128e00/, &
       cd(15)/-8.01371260952526e00/
  data cd(16)/ 0.00000000000000e00/,  cd(17)/-5.57742429879505e-3/, &
       cd(18)/-4.99112944172476e-2/,  cd(19)/-1.37440911652397e-1/, &
       cd(20)/-2.67233784710566e-1/,  cd(21)/-4.40380166808682e-1/, &
       cd(22)/-6.61813614872541e-1/,  cd(23)/-9.41861077665017e-1/, &
       cd(24)/-1.29754130468326e00/,  cd(25)/-1.75407696719816e00/, &
       cd(26)/-2.34755299882276e00/,  cd(27)/-3.13041332689196e00/, &
       cd(28)/-4.18397120563729e00/,  cd(29)/-5.65251799214994e00/, &
       cd(30)/-7.87863959810677e00/
  data ce(1) / 0.00000000000000e00/,  ce(2) /-4.80942336387447e-3/, &
       ce(3) /-1.31366200347759e-2/,  ce(4) /-1.94843834008458e-2/, &
       ce(5) /-2.19948900032003e-2/,  ce(6) /-2.09396625676519e-2/, &
       ce(7) /-1.74600268458650e-2/,  ce(8) /-1.27937813362085e-2/, &
       ce(9) /-8.05234421796592e-3/,  ce(10)/-4.15817375002760e-3/, &
       ce(11)/-1.64317738747922e-3/,  ce(12)/-4.49175585314709e-4/, &
       ce(13)/-7.28594765574007e-5/,  ce(14)/-5.38265230658285e-6/, &
       ce(15)/-9.93779048036289e-8/
  data ce(16)/ 0.00000000000000e00/,  ce(17)/ 7.53805779200591e-2/, &
       ce(18)/ 7.12293537403464e-2/,  ce(19)/ 6.33116224228200e-2/, &
       ce(20)/ 5.28240264523301e-2/,  ce(21)/ 4.13305359441492e-2/, &
       ce(22)/ 3.01350573947510e-2/,  ce(23)/ 2.01043439592720e-2/, &
       ce(24)/ 1.18552223068074e-2/,  ce(25)/ 5.86055510956010e-3/, &
       ce(26)/ 2.25465148267325e-3/,  ce(27)/ 6.08173041536336e-4/, &
       ce(28)/ 9.84215550625747e-5/,  ce(29)/ 7.32139093038089e-6/, &
       ce(30)/ 1.37279667384666e-7/
!     -------------------
  az(1)=real(a)
  az(2)=aimag(a)
  zs=az(1)*az(1)+az(2)*az(2)
  zl(1)=0.5*alog(zs)
  zl(2)=atan2(az(2),az(1))
  an=iabs(in)
  sn=+1.0
  if(in)002,003,003
  002 if(in == in/2*2)go to 003
  sn=-1.0
  003 if(az(1))004,005,005
  004 qz(1)=-az(1)
  qz(2)=-az(2)
  go to 006
  005 qz(1)=+az(1)
  qz(2)=+az(2)
  006 if(zs-1.0)020,020,007
  007 if(zs-289.0)008,010,010
  008 if(-abs(az(2))+0.096*az(1)*az(1))020,020,015
  010 qm=sn*0.797884560802865*exp(-0.5*zl(1))
  qf(1)=qm*cos(-0.5*zl(2))
  qf(2)=qm*sin(-0.5*zl(2))
  if(an > 1.0)go to 012
  pn=an
  assign 011 to la
  go to 100
  011 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  012 pn=1.0
  assign 013 to la
  go to 100
  013 sq(1)=-qf(1)*sm(1)+qf(2)*sm(2)
  sq(2)=-qf(1)*sm(2)-qf(2)*sm(1)
  pn=0.0
  assign 014 to la
  go to 100
  014 sr(1)=+qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=+qf(1)*sm(2)+qf(2)*sm(1)
  go to 026
  015 qm=sn*0.3989422804014327*exp(-0.5*zl(1))
  qf(1)=qm*cos(-0.5*zl(2))
  qf(2)=qm*sin(-0.5*zl(2))
  if(an > 1.0)go to 017
  pn=an
  assign 016 to lr
  go to 112
  016 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  017 pn=1.0
  assign 018 to lr
  go to 112
  018 sq(1)=-qf(1)*sm(1)+qf(2)*sm(2)
  sq(2)=-qf(1)*sm(2)-qf(2)*sm(1)
  pn=0.0
  assign 019 to lr
  go to 112
  019 sr(1)=+qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=+qf(1)*sm(2)+qf(2)*sm(1)
  go to 026
  020 qf(1)=sn*0.6366197723675813
  qf(2)=0.0
  021 if(an > 1.0)go to 023
  pn=an
  assign 022 to ly
  go to 122
  022 ts(1)=qf(1)*sm(1)-qf(2)*sm(2)
  ts(2)=qf(1)*sm(2)+qf(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 029
  023 pn=1.0
  assign 024 to ly
  go to 122
  024 sq(1)=-qf(1)*sm(1)+qf(2)*sm(2)
  sq(2)=-qf(1)*sm(2)-qf(2)*sm(1)
  pn=0.0
  assign 025 to ly
  go to 122
  025 sr(1)=+qf(1)*sm(1)-qf(2)*sm(2)
  sr(2)=+qf(1)*sm(2)+qf(2)*sm(1)
  026 rz(1)=+az(1)/zs
  rz(2)=-az(2)/zs
  pn=0.0
  go to 028
  027 sq(1)=sr(1)
  sq(2)=sr(2)
  sr(1)=sm(1)
  sr(2)=sm(2)
  028 sm(1)=2.0*pn*(rz(1)*sr(1)-rz(2)*sr(2))-sq(1)
  sm(2)=2.0*pn*(rz(1)*sr(2)+rz(2)*sr(1))-sq(2)
  pn=pn+1.0
  if(pn < an)go to 027
  029 w=cmplx(sm(1),sm(2))
  return
  100 sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  rz(1)=+0.5*qz(1)/zs
  rz(2)=-0.5*qz(2)/zs
  qn=pn*pn-0.25
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 102
  101 qn=qn-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=-qn*ts(1)/pm
  tm(2)=-qn*ts(2)/pm
  102 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  qn=qn-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=+qn*ts(1)/pm
  tm(2)=+qn*ts(2)/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 103
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 104
  103 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 101
  104 aq(1)=qz(1)-1.57079632679490*(pn+0.5)
  aq(2)=qz(2)
  ts(1)=+cos(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=-sin(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=sm(1)*ts(1)-sm(2)*ts(2)
  tm(2)=sm(1)*ts(2)+sm(2)*ts(1)
  tm(3)=sm(3)*ts(1)-sm(4)*ts(2)
  tm(4)=sm(3)*ts(2)+sm(4)*ts(1)
  ts(1)=+sin(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=+cos(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=tm(1)-sm(3)*ts(1)+sm(4)*ts(2)
  tm(2)=tm(2)-sm(3)*ts(2)-sm(4)*ts(1)
  tm(3)=tm(3)+sm(1)*ts(1)-sm(2)*ts(2)
  tm(4)=tm(4)+sm(1)*ts(2)+sm(2)*ts(1)
  105 if(az(1))106,110,110
  106 if(az(2))107,108,108
  107 sm(1)=-2.0*tm(1)+tm(4)
  sm(2)=-2.0*tm(2)-tm(3)
  go to 109
  108 sm(1)=-2.0*tm(1)-tm(4)
  sm(2)=-2.0*tm(2)+tm(3)
  109 if(pn == 0.0)go to 111
  sm(1)=-sm(1)
  sm(2)=-sm(2)
  go to 111
  110 sm(1)=tm(3)
  sm(2)=tm(4)
  111 go to la,(011,013,014)
  112 sm(1)=1.0
  sm(2)=0.0
  sm(3)=1.0
  sm(4)=0.0
  m=15.0*pn+2.0
  n=15.0*pn+15.0
  do 113 i=m,n
  ts(1)=+qz(2)-cd(i)
  ts(2)=-qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  ts(1)=-qz(2)-cd(i)
  ts(2)=+qz(1)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+ce(i)*ts(1)/ss
  tm(2)=-ce(i)*ts(2)/ss
  sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  113 continue
  114 aq(1)=qz(1)-1.57079632679490*(pn+0.5)
  aq(2)=qz(2)
  ts(1)=+cos(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=-sin(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=+ts(1)*sm(1)-ts(2)*sm(2)+ts(1)*sm(3)-ts(2)*sm(4)
  tm(2)=+ts(1)*sm(2)+ts(2)*sm(1)+ts(1)*sm(4)+ts(2)*sm(3)
  tm(3)=+ts(1)*sm(2)+ts(2)*sm(1)-ts(1)*sm(4)-ts(2)*sm(3)
  tm(4)=-ts(1)*sm(1)+ts(2)*sm(2)+ts(1)*sm(3)-ts(2)*sm(4)
  ts(1)=+sin(aq(1))*0.5*(exp(+aq(2))+exp(-aq(2)))
  ts(2)=+cos(aq(1))*0.5*(exp(+aq(2))-exp(-aq(2)))
  tm(1)=tm(1)-ts(1)*sm(2)-ts(2)*sm(1)+ts(1)*sm(4)+ts(2)*sm(3)
  tm(2)=tm(2)+ts(1)*sm(1)-ts(2)*sm(2)-ts(1)*sm(3)+ts(2)*sm(4)
  tm(3)=tm(3)+ts(1)*sm(1)-ts(2)*sm(2)+ts(1)*sm(3)-ts(2)*sm(4)
  tm(4)=tm(4)+ts(1)*sm(2)+ts(2)*sm(1)+ts(1)*sm(4)+ts(2)*sm(3)
  115 if(az(1))116,120,120
  116 if(az(2))117,118,118
  117 sm(1)=-2.0*tm(1)+tm(4)
  sm(2)=-2.0*tm(2)-tm(3)
  go to 119
  118 sm(1)=-2.0*tm(1)-tm(4)
  sm(2)=-2.0*tm(2)+tm(3)
  119 if(pn == 0.0)go to 121
  sm(1)=-sm(1)
  sm(2)=-sm(2)
  go to 121
  120 sm(1)=tm(3)
  sm(2)=tm(4)
  121 go to lr,(016,018,019)
  122 aq(1)=1.0
  aq(2)=0.0
  rn=0.0
  pm=0.0
  go to 124
  123 pm=pm+1.0
  rn=rn+0.5/pm
  ts(1)=0.5*(az(1)*aq(1)-az(2)*aq(2))
  ts(2)=0.5*(az(1)*aq(2)+az(2)*aq(1))
  aq(1)=ts(1)/pm
  aq(2)=ts(2)/pm
  124 if(pm < pn)go to 123
  sz(1)=0.25*(az(1)-az(2))*(az(1)+az(2))
  sz(2)=0.5*az(1)*az(2)
  sr(1)=0.0
  sr(2)=0.0
  ss=aq(1)*aq(1)+aq(2)*aq(2)
  tm(1)=+aq(1)/ss
  tm(2)=-aq(2)/ss
  pm=0.0
  go to 126
  125 tm(1)=tm(1)/(pn-pm)
  tm(2)=tm(2)/(pn-pm)
  sr(1)=sr(1)-0.5*tm(1)
  sr(2)=sr(2)-0.5*tm(2)
  pm=pm+1.0
  ts(1)=sz(1)*tm(1)-sz(2)*tm(2)
  ts(2)=sz(1)*tm(2)+sz(2)*tm(1)
  tm(1)=+ts(1)/pm
  tm(2)=+ts(2)/pm
  126 if(pm < pn)go to 125
  sm(1)=0.0
  sm(2)=0.0
  rm=1.0
  qm=0.0
  sl(1)=-0.115931515658412+zl(1)-rn
  sl(2)=+zl(2)
  pm=0.0
  go to 128
  127 qm=qm+rm
  pm=pm+1.0
  rm=0.25*zs*rm/(pm*(pn+pm))
  ts(1)=sz(1)*aq(1)-sz(2)*aq(2)
  ts(2)=sz(1)*aq(2)+sz(2)*aq(1)
  aq(1)=-ts(1)/(pm*(pn+pm))
  aq(2)=-ts(2)/(pm*(pn+pm))
  sl(1)=sl(1)-0.5/pm-0.5/(pn+pm)
  128 tm(1)=aq(1)*sl(1)-aq(2)*sl(2)
  tm(2)=aq(1)*sl(2)+aq(2)*sl(1)
  sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  if(qm+rm > qm)go to 127
  sm(1)=sr(1)+sm(1)
  sm(2)=sr(2)+sm(2)
  go to ly,(022,024,025)
end
subroutine bstrp (tau, gtau, t, n, k, bcoef, q, iflag)
!
!***********************************************************************
!
!! BSTRP produces the b-spline coeff.s bcoef of the piecewise
!   polynomial of order k with knots t(i) (i=1,...,n+k) which has the
!   value gtau(i) at tau(i) for i=1,...,n.
!
!******  i n p u t  ******
!
!  tau.....array of length  n , containing data point abscissae.
!    a s s u m p t i o n . . .  tau  is strictly increasing
!  gtau.....corresponding array of length  n , containing data point
!        ordinates.
!  t.....knot sequence, of length  n+k
!  n.....number of data points and dimension of spline space  s(k,t)
!  k.....order of the piecewise polynomial
!  iflag.....on an initial call to the routine, iflag may be assigned
!        any value except 0. the routine may be recalled when only gtau
!        is modified. iflag=0 when this is done.
!
!******  o u t p u t  ******
!
!  bcoef.....the b-coefficients of the interpolant, of length  n
!  q.....array of size  (2*k-1)*n , containing the triangular factoriz-
!        ation of the coefficient matrix of the linear system for the b-
!        coefficients of the spline interpolant.
!  iflag.....an integer indicating success (= 0)  or failure (= 1)
!        the linear system to be solved is (theoretically) invertible if
!        and only if
!              b(i)(tau(i)) /= 0   for all i.
!        violation of this condition is certain to lead to iflag = 1.
!
!******  m e t h o d  ******
!
!     the i-th equation of the linear system  a*bcoef = b  for the b-co-
!  effs of the interpolant enforces interpolation at  tau(i), i=1,...,n.
!  hence,  b(i) = gtau(i), all i, and  a  is a band matrix with  2k-1
!  bands (if it is invertible).
!     the matrix  a  is generated row by row and stored, diagonal by di-
!  agonal, in the  r o w s  of the array  q , with the main diagonal go-
!  ing into row  k .  see comments in the program below.
!     the banded system is then solved by a call to banfac (which con-
!  structs the triangular factorization for  a  and stores it in  q),
!  followed by a call to banslv (which then obtains the solution bcoef
!  by substitution).
!     banfac performs no pivoting since the total positivity of the
!  matrix a makes this unnecessary.
!-----------------------------------------------------------------------
  real bcoef(n), gtau(n), q(*), t(*), tau(n), taui
!
  km1 = k - 1
  if (iflag == 0) go to 50
  np1 = n + 1
  npk = n + k
  kpkm2 = 2*km1
!
!                zero out all entries of q
!
  lenq = n*(k + km1)
  do 10 i = 1,lenq
     q(i) = 0.0
   10 continue
!
!  ***   loop over i to construct the n interpolation equations
!
  left = k
  do 41 i = 1,n
     taui = tau(i)
     ilp1mx = min (i + k,np1)
!
!        *** find  left  in the closed interval (i,i+k-1) such that
!                t(left) <= tau(i) < t(left+1)
!        matrix is singular if this is not possible
!
     left = max (left,i)
     if (taui < t(left)) go to 100
   20       if (taui < t(left+1)) go to 30
        left = left + 1
        if (left < ilp1mx) go to 20
     if (left == i + k) go to 100
     if (i < n) go to 100
!
     if (taui > t(np1)) go to 100
     left = n
     if (t(n) >= t(np1)) go to 100
!
!        *** the i-th equation enforces interpolation at taui, hence
!        a(i,j) = b(j,k,t)(taui), all j. only the  k  entries with  j =
!        left-k+1,...,left actually might be nonzero. these  k  numbers
!        are returned, in  bcoef (used for temp.storage here), by the
!        following
!
   30    call bspev(t,npk,taui,left,0,k,bcoef,iflag)
!
!        let q denote a two-dimensional array of dimension (2*k-1,n).
!        we therefore want  bcoef(j) = b(left-k+j)(taui) to go into
!        a(i,left-k+j), i.e., into  q(i-(left+j)+2*k,(left+j)-k) since
!        a(i+j,j)  is to go into  q(i+k,j), all i,j.  in the current
!        routine we treat q as an equivalent one-dimensional array.
!        thus we want bcoef(j) to be inserted into entry
!            i - (left+j) + 2*k + ((left+j) - k-1)*(2*k-1)
!                   =  i-left+1 + (left - k)*(2*k-1) + (2*k-2)*j
!        of  q .
!
     jj = i - left + 1 + (left - k)*(k + km1)
     do 40 j = 1,k
        jj = jj + kpkm2
        q(jj) = bcoef(j)
   40    continue
   41 continue
!
!     ***obtain factorization of  a  , stored again in  q.
!
  call banfac (q, k + km1, n, km1, km1, iflag)
  iflag = iflag - 1
  if (iflag /= 0) return
!
!     *** solve  a*bcoef = gtau  by backsubstitution
!
   50 do 51 i = 1,n
     bcoef(i) = gtau(i)
   51 continue
  call banslv (q, k + km1, n, km1, km1, bcoef)
  return
!
!     *** error return
!
  100 iflag = 1
  return
end
subroutine bsubt(m,n,a,ka,ml,mu,b,kb,nl,nu,c,kc,l,mcl,mcu,ierr)
!
!***********************************************************************
!
!! BSUBT subtraction of real banded matrices
!
  real a(ka,*), b(kb,*), c(kc,l)
!
!     subtraction of the diagonals below the main diagonals
!     and subtraction of the main diagonals
!
  ierr = 0
  if (nl - ml) 10,30,20
!
   10 if (ml >= l) go to 200
  mcl = ml
  ja = ml - nl
  jb = 0
  jc = ja
  jmax = nl + 1
  do 12 j = 1,jc
    do 11 i = 1,m
   11   c(i,j) = a(i,j)
   12 continue
  go to 60
!
   20 if (nl >= l) go to 210
  mcl = nl
  ja = 0
  jb = nl - ml
  jc = jb
  jmax = ml + 1
  do 22 j = 1,jc
    do 21 i = 1,m
   21   c(i,j) = -b(i,j)
   22 continue
  go to 60
!
   30 mcl = ml
  if (ml == 0) go to 40
  imin = ml + 1
  do 32 j = 1,ml
    do 31 i = imin,m
    if (a(i,j) - b(i,j) /= 0.0) go to 50
   31   continue
  mcl = mcl - 1
   32 imin = imin - 1
!
   40 ja = ml
  jb = ml
  jc = 0
  jmax = 1
  go to 60
!
   50 ja = j - 1
  jb = ja
  jc = 0
  jmax = ml + 1 - ja
  if (jmax > l) go to 220
!
   60 do 62 j = 1,jmax
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 61 i = 1,m
   61   c(i,jc) = a(i,ja) - b(i,jb)
   62 continue
!
!     subtraction of the diagonals above the main diagonals
!
  if (nu - mu) 100,140,120
!
  100 if (jc + mu > l) go to 230
  mcu = mu
  if (nu == 0) go to 110
  do 102 j = 1,nu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 101 i = 1,m
  101   c(i,jc) = a(i,ja) - b(i,jb)
  102 continue
!
  110 jmax = mu - nu
  do 112 j = 1,jmax
  ja = ja + 1
  jc = jc + 1
    do 111 i = 1,m
  111   c(i,jc) = a(i,ja)
  112 continue
  return
!
  120 if (jc + nu > l) go to 240
  mcu = nu
  if (mu == 0) go to 130
  do 122 j = 1,mu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 121 i = 1,m
  121   c(i,jc) = a(i,ja) - b(i,jb)
  122 continue
!
  130 jmax = nu - mu
  do 132 j = 1,jmax
  jb = jb + 1
  jc = jc + 1
    do 131 i = 1,m
  131   c(i,jc) = -b(i,jb)
  132 continue
  return
!
  140 mcu = mu
  if (mu == 0) return
  la = ml + mu + 1
  lb = nl + nu + 1
  do 142 j = 1,mu
  imax = min (m,n-mcu)
    do 141 i = 1,imax
    if (a(i,la) - b(i,lb) /= 0.0) go to 150
  141   continue
  mcu = mcu - 1
  la = la - 1
  142 lb = lb - 1
  return
!
  150 if (jc + mcu > l) go to 250
  do 152 j = 1,mcu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 151 i = 1,m
  151   c(i,jc) = a(i,ja) - b(i,jb)
  152 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = ml + 1
  return
  210 ierr = nl + 1
  return
  220 ierr = jmax
  return
  230 ierr = jc + mu
  return
  240 ierr = jc + nu
  return
  250 ierr = jc + mcu
  return
end
subroutine btprd(m,n,a,ka,ml,mu,x,y)
!
!***********************************************************************
!
!! BTPRD product of a real vector and a real banded matrix
!
  real a(ka,*), x(m), y(n)
  double precision dsum
!
!     compute the first mu components
!
  jcol = ml + 1
  if (mu == 0) go to 20
  do 11 j = 1,mu
  kmax = min (m,j+ml)
  jj = jcol
  dsum = 0.d0
    do 10 k = 1,kmax
    dsum = dsum + dble(a(k,jj))*dble(x(k))
   10   jj = jj - 1
  y(j) = dsum
   11 jcol = jcol + 1
!
!     compute the remaining nonzero components
!
   20 jmin = mu + 1
  jmax = min (n,m+mu)
  do 22 j = jmin,jmax
  kmin = j - mu
  kmax = min (m,j+ml)
  jj = jcol
  dsum = 0.d0
    do 21 k = kmin,kmax
    dsum = dsum + dble(a(k,jj))*dble(x(k))
   21   jj = jj - 1
   22 y(j) = dsum
!
!     store zeros in the final n-jmax components
!
  if (jmax == n) return
  jmin = jmax + 1
  do 30 j = jmin,n
   30 y(j) = 0.0
  return
end
subroutine btprd1(m,n,a,ka,ml,mu,x,y)
!
!***********************************************************************
!
!! BTPRD1 setting y = x*a + y where a is a real banded matrix and
!     x,y are real vectors
!     ******************************************************************
  real a(ka,*), x(m), y(n)
  double precision dsum
!
!     compute the first mu components
!
  jcol = ml + 1
  if (mu == 0) go to 20
  do 11 j = 1,mu
  kmax = min (m,j+ml)
  jj = jcol
  dsum = y(j)
    do 10 k = 1,kmax
    dsum = dsum + dble(a(k,jj))*dble(x(k))
   10   jj = jj - 1
  y(j) = dsum
   11 jcol = jcol + 1
!
!     compute the remaining components
!
   20 jmin = mu + 1
  jmax = min (n,m+mu)
  do 22 j = jmin,jmax
  kmin = j - mu
  kmax = min (m,j+ml)
  jj = jcol
  dsum = y(j)
    do 21 k = kmin,kmax
    dsum = dsum + dble(a(k,jj))*dble(x(k))
   21   jj = jj - 1
   22 y(j) = dsum
  return
end
subroutine btslv(mo, m, n, a, b, c, x, ip, ierr)
!
!***********************************************************************
!
!! BTSLV ???
!
  integer mo, m , n, ip(m,n)
  real a(m,m,n), b(m,m,n), c(m,m,n), x(*)
!
!     decompose the coefficient matrix
!
  if (mo /= 0) go to 10
  call decbt(m, n, a, b, c, ip, ierr)
  if (ierr /= 0) return
!
!     solve the system of equations
!
   10 call solbt(m, n, a, b, c, x, ip)
  return
end
function bup(a, b, x, y, n, eps)
!
!***********************************************************************
!
!! BUP evaluation of ix(a,b) - ix(a+n,b) where n is a positive integer.
!     eps is the tolerance used.
!
  real bup
  real l
!
!          obtain the scaling factor exp(-mu) and
!             exp(mu)*(x**a*y**b/beta(a,b))/a
!
  apb = a + b
  ap1 = a + 1.0
  mu = 0
  d = 1.0
  if (n == 1 .or. a < 1.0) go to 10
  if (apb < 1.1*ap1) go to 10
     mu = abs(exparg(1))
     k = exparg(0)
     if (k < mu) mu = k
     t = mu
     d = exp(-t)
!
   10 bup = brcmp1(mu,a,b,x,y)/a
  if (n == 1 .or. bup == 0.0) return
  nm1 = n - 1
  w = d
!
!          let k be the index of the maximum term
!
  k = 0
  if (b <= 1.0) go to 40
  if (y > 1.e-4) go to 20
     k = nm1
     go to 30
   20 r = (b - 1.0)*x/y - a
  if (r < 1.0) go to 40
  k = nm1
  t = nm1
  if (r < t) k = r
!
!          add the increasing terms of the series
!
   30 do 31 i = 1,k
     l = i - 1
     d = ((apb + l)/(ap1 + l))*x*d
     w = w + d
   31 continue
  if (k == nm1) go to 50
!
!          add the remaining terms of the series
!
   40 kp1 = k + 1
  do 41 i = kp1,nm1
     l = i - 1
     d = ((apb + l)/(ap1 + l))*x*d
     w = w + d
     if (d <= eps*w) go to 50
   41 continue
!
!               terminate the procedure
!
   50 bup = bup*w
  return
end
subroutine bupd(a1, a2, p1, p2, v1, v2, ii, k1, k2, n, m, np1)
!
!***********************************************************************
!
!! BUPD backtracking step updating
!
  integer a1(m), a2(m), p1(np1), p2(np1), v1(n), v2(n)
!
  l1 = p1(ii) + 1
  l2 = p1(ii+1)
  do 30 l=l1,l2
    if (a1(l) > k1) go to 30
    if (a1(l) < k2) go to 30
    ia = k1 - a1(l)
    a1(l) = ia
    v1(ii) = v1(ii) + 1
    ll1 = p2(ia) + 1
    ll2 = p2(ia+1)
    do 10 ll=ll1,ll2
      if (k1-a2(ll) == ii) go to 20
   10   continue
   20   a2(ll) = ii
    v2(ia) = v2(ia) + 1
   30 continue
  return
end
subroutine bvip (md,ncp,ndp,xd,yd,zd,nip,xi,yi,zi, &
                      iwk,wk,ierr)
!
!***********************************************************************
!
!! BVIP performs bivariate interpolation when the pro-
! jections of the data points in the x-y plane are irregularly
! distributed in the plane.
! the input parameters are
!     md  = mode of computation (must be 1, 2, or 3),
!         = 1 for new ncp and/or new xd-yd,
!         = 2 for old ncp, old xd-yd, new xi-yi,
!         = 3 for old ncp, old xd-yd, old xi-yi,
!     ncp = number of additional data points used for esti-
!           mating partial derivatives at each data point
!           (must be 2 or greater, but smaller than ndp),
!     ndp = number of data points (must be 4 or greater),
!     xd  = array of dimension ndp containing the x
!           coordinates of the data points,
!     yd  = array of dimension ndp containing the y
!           coordinates of the data points,
!     zd  = array of dimension ndp containing the z
!           coordinates of the data points,
!     nip = number of output points at which interpolation
!           is to be performed (must be 1 or greater),
!     xi  = array of dimension nip containing the x
!           coordinates of the output points,
!     yi  = array of dimension nip containing the y
!           coordinates of the output points.
! the output parameters are
!     zi  = array of dimension nip where interpolated z
!           values are to be stored.
!     ierr = error indicator. ierr is set to 0 if no errors
!           are detected.
! the other parameters are
!     iwk = integer array of dimension
!              max (31,27+ncp)*ndp+nip
!           used internally as a work area,
!     wk  = array of dimension 8*ndp used internally as a
!           work area.
! error return
!     ierr = 1      md is not 1, 2, or 3.
!     ierr = 2      either  2 <= ncp < ndp  or  ncp <= ncpmx
!                   is violated.
!     ierr = 3      ndp is less than 4.
!     ierr = 4      nip is less than 1.
!     ierr = 5      ncp or ndp is modified. this cannot be
!                   done when md = 2 or 3.
!     ierr = 6      nip is modified. this cannot be done when
!                   md = 3.
!     ierr = 7      points (xd(i),yd(i)) and (xd(j),yd(j))
!                   are equal or are too close where
!                   iwk(1) = i and iwk(2) = j.
!     ierr = 8      the points in xd,yd,zd are collinear or
!                   are almost collinear.
! the very first call to this subroutine and the call with a new
! ncp value, a new ndp value, and/or new contents of the xd and
! yd arrays must be made with md=1.  the call with md=2 must be
! preceded by another call with the same ncp and ndp values and
! with the same contents of the xd and yd arrays.  the call with
! md=3 must be preceded by another call with the same ncp, ndp,
! and nip values and with the same contents of the xd, yd, xi,
! and yi arrays.  between the call with md=2 or md=3 and its
! preceding call, the iwk and wk arrays must not be disturbed.
! use of a value between 3 and 5 (inclusive) for ncp is recom-
! mended unless there are evidences that dictate otherwise.
! this subroutine calls the idcldp, idlctn, idpdrv, idptip, and
! idtang subroutines.
!
  dimension   xd(ndp),yd(ndp),zd(ndp),xi(nip),yi(nip), &
              zi(nip),iwk(*),wk(*)
  common/idlc/itipv,dmmy1(4),ntsc(9)
  common/idpi/itpv,dmmy(27)
!
! setting of some input parameters to local variables.
! (for md=1,2,3)
   10 md0=md
  ncp0=ncp
  ndp0=ndp
  nip0=nip
! error check.  (for md=1,2,3)
   20 ierr=0
  if(md0 < 1.or.md0 > 3)           go to 90
  if(ncp0 < 2.or.ncp0 >= ndp0)      go to 91
  if(ndp0 < 4)                      go to 92
  if(nip0 < 1)                      go to 93
  if(md0 >= 2)        go to 21
  iwk(1)=ncp0
  iwk(2)=ndp0
  go to 22
   21 ncppv=iwk(1)
  ndppv=iwk(2)
  if(ncp0/=ncppv)   go to 94
  if(ndp0/=ndppv)   go to 94
   22 if(md0 >= 3)        go to 23
  iwk(3)=nip
  go to 30
   23 nippv=iwk(3)
  if(nip0/=nippv)   go to 95
! allocation of storage areas in the iwk array.  (for md=1,2,3)
   30 jwipt=16
  jwiwl=6*ndp0+1
  jwiwk=jwiwl
  jwipl=24*ndp0+1
  jwiwp=30*ndp0+1
  jwipc=27*ndp0+1
  jwit0=max (31,27+ncp0)*ndp0
! triangulates the x-y plane.  (for md=1)
   40 if(md0 > 1)   go to 41
  call idtang(ndp0,xd,yd,nt,iwk(jwipt),nl,iwk(jwipl), &
              iwk(jwiwl),iwk(jwiwp),wk,ierr)
  if (ierr/=0) go to 96
  iwk(5)=nt
  iwk(6)=nl
  go to 50
   41 nt=iwk(5)
  nl=iwk(6)
! determines ncp points closest to each data point.  (for md=1)
   50 if(md0 > 1)   go to 60
  call idcldp(ndp0,xd,yd,ncp0,iwk(jwipc),ierr)
  if (ierr/=0) return
! locates all points at which interpolation is to be performed.
! (for md=1,2)
   60 if(md0 == 3)   go to 70
  itipv=0
  jwit=jwit0
  do 61  iip=1,nip0
    jwit=jwit+1
    call idlctn(ndp0,xd,yd,nt,iwk(jwipt),nl,iwk(jwipl), &
              xi(iip),yi(iip),iwk(jwit),iwk(jwiwk),wk)
   61 continue
! estimates partial derivatives at all data points.
! (for md=1,2,3)
   70 call idpdrv(ndp0,xd,yd,zd,ncp0,iwk(jwipc),wk)
! interpolates the zi values.  (for md=1,2,3)
   80 itpv=0
  jwit=jwit0
  do 81  iip=1,nip0
    jwit=jwit+1
    call idptip(xd,yd,zd,nt,iwk(jwipt),nl,iwk(jwipl),wk, &
                iwk(jwit),xi(iip),yi(iip),zi(iip))
   81 continue
  return
! error exit
   90 ierr=1
  return
   91 ierr=2
  return
   92 ierr=3
  return
   93 ierr=4
  return
   94 ierr=5
  return
   95 ierr=6
  return
   96 if (ierr/=7) return
  iwk(1)=iwk(jwiwp)
  iwk(2)=iwk(jwiwp+1)
  return
end
subroutine  bvip2 (md,ncp,ndp,xd,yd,zd,nxi,nyi,xi,yi,zi, &
                        iwk,wk,ierr)
!
!***********************************************************************
!
!! BVIP2 performs smooth surface fitting when the pro-
! jections of the data points in the x-y plane are irregularly
! distributed in the plane.
! the input parameters are
!     md  = mode of computation (must be 1, 2, or 3),
!         = 1 for new ncp and/or new xd-yd,
!         = 2 for old ncp, old xd-yd, new xi-yi,
!         = 3 for old ncp, old xd-yd, old xi-yi,
!     ncp = number of additional data points used for esti-
!           mating partial derivatives at each data point
!           (must be 2 or greater, but smaller than ndp),
!     ndp = number of data points (must be 4 or greater),
!     xd  = array of dimension ndp containing the x
!           coordinates of the data points,
!     yd  = array of dimension ndp containing the y
!           coordinates of the data points,
!     zd  = array of dimension ndp containing the z
!           coordinates of the data points,
!     nxi = number of output grid points in the x coordinate
!           (must be 1 or greater),
!     nyi = number of output grid points in the y coordinate
!           (must be 1 or greater),
!     xi  = array of dimension nxi containing the x
!           coordinates of the output grid points,
!     yi  = array of dimension nyi containing the y
!           coordinates of the output grid points.
! the output parameters are
!     zi  = doubly-dimensioned array of dimension (nxi,nyi),
!           where the interpolated z values at the output
!           grid points are to be stored.
!     ierr = error indicator. ierr is set to 0 if no errors
!           are detected.
! the other parameters are
!     iwk = integer array of dimension
!              max (31,27+ncp)*ndp+nxi*nyi
!           used internally as a work area,
!     wk  = array of dimension 5*ndp used internally as a
!           work area.
! error return
!     ierr = 1      md is not 1, 2, or 3.
!     ierr = 2      either  2 <= ncp < ndp  or  ncp <= ncpmx
!                   is violated.
!     ierr = 3      ndp is less than 4.
!     ierr = 4      nxi or nyi is less than 1.
!     ierr = 5      ncp or ndp is modified. this cannot be
!                   done when md = 2 or 3.
!     ierr = 6      nxi or nyi is modified. this cannot be
!                   done when md = 3.
!     ierr = 7      points (xd(i),yd(i)) and (xd(j),yd(j))
!                   are equal or are too close where
!                   iwk(1) = i and iwk(2) = j.
!     ierr = 8      the points in xd,yd,zd are collinear or
!                   are almost collinear.
! the very first call to this subroutine and the call with a new
! ncp value, a new ndp value, and/or new contents of the xd and
! yd arrays must be made with md=1.  the call with md=2 must be
! preceded by another call with the same ncp and ndp values and
! with the same contents of the xd and yd arrays.  the call with
! md=3 must be preceded by another call with the same ncp, ndp,
! nxi, and nyi values and with the same contents of the xd, yd,
! xi, and yi arrays.  between the call with md=2 or md=3 and its
! preceding call, the iwk and wk arrays must not be disturbed.
! use of a value between 3 and 5 (inclusive) for ncp is recom-
! mended unless there are evidences that dictate otherwise.
! this subroutine calls the idcldp, idgrid, idpdrv, idptip, and
! idtang subroutines.
!
  dimension   xd(ndp),yd(ndp),zd(ndp),xi(nxi),yi(nyi), &
              zi(*),iwk(*),wk(*)
  common/idpi/itpv,dmmy(27)
!
! setting of some input parameters to local variables.
! (for md=1,2,3)
   10 md0=md
  ncp0=ncp
  ndp0=ndp
  nxi0=nxi
  nyi0=nyi
! error check.  (for md=1,2,3)
   20 ierr=0
  if(md0 < 1.or.md0 > 3)           go to 90
  if(ncp0 < 2.or.ncp0 >= ndp0)      go to 91
  if(ndp0 < 4)                      go to 92
  if(nxi0 < 1.or.nyi0 < 1)         go to 93
  if(md0 >= 2)        go to 21
  iwk(1)=ncp0
  iwk(2)=ndp0
  go to 22
   21 ncppv=iwk(1)
  ndppv=iwk(2)
  if(ncp0/=ncppv)   go to 94
  if(ndp0/=ndppv)   go to 94
   22 if(md0 >= 3)        go to 23
  iwk(3)=nxi0
  iwk(4)=nyi0
  go to 30
   23 nxipv=iwk(3)
  nyipv=iwk(4)
  if(nxi0/=nxipv)   go to 95
  if(nyi0/=nyipv)   go to 95
! allocation of storage areas in the iwk array.  (for md=1,2,3)
   30 jwipt=16
  jwiwl=6*ndp0+1
  jwngp0=jwiwl-1
  jwipl=24*ndp0+1
  jwiwp=30*ndp0+1
  jwipc=27*ndp0+1
  jwigp0=max (31,27+ncp0)*ndp0
! triangulates the x-y plane.  (for md=1)
   40 if(md0 > 1)   go to 41
  call idtang(ndp0,xd,yd,nt,iwk(jwipt),nl,iwk(jwipl), &
              iwk(jwiwl),iwk(jwiwp),wk,ierr)
  if (ierr/=0) go to 96
  iwk(5)=nt
  iwk(6)=nl
  go to 50
   41 nt=iwk(5)
  nl=iwk(6)
! determines ncp points closest to each data point.  (for md=1)
   50 if(md0 > 1)   go to 60
  call idcldp(ndp0,xd,yd,ncp0,iwk(jwipc),ierr)
  if (ierr/=0) return
! sorts output grid points in ascending order of the triangle
! number and the border line segment number.  (for md=1,2)
   60 if(md0 == 3)   go to 70
  call idgrid(xd,yd,nt,iwk(jwipt),nl,iwk(jwipl),nxi0,nyi0, &
              xi,yi,iwk(jwngp0+1),iwk(jwigp0+1))
! estimates partial derivatives at all data points.
! (for md=1,2,3)
   70 call idpdrv(ndp0,xd,yd,zd,ncp0,iwk(jwipc),wk)
! interpolates the zi values.  (for md=1,2,3)
   80 itpv=0
  jig0mx=0
  jig1mn=nxi0*nyi0+1
  nngp=nt+2*nl
  do 89  jngp=1,nngp
    iti=jngp
    if(jngp <= nt)    go to 81
    il1=(jngp-nt+1)/2
    il2=(jngp-nt+2)/2
    if(il2 > nl)     il2=1
    iti=il1*(nt+nl)+il2
   81   jwngp=jwngp0+jngp
    ngp0=iwk(jwngp)
    if(ngp0 == 0)     go to 86
    jig0mn=jig0mx+1
    jig0mx=jig0mx+ngp0
    do 82  jigp=jig0mn,jig0mx
      jwigp=jwigp0+jigp
      izi=iwk(jwigp)
      iyi=(izi-1)/nxi0+1
      ixi=izi-nxi0*(iyi-1)
      call idptip(xd,yd,zd,nt,iwk(jwipt),nl,iwk(jwipl),wk, &
                  iti,xi(ixi),yi(iyi),zi(izi))
   82   continue
   86   jwngp=jwngp0+2*nngp+1-jngp
    ngp1=iwk(jwngp)
    if(ngp1 == 0)     go to 89
    jig1mx=jig1mn-1
    jig1mn=jig1mn-ngp1
    do 87  jigp=jig1mn,jig1mx
      jwigp=jwigp0+jigp
      izi=iwk(jwigp)
      iyi=(izi-1)/nxi0+1
      ixi=izi-nxi0*(iyi-1)
      call idptip(xd,yd,zd,nt,iwk(jwipt),nl,iwk(jwipl),wk, &
                  iti,xi(ixi),yi(iyi),zi(izi))
   87   continue
   89 continue
  return
! error exit
   90 ierr=1
  return
   91 ierr=2
  return
   92 ierr=3
  return
   93 ierr=4
  return
   94 ierr=5
  return
   95 ierr=6
  return
   96 if (ierr/=7) return
  iwk(1)=iwk(jwiwp)
  iwk(2)=iwk(jwiwp+1)
  return
end
subroutine bvprd(m,n,a,ka,ml,mu,x,y)
!
!***********************************************************************
!
!! BVPRD product of a real banded matrix and a real vector
!
  real a(ka,*), x(n), y(m)
  double precision dsum
!
!     compute the first ml components
!
  mlp1 = ml + 1
  if (ml == 0) go to 20
  jmin = mlp1
  do 11 i = 1,ml
  kmax = min (n,i+mu)
  kk = jmin
  dsum = 0.d0
    do 10 k = 1,kmax
    dsum = dsum + dble(a(i,kk))*dble(x(k))
   10   kk = kk + 1
  y(i) = dsum
   11 jmin = jmin - 1
!
!     compute the remaining nonzero components
!
   20 imax = min (m,n+ml)
  do 22 i = mlp1,imax
  kmin = i - ml
  kmax = min (n,i+mu)
  kk = 1
  dsum = 0.d0
    do 21 k = kmin,kmax
    dsum = dsum + dble(a(i,kk))*dble(x(k))
   21   kk = kk + 1
   22 y(i) = dsum
!
!     store zeros in the final m-imax components
!
  if (imax == m) return
  imin = imax + 1
  do 30 i = imin,m
   30 y(i) = 0.0
  return
end
subroutine bvprd1(m,n,a,ka,ml,mu,x,y)
!
!***********************************************************************
!
!! BVPRD1 sets y = a*x + y where a is a banded matrix, x and y are vectors.
!
  real a(ka,*), x(n), y(m)
  double precision dsum
!
!     compute the first ml components
!
  mlp1 = ml + 1
  jmin = mlp1
  do i = 1,ml
    kmax = min (n,i+mu)
    kk = jmin
    dsum = y(i)
    do k = 1,kmax
      dsum = dsum + dble(a(i,kk))*dble(x(k))
      kk = kk + 1
    end do
    y(i) = dsum
    jmin = jmin - 1
  end do
!
!     compute the remaining components
!
  imax = min (m,n+ml)

  do i = mlp1,imax
    kmin = i - ml
    kmax = min (n,i+mu)
    kk = 1
    dsum = y(i)
    do k = kmin,kmax
      dsum = dsum + dble(a(i,kk))*dble(x(k))
      kk = kk + 1
    end do
    y(i) = dsum
  end do

  return
end
subroutine cai(ind,z,ai,aip,ierr)
!
!*******************************************************************************
!
!! CAI calculates the airy function ai and its derivative aip
!     for complex argument z.
!
  complex z,ai,bi,aip,bip
  ierr = 0
  a = real(z)
  b = aimag(z)
  r = cpabs(a,b)
  if(r > 1.0) go to 10
!
!     maclaurin expansion
!
     call airm(ind,z,ai,aip,bi,bip)
     return
   10 if(r > 10.0) go to 20
!
!     intermediate range calculation
!
     call aii(ind,z,ai,aip,ierr)
     return
!
!     asymptotic expansion
!
   20 call aia(ind,z,ai,aip,ierr)
  return
end
subroutine calcsc(type, n, k, qk)
!
!*******************************************************************************
!
!! CALCSC calculates scalar quantities used to
!     compute the next k polynomial and new estimates of
!     the quadratic coefficients.
!
!     type - integer variable set here indicating how the
!            calculations are normalized to avoid overflow
!
  integer type
  double precision k(n), qk(n)
  double precision tol
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
!     synthetic division of k by the quadratic 1,u,v
!
  call quadsd(n, u, v, k, qk, c, d)
  tol = 100.0*eta
  if (dabs(c) > tol*dabs(k(n))) go to 10
  if (dabs(d) > tol*dabs(k(n - 1))) go to 10
  type = 3
!
!     type=3 indicates the quadratic is almost a factor of k
!
  return
   10 if (dabs(d) < dabs(c)) go to 20
  type = 2
!
!     type=2 indicates that all formulas are divided by d
!
  e = a/d
  f = c/d
  g = u*b
  h = v*b
  a3 = (a + g)*e + h*(b/d)
  a1 = b*f - a
  a7 = (f + u)*a + h
  return
   20 type = 1
!
!     type=1 indicates that all formulas are divided by c
!
  e = a/c
  f = d/c
  g = u*e
  h = v*b
  a3 = a*e + (h/c + g)*b
  a1 = b - a*(d/c)
  a7 = a + g*d + h*f
  return
end
subroutine calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
!
!*******************************************************************************
!
!! CALCT computes t = -p(s)/h(s)
!
!     bool - logical variable, which is set to .true. if h(s) is
!            essentially zero.
!
  logical bool
  double precision sr,si,tr,ti,pvr,pvi,are,hr(n),hi(n), &
                   qhr(n),qhi(n)
  double precision hvr,hvi,dcpabs
!
!     evaluate h(s)
!
  call polyev (n,sr,si,hr,hi,qhr,qhi,hvr,hvi)
  bool = dcpabs(hvr,hvi) <= 10.d0*are*dcpabs(hr(n),hi(n))
  if (bool) go to 10
     call cdivid(-pvr,-pvi,hvr,hvi,tr,ti)
     return
   10 tr = 0.d0
  ti = 0.d0
  return
end
subroutine capo(x,y,r,theta)
  if (abs(x) <= abs(y)) go to 10
  a=y/x
  r=abs(x)*sqrt(1.0+a*a)
  theta=atan2(y,x)
  return
   10 if (y == 0.) go to 20
  a=x/y
  r=abs(y)*sqrt(1.0+a*a)
  theta=atan2(y,x)
  return
   20 r=0.0
  theta=0.0
  return
end
subroutine cauchy(nn,bnd,pt,q)
!
!*******************************************************************************
!
!! CAUCHY computes a lower bound bnd on the moduli of the zeros
!     of a polynomial. pt is the modulus of the coefficients.
!
  double precision q(nn),pt(nn),x,xm,f,dx,df,bnd
!
  pt(nn) = -pt(nn)
!
!     compute upper estimate of bound.
!
  n = nn - 1
  x = dexp((dlog(-pt(nn)) - dlog(pt(1)))/dble(real(n)))
  if (pt(n) == 0.d0) go to 20
!
!     if the newton step at the origin is better then use it.
!
     xm = -pt(nn)/pt(n)
     if (xm < x) x = xm
!
!     chop the interval (0,x) until f <= 0.
!
   20 xm = 0.1d0*x
  f = pt(1)
  do 30 i = 2,nn
     f = f*xm + pt(i)
   30 continue
  if (f <= 0.d0) go to 40
     x = xm
     go to 20
   40 dx = x
!
!     do newton iteration until x converges to two decimal places.
!
   50 if (dabs(dx/x) <= 0.005d0) go to 70
     q(1) = pt(1)
     do 60 i = 2,nn
        q(i) = q(i - 1)*x + pt(i)
   60    continue
     f = q(nn)
     df = q(1)
     do 65 i = 2,n
        df = df*x + q(i)
   65    continue
     dx = f/df
     x = x - dx
     go to 50
!
   70 bnd = x
  return
end
subroutine caxpy(n,ca,cx,incx,cy,incy)
!
!*******************************************************************************
!
!! CAXPY: constant times a vector plus a vector.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*),cy(*),ca
  integer i,incx,incy,ix,iy,n
!
  if(n <= 0)return
  if (abs(real(ca)) + abs(aimag(ca)) == 0.0 ) return
  if(incx == 1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    cy(iy) = cy(iy) + ca*cx(ix)
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
    cy(i) = cy(i) + ca*cx(i)
   30 continue
  return
end
subroutine cbabk2(nm,n,low,igh,scale,m,zr,zi)
!
!*******************************************************************************
!
!! CBABK2 is a translation of the algol procedure
!     cbabk2, which is a complex version of balbak,
!     num. math. 13, 293-304(1969) by parlett and reinsch.
!     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
!
!     this subroutine forms the eigenvectors of a complex general
!     matrix by back transforming those of the corresponding
!     balanced matrix determined by  cbal.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by  cbal,
!
!        scale contains information determining the permutations
!          and scaling factors used by  cbal,
!
!        m is the number of eigenvectors to be back transformed,
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the eigenvectors to be
!          back transformed in their first m columns.
!
!     on output-
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the transformed eigenvectors
!          in their first m columns.
!
!
  integer i,j,k,m,n,ii,nm,igh,low
  real scale(n),zr(nm,m),zi(nm,m)
  real s
!
  if (m == 0) go to 200
  if (igh == low) go to 120
!
  do 110 i = low, igh
     s = scale(i)
!     ********** left hand eigenvectors are back transformed
!                if the foregoing statement is replaced by
!                s=1.0/scale(i). **********
     do 100 j = 1, m
        zr(i,j) = zr(i,j) * s
        zi(i,j) = zi(i,j) * s
  100    continue
!
  110 continue
!     ********** for i=low-1 step -1 until 1,
!                igh+1 step 1 until n do -- **********
  120 do 140 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 140
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 140
!
     do 130 j = 1, m
        s = zr(i,j)
        zr(i,j) = zr(k,j)
        zr(k,j) = s
        s = zi(i,j)
        zi(i,j) = zi(k,j)
        zi(k,j) = s
  130    continue
!
  140 continue
!
  200 return
end
subroutine cbadd(m,n,a,ka,ml,mu,b,kb,nl,nu,c,kc,l,mcl,mcu,ierr)
!
!*******************************************************************************
!
!! CBADD: addition of complex banded matrices
!
  complex a(ka,*), b(kb,*), c(kc,l)
  complex zero
!
  data zero /(0.0,0.0)/
!
!     addition of the diagonals below the main diagonals
!     and addition of the main diagonals
!
  ierr = 0
  if (nl - ml) 10,30,20
!
   10 if (ml >= l) go to 200
  mcl = ml
  ja = ml - nl
  jb = 0
  jc = ja
  jmax = nl + 1
  do 12 j = 1,jc
    do 11 i = 1,m
   11   c(i,j) = a(i,j)
   12 continue
  go to 60
!
   20 if (nl >= l) go to 210
  mcl = nl
  ja = 0
  jb = nl - ml
  jc = jb
  jmax = ml + 1
  do 22 j = 1,jc
    do 21 i = 1,m
   21   c(i,j) = b(i,j)
   22 continue
  go to 60
!
   30 mcl = ml
  if (ml == 0) go to 40
  imin = ml + 1
  do 32 j = 1,ml
    do 31 i = imin,m
    if (a(i,j) + b(i,j) /= zero) go to 50
   31   continue
  mcl = mcl - 1
   32 imin = imin - 1
!
   40 ja = ml
  jb = ml
  jc = 0
  jmax = 1
  go to 60
!
   50 ja = j - 1
  jb = ja
  jc = 0
  jmax = ml + 1 - ja
  if (jmax > l) go to 220
!
   60 do 62 j = 1,jmax
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 61 i = 1,m
   61   c(i,jc) = a(i,ja) + b(i,jb)
   62 continue
!
!     addition of the diagonals above the main diagonals
!
  if (nu - mu) 100,140,120
!
  100 if (jc + mu > l) go to 230
  mcu = mu
  if (nu == 0) go to 110
  do 102 j = 1,nu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 101 i = 1,m
  101   c(i,jc) = a(i,ja) + b(i,jb)
  102 continue
!
  110 jmax = mu - nu
  do 112 j = 1,jmax
  ja = ja + 1
  jc = jc + 1
    do 111 i = 1,m
  111   c(i,jc) = a(i,ja)
  112 continue
  return
!
  120 if (jc + nu > l) go to 240
  mcu = nu
  if (mu == 0) go to 130
  do 122 j = 1,mu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 121 i = 1,m
  121   c(i,jc) = a(i,ja) + b(i,jb)
  122 continue
!
  130 jmax = nu - mu
  do 132 j = 1,jmax
  jb = jb + 1
  jc = jc + 1
    do 131 i = 1,m
  131   c(i,jc) = b(i,jb)
  132 continue
  return
!
  140 mcu = mu
  if (mu == 0) return
  la = ml + mu + 1
  lb = nl + nu + 1
  do 142 j = 1,mu
  imax = min (m,n-mcu)
    do 141 i = 1,imax
    if (a(i,la) + b(i,lb) /= zero) go to 150
  141   continue
  mcu = mcu - 1
  la = la - 1
  142 lb = lb - 1
  return
!
  150 if (jc + mcu > l) go to 250
  do 152 j = 1,mcu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 151 i = 1,m
  151   c(i,jc) = a(i,ja) + b(i,jb)
  152 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = ml + 1
  return
  210 ierr = nl + 1
  return
  220 ierr = jmax
  return
  230 ierr = jc + mu
  return
  240 ierr = jc + nu
  return
  250 ierr = jc + mcu
  return
end
subroutine cbal(nm,n,ar,ai,low,igh,scale)
!
!*******************************************************************************
!
!! CBAL is a translation of the algol procedure
!     cbalance, which is a complex version of balance,
!     num. math. 13, 293-304(1969) by parlett and reinsch.
!     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
!
!     this subroutine balances a complex matrix and isolates
!     eigenvalues whenever possible.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the complex matrix to be balanced.
!
!     on output-
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the balanced matrix,
!
!        low and igh are two integers such that ar(i,j) and ai(i,j)
!          are equal to zero if
!           (1) i is greater than j and
!           (2) j=1,...,low-1 or i=igh+1,...,n,
!
!        scale contains information determining the
!           permutations and scaling factors used.
!
!     suppose that the principal submatrix in rows low through igh
!     has been balanced, that p(j) denotes the index interchanged
!     with j during the permutation step, and that the elements
!     of the diagonal matrix used are denoted by d(i,j).  then
!        scale(j) = p(j),    for j = 1,...,low-1
!                 = d(j,j)       j = low,...,igh
!                 = p(j)         j = igh+1,...,n.
!     the order in which the interchanges are made is n to igh+1,
!     then 1 to low-1.
!
!     note that 1 is returned for igh if igh is zero formally.
!
!     the algol procedure exc contained in cbalance appears in
!     cbal  in line.  (note that the algol roles of identifiers
!     k,l have been reversed.)
!
!
  integer i,j,k,l,m,n,jj,nm,igh,low,iexc
  real ar(nm,n),ai(nm,n),scale(n)
  real c,f,g,r,s,b2,radix
!     real abs
  logical noconv
!
!  radix is a machine dependent parameter specifying
!                the base of the machine floating point representation.
!
             radix = ipmpar(4)
!
  b2 = radix * radix
  k = 1
  l = n
  go to 100
!  in-line procedure for row and column exchange
   20 scale(m) = j
  if (j == m) go to 50
!
  do 30 i = 1, l
     f = ar(i,j)
     ar(i,j) = ar(i,m)
     ar(i,m) = f
     f = ai(i,j)
     ai(i,j) = ai(i,m)
     ai(i,m) = f
   30 continue
!
  do 40 i = k, n
     f = ar(j,i)
     ar(j,i) = ar(m,i)
     ar(m,i) = f
     f = ai(j,i)
     ai(j,i) = ai(m,i)
     ai(m,i) = f
   40 continue
!
   50 go to (80,130), iexc
!     ********** search for rows isolating an eigenvalue
!                and push them down
   80 if (l == 1) go to 280
  l = l - 1
!     ********** for j=l step -1 until 1 do
  100 do 120 jj = 1, l
     j = l + 1 - jj
!
     do 110 i = 1, l
        if (i == j) go to 110
        if (ar(j,i) /= 0.0 .or. ai(j,i) /= 0.0) go to 120
  110    continue
!
     m = l
     iexc = 1
     go to 20
  120 continue
!
  go to 140
!     ********** search for columns isolating an eigenvalue
!                and push them left.
  130 k = k + 1
!
  140 do 170 j = k, l
!
     do 150 i = k, l
        if (i == j) go to 150
        if (ar(i,j) /= 0.0 .or. ai(i,j) /= 0.0) go to 170
  150    continue
!
     m = k
     iexc = 2
     go to 20
  170 continue
!     ********** now balance the submatrix in rows k to l.
  do 180 i = k, l
  180 scale(i) = 1.0
!     ********** iterative loop for norm reduction.
  190 noconv = .false.
!
  do 270 i = k, l
     c = 0.0
     r = 0.0
!
     do 200 j = k, l
        if (j == i) go to 200
        c = c + abs(ar(j,i)) + abs(ai(j,i))
        r = r + abs(ar(i,j)) + abs(ai(i,j))
  200    continue
!     ********** guard against zero c or r due to underflow.
     if (c == 0.0 .or. r == 0.0) go to 270
     g = r / radix
     f = 1.0
     s = c + r
  210    if (c >= g) go to 220
     f = f * radix
     c = c * b2
     go to 210
  220    g = r * radix
  230    if (c < g) go to 240
     f = f / radix
     c = c / b2
     go to 230
!     ********** now balance.
  240    if ((c + r) / f >= 0.95 * s) go to 270
     g = 1.0 / f
     scale(i) = scale(i) * f
     noconv = .true.
!
     do 250 j = k, n
        ar(i,j) = ar(i,j) * g
        ai(i,j) = ai(i,j) * g
  250    continue
!
     do 260 j = 1, l
        ar(j,i) = ar(j,i) * f
        ai(j,i) = ai(j,i) * f
  260    continue
!
  270 continue
!
  if (noconv) go to 190
!
  280 low = k
  igh = l
  return
end
subroutine cbcrt (a, z )
!
!*******************************************************************************
!
!! CBCRT computes the roots of the real polynomial
!              a(1) + a(2)*z + a(3)*z**2 + a(4)*z**3
!     and stores the results in z. it is assumed that a(4)
!     is nonzero.
!
!
!     written by alfred h. morris
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  real a(4), aq(3)
  complex z(3)
!
  data rt3/1.7320508075689/
!
!
!  eps is a machine dependent constant. eps is the
!           smallest number such that 1.0 + eps > 1.0.
!
  eps = epsilon ( eps )
  if (a(1) == 0.0) go to 100
  p = a(3)/(3.0*a(4))
  q = a(2)/a(4)
  r = a(1)/a(4)
  tol = 4.0*eps

  c = 0.0
  t = a(2) - p*a(3)
  if (abs(t) > tol*abs(a(2))) c = t/a(4)

  t = 2.0*p*p - q
  if (abs(t) <= tol*abs(q)) t = 0.0
  d = r + p*t
  if (abs(d) <= tol*abs(r)) go to 110
!
!  set  sq = (a(4)/s)**2 * (c**3/27 + d**2/4)
!
  s = max ( abs(a(1)),abs(a(2)),abs(a(3)))
  p1 = a(3)/(3.0*s)
  q1 = a(2)/s
  r1 = a(1)/s
!
  t1 = q - 2.25*p*p
  if (abs(t1) <= tol*abs(q)) t1 = 0.0
  w = 0.25*r1*r1
  w1 = 0.5*p1*r1*t
  w2 = q1*q1*t1/27.0
  if (w1 < 0.0) go to 10
     w = w + w1
     sq = w + w2
     go to 12
   10 if (w2 < 0.0) go to 11
     w = w + w2
     sq = w + w1
     go to 12
   11 sq = w + (w1 + w2)
   12 if (abs(sq) <= tol*w) sq = 0.0
  rq = abs(s/a(4))*sqrt(abs(sq))
  if (sq >= 0.0) go to 40
!
!                   all roots are real
!
  arg = atan2(rq, -0.5*d)
  cf = cos(arg/3.0)
  sf = sin(arg/3.0)
  rt = sqrt(-c/3.0)
  y1 = 2.0*rt*cf
  y2 = -rt*(cf + rt3*sf)
  y3 = -(d/y1)/y2
!
  x1 = y1 - p
  x2 = y2 - p
  x3 = y3 - p
  if (abs(x1) <= abs(x2)) go to 20
     t = x1
     x1 = x2
     x2 = t
   20 if (abs(x2) <= abs(x3)) go to 30
     t = x2
     x2 = x3
     x3 = t
  if (abs(x1) <= abs(x2)) go to 30
     t = x1
     x1 = x2
     x2 = t
!
   30 w = x3
  if (abs(x2) < 0.1*abs(x3)) go to 70
  if (abs(x1) < 0.1*abs(x2)) x1 = - (r/x3)/x2
  z(1) = cmplx(x1, 0.0)
  z(2) = cmplx(x2, 0.0)
  z(3) = cmplx(x3, 0.0)
  return
!
!                  real and complex roots
!
   40 ra = cbrt(-0.5*d - sign(rq,d))
  rb = -c/(3.0*ra)
  t = ra + rb
  w = -p
  x = -p
  if (abs(t) <= tol*abs(ra)) go to 41
     w = t - p
     x = -0.5*t - p
     if (abs(x) <= tol*abs(p)) x = 0.0
   41 t = abs(ra - rb)
  y = 0.5*rt3*t
!
  if (t <= tol*abs(ra)) go to 60
  if (abs(x) < abs(y)) go to 50
     s = abs(x)
     t = y/x
     go to 51
   50 s = abs(y)
  t = x/y
   51 if (s < 0.1*abs(w)) go to 70
  w1 = w/s
  sum = 1.0 + t*t
  if (w1*w1 < 0.01*sum) w = - ((r/sum)/s)/s
  z(1) = cmplx(w,0.0)
  z(2) = cmplx(x, y)
  z(3) = cmplx(x,-y)
  return
!
!               at least two roots are equal
!
   60 if (abs(x) < abs(w)) go to 61
     if (abs(w) < 0.1*abs(x)) w = - (r/x)/x
     z(1) = cmplx(w, 0.0)
     z(2) = cmplx(x, 0.0)
     z(3) = z(2)
     return
   61 if (abs(x) < 0.1*abs(w)) go to 70
  z(1) = cmplx(x, 0.0)
  z(2) = z(1)
  z(3) = cmplx(w, 0.0)
  return
!
!     here w is much larger in magnitude than the other roots.
!     as a result, the other roots may be exceedingly inaccurate
!     because of roundoff error. to deal with this, a quadratic
!     is formed whose roots are the same as the smaller roots of
!     the cubic. this quadratic is then solved.
!
!     this code was written by william l. davis (nswc).
!
   70    aq(1) = a(1)
     aq(2) = a(2) + a(1)/w
     aq(3) = -a(4)*w
     call qdcrt(aq, z)
     z(3) = cmplx(w, 0.0)
!
  if (aimag(z(1)) == 0.0) return
  z(3) = z(2)
  z(2) = z(1)
  z(1) = cmplx(w, 0.0)
  return
!
!
!                  case when a(1) = 0
!
  100 z(1) = (0.0, 0.0)
  call qdcrt(a(2), z(2))
  return
!
!                   case when d = 0
!
  110 z(1) = cmplx(-p, 0.0)
  w = sqrt(abs(c))
  if (c < 0.0) go to 120
     z(2) = cmplx(-p, w)
     z(3) = cmplx(-p,-w)
     return
!
  120 if (p /= 0.0) go to 130
     z(2) = cmplx(w, 0.0)
     z(3) = cmplx(-w, 0.0)
     return
!
  130 x = -(p + sign(w,p))
  z(3) = cmplx(x, 0.0)
  t = 3.0*a(1)/(a(3)*x)
  if (abs(p) > abs(t)) go to 131
     z(2) = cmplx(t, 0.0)
     return
  131 z(2) = z(1)
  z(1) = cmplx(t, 0.0)
  return
end
subroutine cbfa (a, lda, n, ml, mu, ipvt, info)
!
!*******************************************************************************
!
!! CBFA factors a complex band matrix by elimination.
!
!                              ----------
!     on entry
!
!        a       complex(lda, nc)
!                contains the matrix in band storage. the rows
!                of the original matrix are stored in the rows
!                of a and the diagonals of the original matrix
!                are stored in columns 1 through ml+mu+1 of a.
!                nc must be >= 2*ml+mu+1 .
!                see the comments below for details.
!
!        lda     integer
!                the leading dimension of the array a. it is
!                assumed that lda >= n.
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!                0 <= ml < n .
!
!        mu      integer
!                number of diagonals above the main diagonal.
!                0 <= mu < n .
!                more efficient if ml <= mu .
!
!     on return
!
!        a       an upper triangular matrix in band storage
!                and the multipliers which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l is a product of permutation and unit lower
!                triangular matrices and u is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                =0  normal value
!                =k  if  u(k,k) == 0. this is not an error
!                condition for this subroutine, but it does
!                indicate that snbsl will divide by zero if
!                it is called.
!
!     band storage
!
!           if a0 is the matrix then the following code will store
!           a0 in band form.
!
!                   ml = (band width below the diagonal)
!                   mu = (band width above the diagonal)
!                   do 20 i = 1, n
!                      j1 = max (1, i-ml)
!                      j2 = min (n, i+mu)
!                      do 10 j = j1, j2
!                         k = j - i + ml + 1
!                         a(i,k) = a0(i,j)
!                10    continue
!                20 continue
!
!           this uses columns 1 through  ml + mu + 1  of a.
!           furthermore, ml additional columns are needed in
!           a (starting with column  ml+mu+2) for elements
!           generated during the triangularization. the total
!           number of columns needed in a is  2*ml+mu+1 .
!
!     example..  if the original matrix is
!
!           11 12 13  0  0  0
!           21 22 23 24  0  0
!            0 32 33 34 35  0
!            0  0 43 44 45 46
!            0  0  0 54 55 56
!            0  0  0  0 65 66
!
!      then  n = 6, ml = 1, mu = 2, lda >= 6  and a should contain
!
!            * 11 12 13  +     , * = not used
!           21 22 23 24  +     , + = used for pivoting
!           32 33 34 35  +
!           43 44 45 46  +
!           54 55 56  *  +
!           65 66  *  *  +
!
!     written by e.a.voorhees, los alamos scientific laboratory.
!     modified by a.h.morris, Naval Surface Weapons Center,.
!
!     subroutines and functions
!        min0,icamax,caxpy,cscal,cswap
!
  integer lda,n,ml,mu,info
  complex a(lda,*)
  integer ipvt(n)
  complex t,zero
!
  data zero/(0.0,0.0)/
!
  info = 0
  if (ml == 0) go to 100
  m = ml + mu + 1
!
!     set fill-in columns to zero
!
  do 11 j = 1,ml
  jj = m + j
    do 10 i = 1,n
   10   a(i,jj) = zero
   11 continue
!
!     gaussian elimination with partial pivoting
!
  ml1 = ml + 1
  mb = ml + mu
  n1 = n - 1
  ldb = lda - 1
  do 40 k = 1,n1
    lm = min (n-k,ml)
    lmk = lm + k
    lm1 = lm + 1
    lm2 = ml1 - lm
!
!     search for pivot index
!
    l = -icamax(lm1, a(lmk,lm2), ldb) + lm1 + k
    ipvt(k) = l
    mp = min (mb,n-k)
!
!     swap rows if necessary
!
    ll = ml1 + k - l
    if (l /= k) call cswap(mp + 1, a(k,ml1), lda, a(l,ll), lda)
!
!     skip column reduction if pivot is zero
!
    if (a(k,ml1) /= zero) go to 20
       info = k
       go to 40
!
!     compute multipliers
!
   20   t = -1.0/a(k,ml1)
    call cscal(lm, t, a(lmk,lm2), ldb)
!
!     row elimination with column indexing
!
    do 30 j = 1,mp
       jj = ml1 + j
       j1 = lm2 + j
       call caxpy(lm, a(k,jj), a(lmk,lm2), ldb, a(lmk,j1), ldb)
   30   continue
   40 continue
!
  ipvt(n) = n
  if (a(n,ml1) == zero) info = n
  return
!
!     case when ml = 0
!
  100 do 110 k = 1,n
    ipvt(k) = k
    if (a(k,1) == zero) info = k
  110 continue
  return
end
subroutine cbi(ind,z,bi,bip,ierr)
!
!*******************************************************************************
!
!! CBI calculates the airy function bi and its derivative bip
!     for complex argument z.
!
  complex z,ai,bi,aip,bip
  ierr = 0
  a = real(z)
  b = aimag(z)
  r = cpabs(a,b)
  if(r > 1.0) go to 10
!
!     maclaurin expansion
!
     call airm(ind,z,ai,aip,bi,bip)
     return
   10 if(r > 9.6) go to 20
!
!     intermediate range calculation
!
     call bii(ind,z,bi,bip,ierr)
     return
!
!     asymptotic expansion
!
   20 call bia(ind,z,bi,bip,ierr)
  return
end
subroutine cbpose(a,ka,m,n,ml,mu,b,kb)
!
!*******************************************************************************
!
!! CBPOSE: transposition of complex banded matrices
!
  complex a(ka,*),b(kb,*)
!
  l = ml + mu + 1
  lp1 = l + 1
  if (mu == 0) go to 40
!
!     defining the first mu columns of b
!
  ndiag = mu
  do 31 j = 1,mu
     lj = lp1 - j
!
     do 10 i = 1,ndiag
   10    b(i,j) = (0.0,0.0)
!
     imax = min (m,n-ndiag)
     do 20 i = 1,imax
     ii = ndiag + i
   20    b(ii,j) = a(i,lj)
!
     if (ii == n) go to 31
     imin = ii + 1
     do 30 i = imin,n
   30    b(i,j) = (0.0,0.0)
   31 ndiag = ndiag - 1
!
!     defining the remaining columns of b
!
   40 jmin = mu + 1
  ndiag = 0
  do 61 j = jmin,l
     lj = lp1 - j
!
     imax = min (m-ndiag,n)
     do 50 i = 1,imax
     ii = ndiag + i
   50    b(i,j) = a(ii,lj)
!
     if (imax == n) go to 61
     imin = imax + 1
     do 60 i = imin,n
   60    b(i,j) = (0.0,0.0)
   61 ndiag = ndiag + 1
  return
end
subroutine cbprod(m,n,l,a,ka,ml,mu,b,kb,nl,nu,c,kc,nc, &
                          mcl,mcu,ierr)
!
!*******************************************************************************
!
!! CBPROD: multiplication of complex banded matrices
!
  complex a(ka,*), b(kb,*), c(kc,nc)
  complex sum, zero
!
  data zero/(0.0,0.0)/
!
  ierr = 0
  mlp1 = ml + 1
  nlp1 = nl + 1
  npml = n + ml
  npnu = n + nu
  mcl = min (m-1,ml+nl)
  if (mcl == 0) go to 100
!
!     find the first nonzero lower diagonal
!
  maxd = mcl
  do 21 ndiag = 1,maxd
  imj = maxd + 1 - ndiag
  jmax = min (l,m-imj,npml-imj)
    do 11 j = 1,jmax
    i = j + imj
    sum = zero
    if (j > npnu) go to 11
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 10 k = kmin,kmax
      sum = sum + a(i,kk)*b(k,jj)
      kk = kk + 1
   10     jj = jj - 1
   11   c(i,1) = sum
!
  jmax = min (jmax,npnu)
    do 20 j = 1,jmax
    i = j + imj
    if (c(i,1) /= zero) go to 30
   20   continue
   21 mcl = mcl - 1
  go to 100
!
   30 if (mcl >= nc) go to 200
  c(1,1) = zero
  if (mcl == 1) go to 100
!
!     compute the remaining lower diagonals
!
  jc = 1
  mind = ndiag + 1
  do 42 ndiag = mind,maxd
  jc = jc + 1
  imj = maxd + 1 - ndiag
  jmax = min (l,m-imj,npml-imj)
    do 41 j = 1,jmax
    i = j + imj
    sum = zero
    if (j > npnu) go to 41
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 40 k = kmin,kmax
      sum = sum + a(i,kk)*b(k,jj)
      kk = kk + 1
   40     jj = jj - 1
   41   c(i,jc) = sum
   42 continue
!
!     insert zeros in the upper left corner
!
  imax = mcl
  do 51 j = 1,mcl
    do 50 i = 1,imax
   50   c(i,j) = zero
   51 imax = imax - 1
!
!     find the last nonzero upper diagonal
!
  100 jc = mcl + 1
  mcu = min (l-1,mu+nu)
  if (mcu == 0) go to 140
!
  maxd = mcu
  do 121 ndiag = 1,maxd
  jmi = maxd + 1 - ndiag
  imax = min (m,l-jmi,npml)
    do 111 i = 1,imax
    j = i + jmi
    sum = zero
    if (j > npnu) go to 111
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 110 k = kmin,kmax
      sum = sum + a(i,kk)*b(k,jj)
      kk = kk + 1
  110     jj = jj - 1
  111   c(i,jc) = sum
!
  imax1 = min (imax,npnu-jmi)
    do 120 i = 1,imax1
    if (c(i,jc) /= zero) go to 130
  120   continue
  121 mcu = mcu - 1
  go to 140
!
  130 last = jc + mcu
  if (last > nc) go to 210
  do 131 i = 1,imax
  131 c(i,last) = c(i,jc)
!
!     compute the main diagonal and the remaining upper diagonals
!
  140 maxd = max (1,mcu)
  do 143 ndiag = 1,maxd
  jmi = ndiag - 1
  imax = min (m,l-jmi,npml)
    do 142 i = 1,imax
    j = i + jmi
    sum = zero
    if (j > npnu) go to 142
    kmin = max (1,i-ml,j-nu)
    kmax = min (n,i+mu,j+nl)
    kk = mlp1 - i + kmin
    jj = nlp1 + j - kmin
      do 141 k = kmin,kmax
      sum = sum + a(i,kk)*b(k,jj)
      kk = kk + 1
  141     jj = jj - 1
  142   c(i,jc) = sum
  143 jc = jc + 1
!
!     insert zeros in the lower right corner
!
  jmax = mcl + mcu + 1
  imin = l - mcu + 1
  imax = min (m,npml)
  if (imin > imax) go to 160
!
  jmin = max (1,jmax-imax+imin)
  j = jmax
  do 151 jj = jmin,jmax
    do 150 i = imin,imax
  150   c(i,j) = zero
  imin = imin + 1
  151 j = j - 1
!
!     store zeros in the final m-imax rows
!
  160 if (imax == m) return
  imin = imax + 1
  do 162 j = 1,jmax
    do 161 i = imin,m
  161   c(i,j) = zero
  162 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = mcl + 1
  return
  210 ierr = last
  return
end
function cbrt (x)
!
!*******************************************************************************
!
!! CBRT: cube root of a real number
!
  real cbrt
!
  if (x) 30, 10, 20
   10 cbrt = 0.0
  return
   20 r = alog(x)/3.0
  cbrt = exp(r)
  return
   30 r = alog(-x)/3.0
  cbrt = -exp(r)
  return
end
subroutine cbsl(a,lda,n,ml,mu,ipvt,b,job)
!
!*******************************************************************************
!
!! CBSL solves the complex band system a*x = b or trans(a)*x = b
!     using the factors computed by cbfa.
!
!                         ----------
!     on entry
!
!        a       complex(lda, nc)
!                the output from cbfa.
!                nc must be >= 2*ml+mu+1 .
!
!        lda     integer
!                the leading dimension of the array a.
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!
!        mu      integer
!                number of diagonals above the main diagonal.
!
!        ipvt    integer(n)
!                the pivot vector from snbco or snbfa.
!
!        b       complex(n)
!                the right hand side vector.
!
!        job     integer
!                = 0         to solve  a*x = b .
!                = nonzero   to solve  trans(a)*x = b , where
!                            trans(a)  is the transpose.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains a
!        zero on the diagonal.  technically this indicates singularity
!        but it is often caused by improper arguments or improper
!        setting of lda.  it will not occur if the subroutines are
!        called correctly and if cbfa has set info = 0.
!
!     written by e.a. voorhees, los alamos scientific laboratory.
!     adapted by a.h. morris, Naval Surface Weapons Center,.
!
  integer lda,n,ml,mu,job
  complex a(lda,*),b(n)
  integer ipvt(n)
  complex cdotu,t
  integer k,kb,klm,l,lb,ldb,lm,m,mlm,nm1
!
  m = mu + ml + 1
  if (m == 1) go to 100
!
  ml1 = ml + 1
  ml2 = ml + 2
  nm1 = n - 1
  ldb = 1 - lda
  if (job /= 0) go to 50
!
!     job = 0 , solve  a * x = b
!       first solve l*y = b
!
  if (ml == 0) go to 30
  do 20 k = 1,nm1
     lm = min (ml,n-k)
     l = ipvt(k)
     t = b(l)
     if (l == k) go to 10
        b(l) = b(k)
        b(k) = t
   10    klm = k + lm
     mlm = ml1 - lm
     call caxpy(lm, t, a(klm,mlm), ldb, b(k+1), 1)
   20 continue
!
!       now solve  u*x = y
!
   30 k = n
  do 40 kb = 2,n
     b(k) = b(k)/a(k,ml1)
     lm = min (k,m) - 1
     lb = k - lm
     t = -b(k)
     call caxpy(lm, t, a(k-1,ml2), ldb, b(lb), 1)
   40 k = k - 1
  b(1) = b(1)/a(1,ml1)
  return
!
!     job = nonzero, solve trans(a) * x = b
!       first solve  trans(u)*y = b
!
   50 b(1) = b(1)/a(1,ml1)
  do 60 k = 2,n
     lm = min (k,m) - 1
     lb = k - lm
     t = cdotu(lm, a(k-1,ml2), ldb, b(lb), 1)
     b(k) = (b(k) - t)/a(k,ml1)
   60 continue
  if (ml == 0) return
!
!       now solve trans(l)*x = y
!
  do 70 kb = 1, nm1
     k = n - kb
     lm = min (ml,n-k)
     klm = k + lm
     mlm = ml1 - lm
     b(k) = b(k) + cdotu(lm, a(klm,mlm), ldb, b(k+1), 1)
     l = ipvt(k)
     if (l == k) go to 70
        t = b(l)
        b(l) = b(k)
        b(k) = t
   70 continue
  return
!
!     case when ml = 0 and mu = 0
!
  100 do 110 k = 1,n
  110 b(k) = b(k)/a(k,1)
  return
end
subroutine cbslv(m0,a,ka,n,ml,mu,b,iwk,ierr)
!
!*******************************************************************************
!
!! CBSLV employs gauss elimination with row interchanges to solve
!     the nxn complex banded system ax = b. the argument m0 specifies
!     if cbslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) an lu decompo-
!     sition of a is obtained and then the equations are solved.
!     on subsequent calls (when m0/=0) the equations are solved
!     using the decomposition obtained on the initial call to cbslv.
!
!
!     input arguments when m0=0 ---
!
!     a,ka      2-dimensional array of dimension (ka,m) where
!               ka >= n and m >= 2*ml+mu+1. the first ml+mu+1
!               columns contain the matrix a in banded form.
!               a is a complex array.
!
!     n         number of equations and unknowns.
!
!     ml        number of diagonals below the main diagonal.
!
!     mu        number of diagonals above the main diagonal.
!
!     b         complex array of n entries containing the right
!               hand side data.
!
!
!     output arguments when m0=0 ---
!
!     a         an upper tiangular matrix in band storage and
!               the multipliers which were used to obtain it.
!
!     b         the solution of the equations.
!
!     iwk       array of length n containing the pivot indices.
!
!     ierr      integer specifying the status of the results.
!               ierr=0 if the solution of ax = b is obtained.
!               otherwise ierr/=0.
!
!
!     after an initial call to cbslv, the routine may be recalled
!     with m0/=0 for a new b. when m0/=0 it is assumed that
!     a,ka,n,ml,mu,iwk have not been modified. cbslv retrieves the
!     lu decomposition which was obtained on the initial call to
!     cbslv and solves the new equations ax = b. in this case ierr
!     is not referenced.
!
  complex a(ka,*),b(n)
  integer iwk(n)
  if (m0 /= 0) go to 10
!
!     error checking
!
  if (n <= 0 .or. n > ka) go to 100
  if (ml < 0 .or. ml >= n) go to 110
  if (mu < 0 .or. mu >= n) go to 120
!
!     obtain an lu decomposition of a
!
  call cbfa(a,ka,n,ml,mu,iwk,ierr)
  if (ierr /= 0) return
!
!     solve the system of equations
!
   10 call cbsl(a,ka,n,ml,mu,iwk,b,0)
  return
!
!     error return
!
  100 ierr = -1
  return
  110 ierr = -2
  return
  120 ierr = -3
  return
end
subroutine cbslv1(m0,a,ka,n,ml,mu,b,iwk,ierr)
!
!*******************************************************************************
!
!! CBSLV1 employs gauss elimination with row interchanges to solve
!     the nxn complex banded system xa = b. the argument m0 specifies
!     if cbslv1 is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) an lu decompo-
!     sition of a is obtained and then the equations are solved.
!     on subsequent calls (when m0/=0) the equations are solved
!     using the decomposition obtained on the initial call to cbslv1.
!
!
!     input arguments when m0=0 ---
!
!     a,ka      2-dimensional array of dimension (ka,m) where
!               ka >= n and m >= 2*ml+mu+1. the first ml+mu+1
!               columns contain the matrix a in banded form.
!               a is a complex array.
!
!     n         number of equations and unknowns.
!
!     ml        number of diagonals below the main diagonal.
!
!     mu        number of diagonals above the main diagonal.
!
!     b         complex array of n entries containing the right
!               hand side data.
!
!
!     output arguments when m0=0 ---
!
!     a         an upper tiangular matrix in band storage and
!               the multipliers which were used to obtain it.
!
!     b         the solution of the equations.
!
!     iwk       array of length n containing the pivot indices.
!
!     ierr      integer specifying the status of the results.
!               ierr=0 if the solution of xa = b is obtained.
!               otherwise ierr/=0.
!
!
!     after an initial call to cbslv1, the routine may be recalled
!     with m0/=0 for a new b. when m0/=0 it is assumed that
!     a,ka,n,ml,mu,iwk have not been modified. cbslv retrieves the
!     lu decomposition which was obtained on the initial call to
!     cbslv1 and solves the new equations xa = b. in this case ierr
!     is not referenced.
!
  complex a(ka,*),b(n)
  integer iwk(n)
  if (m0 /= 0) go to 10
!
!     error checking
!
  if (n <= 0 .or. n > ka) go to 100
  if (ml < 0 .or. ml >= n) go to 110
  if (mu < 0 .or. mu >= n) go to 120
!
!     obtain an lu decomposition of a
!
  call cbfa(a,ka,n,ml,mu,iwk,ierr)
  if (ierr /= 0) return
!
!     solve the system of equations
!
   10 call cbsl(a,ka,n,ml,mu,iwk,b,1)
  return
!
!     error return
!
  100 ierr = -1
  return
  110 ierr = -2
  return
  120 ierr = -3
  return
end
subroutine cbspl (x, y, a, b, c, n, ibeg, iend, alpha, beta, ierr)
!
!*******************************************************************************
!
!! CBSPL: cubic spline interpolation
!
  real x(n), y(n), a(n), b(n), c(n)
!
  if (n < 3) go to 200

!     a tridiagonal linear system for the unknown slopes s(i) of
!     f at x(i), i=1,...,n, is generated and then solved by gauss
!     elimination, with s(i) ending up in a(i) for all i. a, b, c
!     are used initially for work spaces.
!
  do 10 m = 2,n
     b(m) = x(m) - x(m-1)
     if (b(m) <= 0.0) go to 210
     c(m) = (y(m) - y(m-1))/b(m)
   10 continue
  ierr = 0
!
!     construct the first equation from the boundary condition, of
!     the form
!
!             c(1)*s(1) + b(1)*s(2) = a(1)
!
  if (ibeg - 1) 20,30,40
!
!     no condition at left end.
!
   20 c(1) = b(3)
  b(1) = x(3) - x(1)
  a(1) = ((b(2) + 2.0*b(1))*b(3)*c(2) + b(2)*b(2)*c(3))/b(1)
  go to 50
!
!     slope prescribed at left end.
!
   30 c(1) = 1.0
  b(1) = 0.0
  a(1) = alpha
  go to 50
!
!     second derivative prescribed at left end.
!
   40 c(1) = 2.0
  b(1) = 1.0
  a(1) = 3.0*c(2) - 0.5*alpha*b(2)
!
!     for the interior knots, generate the corresponding equations and
!     carry out the forward pass of gauss elimination, after which the
!     m-th equation reads  c(m)*s(m) + b(m)*s(m+1) = a(m).
!
   50 nm1 = n - 1
  do 51 m = 2,nm1
     t = -b(m+1)/c(m-1)
     a(m) = t*a(m-1) + 3.0*(b(m)*c(m+1) + b(m+1)*c(m))
     c(m) = t*b(m-1) + 2.0*(b(m) + b(m+1))
   51 continue
!
!     if the slope at the right end is given, then set a(n) to the
!     slope and go to back substitution. otherwise, construct the
!     last equation from the second boundary condition, of the form
!
!                r*s(n-1) + c(n)*s(n) = a(n)
!
  if (iend - 1) 60,80,90
   60 if (n == 3 .and. ibeg == 0) go to 70
!
!     no condition at the right end. either  n >= 4  or
!     there is a condition at the left end.
!
  r = x(n) - x(n-2)
  del  = (y(nm1) - y(n-2))/b(nm1)
  a(n) = ((b(n) + 2.0*r)*b(nm1)*c(n) + b(n)*b(n)*del)/r
  c(n) = b(nm1)
  go to 100
!
!     no conditions at the end points and n = 3. in this case,
!     the second boundary condition does not provide us with a
!     new equation. for convenience, we use the following...
!
   70 a(n) = 2.0*c(n)
  c(n) = 1.0
  r = 1.0
  go to 100
!
!     slope prescribed at right end.
!
   80 a(n) = beta
  go to 110
!
!     second derivative prescribed at right end.
!
   90 a(n) = 3.0*c(n) + 0.5*beta*b(n)
  c(n) = 2.0
  r = 1.0
!
!     complete forward pass of gauss elimination.
!
  100 t = -r/c(nm1)
  a(n) = (t*a(nm1) + a(n))/(t*b(nm1) + c(n))
!
!     carry out back substitution.
!
  110 do 120 i = 1,nm1
     j = n - i
     a(j) = (a(j) - b(j)*a(j+1))/c(j)
  120 continue
!
!     generate the cubic coefficients b(i) and c(i).
!
  do 130 i = 1,nm1
     h = b(i+1)
     del = (y(i+1) - y(i))/h
     t = a(i) + a(i+1) - 2.0*del
     b(i) = (del - a(i) - t)/h
     c(i) = (t/h)/h
  130 continue
  return
!
!     error return
!
  200 ierr = 1
  return
  210 ierr = 2
  return
end
subroutine cbsslj (a, r, w)
!
!*******************************************************************************
!
!! CBSSLJ: ordinary Bessel function of first kind
!
!     a = argument (complex number)
!     r = order (complex number)
!     w = Bessel function value (complex number)
!
  real ns
  complex a, r, w, z
  dimension az(2), cn(2), fj(2)
  dimension zr(2), qz(2), rz(2), sz(2), zl(2), zn(2), an(2), gn(2)
  dimension ts(2), tm(2), rm(4), sm(4), re(4), rn(2), qt(2), qf(2)
  dimension sk(2), qu(2), cu(16)
!
  az(1)=real(a)
  az(2)=aimag(a)
  cn(1)=real(r)
  cn(2)=aimag(r)
  zs=az(1)*az(1)+az(2)*az(2)
  zm=sqrt(zs)
  ns=cn(1)*cn(1)+cn(2)*cn(2)
  pn=aint(cn(1))
  fn=cn(1)-pn
  sn=+1.0
  if(fn/=0.0.or.cn(2)/=0.0)go to 002
  n=pn
  pn=abs(pn)
  if(n >= 0.or.n == n/2*2)go to 002
  sn=-1.0
  002 if(zm > 17.5+0.5*ns)go to 006
  if(zm <= 17.5)go to 003
  qn=pn
  go to 018
  003 if(pn+fn)004,005,005
  004 pm=cn(2)
  qm=az(2)-0.5*cn(2)
  qn=-1.25*(zm+0.5*abs(pm)-abs(qm))
  if(pn+fn >= qn)go to 005
  qm=az(2)-cn(2)
  qn=+1.25*zm-0.625*abs(1.2*zm-qm)-0.625*abs(1.2*zm+qm)
  if(pn+fn >= qn)go to 005
  qn=-aint(1.25*(zm-abs(pm)))
  if(pn >= qn)go to 031
  qn=pn
  go to 031
  005 qm=0.0625*zs*zs-cn(2)*cn(2)
  qn=+aint(sqrt(0.5*(qm+abs(qm))))
  if(pn < qn)go to 031
  qn=pn
  go to 031
  006 if(az(1))007,012,012
  007 qz(1)=-az(1)
  qz(2)=-az(2)
  008 if(az(2))009,010,010
  009 an(1)=+3.14159265358979*cn(2)
  an(2)=-3.14159265358979*(pn+fn)
  go to 011
  010 an(1)=-3.14159265358979*cn(2)
  an(2)=+3.14159265358979*(pn+fn)
  011 qm=sn*0.797884560802865*exp(an(1))
  tm(1)=qm*cos(an(2))
  tm(2)=qm*sin(an(2))
  go to 013
  012 qz(1)=+az(1)
  qz(2)=+az(2)
  tm(1)=sn*0.797884560802865
  tm(2)=0.0
  013 zr(1)=sqrt(qz(1)+zm)
  zr(2)=qz(2)/zr(1)
  zr(1)=0.707106781186548*zr(1)
  zr(2)=0.707106781186548*zr(2)
  qf(1)=+(tm(1)*zr(1)+tm(2)*zr(2))/zm
  qf(2)=-(tm(1)*zr(2)-tm(2)*zr(1))/zm
  rz(1)=+0.5*qz(1)/zs
  rz(2)=-0.5*qz(2)/zs
  ts(1)=pn+fn
  ts(2)=cn(2)
  an(1)=ts(1)*ts(1)-ts(2)*ts(2)-0.25
  an(2)=2.0*ts(1)*ts(2)
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  go to 015
  014 an(1)=an(1)-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=-(ts(1)*an(1)-ts(2)*an(2))/pm
  tm(2)=-(ts(1)*an(2)+ts(2)*an(1))/pm
  015 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  an(1)=an(1)-2.0*pm
  pm=pm+1.0
  ts(1)=tm(1)*rz(1)-tm(2)*rz(2)
  ts(2)=tm(1)*rz(2)+tm(2)*rz(1)
  tm(1)=+(ts(1)*an(1)-ts(2)*an(2))/pm
  tm(2)=+(ts(1)*an(2)+ts(2)*an(1))/pm
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 016
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 017
  016 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  if(pm < 35.0)go to 014
  017 an(1)=qz(1)-1.57079632679490*(pn+fn+0.5)
  an(2)=qz(2)-1.57079632679490*cn(2)
  ts(1)=+cos(an(1))*0.5*(exp(+an(2))+exp(-an(2)))
  ts(2)=-sin(an(1))*0.5*(exp(+an(2))-exp(-an(2)))
  tm(1)=sm(1)*ts(1)-sm(2)*ts(2)
  tm(2)=sm(1)*ts(2)+sm(2)*ts(1)
  ts(1)=+sin(an(1))*0.5*(exp(+an(2))+exp(-an(2)))
  ts(2)=+cos(an(1))*0.5*(exp(+an(2))-exp(-an(2)))
  rm(1)=tm(1)-sm(3)*ts(1)+sm(4)*ts(2)
  rm(2)=tm(2)-sm(3)*ts(2)-sm(4)*ts(1)
  fj(1)=qf(1)*rm(1)-qf(2)*rm(2)
  fj(2)=qf(1)*rm(2)+qf(2)*rm(1)
  w=cmplx(fj(1),fj(2))
  return
  018 n=1
  if(abs(cn(2)) >= 0.8*abs(az(2)))n=0
  pm=cn(2)
  qm=az(2)-0.5*cn(2)
  qm=-1.25*(zm+0.5*abs(pm)-abs(qm))
  if(pn+fn >= qm)n=0
  qm=az(2)-cn(2)
  qm=+1.25*zm-0.625*abs(1.2*zm-qm)-0.625*abs(1.2*zm+qm)
  if(pn+fn >= qm)n=0
  019 if(az(1))020,025,025
  020 qz(1)=-az(1)
  qz(2)=-az(2)
  021 if(az(2))022,023,023
  022 an(1)=+3.14159265358979*cn(2)
  an(2)=-3.14159265358979*(pn+fn)
  go to 024
  023 an(1)=-3.14159265358979*cn(2)
  an(2)=+3.14159265358979*(pn+fn)
  024 qm=sn*0.398942280401433*exp(an(1))
  qf(1)=qm*cos(an(2))
  qf(2)=qm*sin(an(2))
  go to 026
  025 qz(1)=+az(1)
  qz(2)=+az(2)
  qf(1)=sn*0.398942280401433
  qf(2)=0.0
  026 an(1)=qn+fn
  an(2)=cn(2)
  zn(1)=+(an(1)*qz(1)+an(2)*qz(2))/zs
  zn(2)=-(an(1)*qz(2)-an(2)*qz(1))/zs
  rm(1)=1.0-zn(1)
  rm(2)=-zn(2)
  rm(3)=1.0+zn(1)
  rm(4)=+zn(2)
  tm(1)=rm(1)*rm(1)+rm(2)*rm(2)
  tm(2)=rm(3)*rm(3)+rm(4)*rm(4)
  ts(1)=tm(1)*tm(1)
  ts(2)=tm(2)*tm(2)
  qr=tm(1)*ts(1)*tm(2)*ts(2)
  qs=(ts(1)+ts(2))*(ts(1)+ts(2))
  ss=16.0e-6*zs*zs*qr/qs
  if(ss > 1.0)go to 027
  qn=qn+1.0
  if(n == 0)go to 026
  qn=-aint(1.25*(zm-abs(pm)))
  if(pn >= qn)go to 031
  qn=pn
  go to 031
  027 an(1)=qn+fn
  an(2)=cn(2)
  assign 028 to ls
  go to 108
  028 sm(1)=sm(3)
  sm(2)=sm(4)
  if(qn == pn)go to 030
  an(1)=qn+fn+1.0
  an(2)=cn(2)
  assign 029 to ls
  go to 108
  029 an(1)=qn+fn
  an(2)=cn(2)
  tm(1)=+2.0*(an(1)*qz(1)+an(2)*qz(2))/zs
  tm(2)=-2.0*(an(1)*qz(2)-an(2)*qz(1))/zs
  ts(1)=tm(1)*sm(1)-tm(2)*sm(2)-sm(3)
  ts(2)=tm(1)*sm(2)+tm(2)*sm(1)-sm(4)
  sm(3)=sm(1)
  sm(4)=sm(2)
  sm(1)=ts(1)
  sm(2)=ts(2)
  qn=qn-1.0
  if(qn/=pn)go to 029
  030 fj(1)=qf(1)*sm(1)-qf(2)*sm(2)
  fj(2)=qf(1)*sm(2)+qf(2)*sm(1)
  w=cmplx(fj(1),fj(2))
  return
  031 sz(1)=+0.25*(az(1)*az(1)-az(2)*az(2))
  sz(2)=+0.5*az(1)*az(2)
  qm=sz(1)*sz(1)+sz(2)*sz(2)
  an(1)=qn+fn
  an(2)=cn(2)
  sm(1)=0.0
  sm(2)=0.0
  sm(3)=0.0
  sm(4)=0.0
  tm(1)=1.0
  tm(2)=0.0
  pm=0.0
  if(qn)032,037,037
  032 ss=an(1)*an(1)+an(2)*an(2)
  ts(1)=+(tm(1)*an(1)+tm(2)*an(2))/ss
  ts(2)=-(tm(1)*an(2)-tm(2)*an(1))/ss
  sm(1)=sm(1)+ts(1)
  sm(2)=sm(2)+ts(2)
  tm(1)=-ts(1)*sz(1)+ts(2)*sz(2)
  tm(2)=-ts(1)*sz(2)-ts(2)*sz(1)
  pm=pm+1.0
  tm(1)=tm(1)/pm
  tm(2)=tm(2)/pm
  if(an(1) < 0.0.or.qm > pm*pm*ss)go to 033
  if(abs(sm(3))+abs(tm(1))/=abs(sm(3)))go to 033
  if(abs(sm(4))+abs(tm(2)) == abs(sm(4)))go to 034
  033 sm(3)=sm(3)+tm(1)
  sm(4)=sm(4)+tm(2)
  an(1)=an(1)+1.0
  go to 032
  034 sm(3)=sm(3)+1.0
  an(1)=qn+fn
  ts(1)=an(1)*sm(1)-an(2)*sm(2)
  ts(2)=an(1)*sm(2)+an(2)*sm(1)
  sm(1)=ts(1)
  sm(2)=ts(2)
  go to 036
  035 an(1)=qn+fn
  ts(1)=an(1)*an(1)-an(2)*an(2)+an(1)
  ts(2)=2.0*an(1)*an(2)+an(2)
  ss=sz(1)*sz(1)+sz(2)*sz(2)
  tm(1)=+(sz(1)*ts(1)+sz(2)*ts(2))/ss
  tm(2)=+(sz(1)*ts(2)-sz(2)*ts(1))/ss
  ts(1)=tm(1)*(sm(1)-sm(3))-tm(2)*(sm(2)-sm(4))
  ts(2)=tm(1)*(sm(2)-sm(4))+tm(2)*(sm(1)-sm(3))
  sm(3)=sm(1)
  sm(4)=sm(2)
  sm(1)=ts(1)
  sm(2)=ts(2)
  qn=qn+1.0
  036 if(qn < pn)go to 035
  go to 042
  037 an(1)=an(1)+1.0
  ss=an(1)*an(1)+an(2)*an(2)
  ts(1)=+(tm(1)*an(1)+tm(2)*an(2))/ss
  ts(2)=-(tm(1)*an(2)-tm(2)*an(1))/ss
  sm(3)=sm(3)+ts(1)
  sm(4)=sm(4)+ts(2)
  tm(1)=-ts(1)*sz(1)+ts(2)*sz(2)
  tm(2)=-ts(1)*sz(2)-ts(2)*sz(1)
  pm=pm+1.0
  tm(1)=tm(1)/pm
  tm(2)=tm(2)/pm
  if(abs(sm(1))+abs(tm(1))/=abs(sm(1)))go to 038
  if(abs(sm(2))+abs(tm(2)) == abs(sm(2)))go to 039
  038 sm(1)=sm(1)+tm(1)
  sm(2)=sm(2)+tm(2)
  go to 037
  039 sm(1)=sm(1)+1.0
  an(1)=qn+fn+1.0
  ts(1)=an(1)*sm(3)-an(2)*sm(4)
  ts(2)=an(1)*sm(4)+an(2)*sm(3)
  sm(3)=ts(1)
  sm(4)=ts(2)
  go to 041
  040 an(1)=qn+fn
  ts(1)=an(1)*an(1)-an(2)*an(2)+an(1)
  ts(2)=2.0*an(1)*an(2)+an(2)
  ss=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=+(sz(1)*ts(1)+sz(2)*ts(2))/ss
  tm(2)=-(sz(1)*ts(2)-sz(2)*ts(1))/ss
  ts(1)=-tm(1)*sm(3)+tm(2)*sm(4)
  ts(2)=-tm(1)*sm(4)-tm(2)*sm(3)
  sm(3)=sm(1)
  sm(4)=sm(2)
  sm(1)=sm(1)+ts(1)
  sm(2)=sm(2)+ts(2)
  qn=qn-1.0
  041 if(qn > pn)go to 040
  042 an(1)=pn+fn
  zl(1)=0.5*alog(zs)-0.693147180559945
  zl(2)=atan2(az(2),az(1))
  tm(1)=an(1)*zl(1)-an(2)*zl(2)
  tm(2)=an(1)*zl(2)+an(2)*zl(1)
  an(1)=an(1)+1.0
  z=cmplx(an(1),an(2))
  call cgamma (1, z, w)
  gn(1)=real(w)
  gn(2)=aimag(w)
  tm(1)=tm(1)-gn(1)
  tm(2)=tm(2)-gn(2)
  qm=sn*exp(tm(1))
  qf(1)=qm*cos(tm(2))
  qf(2)=qm*sin(tm(2))
  fj(1)=qf(1)*sm(1)-qf(2)*sm(2)
  fj(2)=qf(1)*sm(2)+qf(2)*sm(1)
  w=cmplx(fj(1),fj(2))
  return
  100 ss=sz(1)*sz(1)+sz(2)*sz(2)
  rs=sqrt(ss)
  rz(1)=0.0
  rz(2)=0.0
  if(sz(1))101,103,104
  101 rz(2)=sqrt(-sz(1)+rs)
  rz(1)=sz(2)/rz(2)
  if(sz(2))102,105,105
  102 qm=-0.707106781186548
  go to 106
  103 if(sz(2) == 0.0)go to 107
  104 rz(1)=sqrt(+sz(1)+rs)
  rz(2)=sz(2)/rz(1)
  105 qm=+0.707106781186548
  106 rz(1)=qm*rz(1)
  rz(2)=qm*rz(2)
  107 go to lr,(109,110)
  108 ns=an(1)*an(1)+an(2)*an(2)
  zn(1)=(an(1)*qz(1)+an(2)*qz(2))/ns
  zn(2)=(an(1)*qz(2)-an(2)*qz(1))/ns
  sz(1)=(1.0-zn(1))*(1.0+zn(1))+zn(2)*zn(2)
  sz(2)=-2.0*zn(1)*zn(2)
  assign 109 to lr
  go to 100
  109 ts(1)=1.0+rz(1)
  ts(2)=rz(2)
  qs=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=(ts(1)*zn(1)+ts(2)*zn(2))/qs
  tm(2)=(ts(1)*zn(2)-ts(2)*zn(1))/qs
  qs=tm(1)*tm(1)+tm(2)*tm(2)
  zl(1)=rz(1)+0.5*alog(qs)
  zl(2)=rz(2)+atan2(tm(2),tm(1))
  ts(1)=an(1)*zl(1)-an(2)*zl(2)
  ts(2)=an(1)*zl(2)+an(2)*zl(1)
  qt(1)=+sz(1)/ss
  qt(2)=-sz(2)/ss
  ar=1.0/sqrt(ns*rs)
  aq=-1.0/rs
  am=1.0
  tm(1)=an(1)*rz(1)-an(2)*rz(2)
  tm(2)=an(1)*rz(2)+an(2)*rz(1)
  qs=tm(1)*tm(1)+tm(2)*tm(2)
  sz(1)=+tm(1)/qs
  sz(2)=-tm(2)/qs
  assign 110 to lr
  go to 100
  110 rn(1)=sz(1)
  rn(2)=sz(2)
  qm=(1.0/3.0)*atan2(qz(2),qz(1))
  tm(1)=cos(qm)
  tm(2)=sin(qm)
  rm(1)=+0.866025403784439*tm(1)+0.5*tm(2)
  rm(2)=+0.866025403784439*tm(2)-0.5*tm(1)
  rm(3)=+0.866025403784439*tm(1)-0.5*tm(2)
  rm(4)=+0.866025403784439*tm(2)+0.5*tm(1)
  sk(1)=1.0
  sk(2)=0.0
  111 if(an(1)*rm(1)+an(2)*rm(2)-qz(1)*rm(1)-qz(2)*rm(2)) 113,113,112
  112 sk(1)=0.0
  113 if(an(1)*rm(3)+an(2)*rm(4)-qz(1)*rm(3)-qz(2)*rm(4)) 115,115,114
  114 sk(1)=0.0
  115 if(an(1)*rm(1)+an(2)*rm(2)+qz(1)*rm(1)+qz(2)*rm(2)) 116,117,117
  116 sk(2)=1.0
  117 if(an(1)*rm(3)+an(2)*rm(4)+qz(1)*rm(3)+qz(2)*rm(4)) 118,119,119
  118 sk(2)=1.0
  119 qs=an(1)*tm(2)-an(2)*tm(1)+qz(1)*tm(2)-qz(2)*tm(1)
  if(qs <= 0.0)go to 120
  sk(2)=-sk(2)
  120 rm(1)=0.0
  rm(2)=0.0
  rm(3)=0.0
  rm(4)=0.0
  qm=exp(ts(1))
  tm(1)=qm*cos(ts(2))
  tm(2)=qm*sin(ts(2))
  re(1)=+tm(1)*rz(1)-tm(2)*rz(2)
  re(2)=+tm(1)*rz(2)+tm(2)*rz(1)
  121 if(sk(1)/=0.0)go to 122
  re(3)=0.0
  re(4)=0.0
  go to 126
  122 qs=tm(1)*tm(1)+tm(2)*tm(2)
  tm(1)=+tm(1)/qs
  tm(2)=-tm(2)/qs
  re(3)=+tm(1)*rz(2)+tm(2)*rz(1)
  re(4)=-tm(1)*rz(1)+tm(2)*rz(2)
  123 if(rn(2))125,124,126
  124 if(rn(1))126,126,125
  125 re(3)=-re(3)
  re(4)=-re(4)
  126 do 127 k=1,16
  cu(k)=0.0
  127 continue
  cu(1)=1.0
  m=1
  go to 130
  128 ck=0.0
  pm=m-1
  do 129 k=1,m
  cm=ck
  ck=cu(k)
  cu(k)=(0.125/pm+0.5*(pm-1.0))*ck-(0.625/pm+0.5*(pm-3.0))*cm
  pm=pm+2.0
  129 continue
  130 qu(1)=0.0
  qu(2)=0.0
  au=0.0
  l=m
  do 131 k=1,m
  au=cu(l)+aq*au
  ts(1)=qu(1)*qt(1)-qu(2)*qt(2)
  ts(2)=qu(1)*qt(2)+qu(2)*qt(1)
  qu(1)=ts(1)+cu(l)
  qu(2)=ts(2)
  l=l-1
  131 continue
  rm(1)=rm(1)+re(1)*qu(1)-re(2)*qu(2)
  rm(2)=rm(2)+re(1)*qu(2)+re(2)*qu(1)
  ts(1)=re(1)*rn(1)-re(2)*rn(2)
  ts(2)=re(1)*rn(2)+re(2)*rn(1)
  re(1)=+ts(1)
  re(2)=+ts(2)
  132 if(sk(1) == 0.0)go to 133
  rm(3)=rm(3)+re(3)*qu(1)-re(4)*qu(2)
  rm(4)=rm(4)+re(3)*qu(2)+re(4)*qu(1)
  ts(1)=re(3)*rn(1)-re(4)*rn(2)
  ts(2)=re(3)*rn(2)+re(4)*rn(1)
  re(3)=-ts(1)
  re(4)=-ts(2)
  133 au=am*au
  am=ar*am
  if(1.0+au == 1.0)go to 134
  m=m+1
  if(m <= 16)go to 128
  134 if(sk(1)/=0.0)go to 135
  sm(3)=rm(1)
  sm(4)=rm(2)
  go to 147
  135 if(sk(2)/=0.0)go to 136
  sm(3)=rm(1)+rm(3)
  sm(4)=rm(2)+rm(4)
  go to 147
  136 if(zn(2))137,138,138
  137 tm(1)=-6.28318530717959*an(2)
  tm(2)=+6.28318530717959*fn
  go to 139
  138 tm(1)=+6.28318530717959*an(2)
  tm(2)=-6.28318530717959*fn
  139 qm=exp(tm(1))
  ts(1)=qm*cos(tm(2))
  ts(2)=qm*sin(tm(2))
  140 if(qz(2) <= 0.0.and.sk(2) <= 0.0)go to 142
  if(qz(2) >= 0.0.and.sk(2) >= 0.0)go to 142
  if(qz(2) <= 0.0.and.zn(2) < 0.0)go to 142
  if(qz(2) >= 0.0.and.zn(2) >= 0.0)go to 142
  141 qs=ts(1)*ts(1)+ts(2)*ts(2)
  tm(1)=(ts(1)*rm(3)+ts(2)*rm(4))/qs
  tm(2)=(ts(1)*rm(4)-ts(2)*rm(3))/qs
  rm(3)=tm(1)
  rm(4)=tm(2)
  142 tm(1)=rm(1)-ts(1)*rm(1)+ts(2)*rm(2)
  tm(2)=rm(2)-ts(1)*rm(2)-ts(2)*rm(1)
  143 if(qz(1)/=0.0) go to 144
  if(qz(2) < 0.0.and.an(2) > 0.0) go to 146
  if(qz(2) > 0.0.and.an(2) <= 0.0) go to 146
  go to 145
  144 if(qz(2) < 0.0.and.zn(2) < 0.0) go to 145
  if(qz(2) >= 0.0.and.zn(2) >= 0.0) go to 145
  if(qz(2) < 0.0.and.an(2) >= 0.0.and.rn(2) < 0.0) go to 146
  if(qz(2) >= 0.0.and.an(2) < 0.0.and.rn(2) >= 0.0) go to 146
  145 sm(3)=rm(3)+tm(1)
  sm(4)=rm(4)+tm(2)
  go to 147
  146 sm(3)=rm(3)-tm(1)
  sm(4)=rm(4)-tm(2)
  147 go to ls,(028,029)
end
subroutine cbsslk (z, r, w)
!
!*******************************************************************************
!
!! CBSSLK: calculation of the modified Bessel function of the
!         second kind for real order r and complex argument z.
!         it is assumed that -pi < arg z <= pi.
!
!     written by
!         andrew h. van tuyl
!         naval surface warfare center
!         feb 1990
!     modified by a.h. morris (nswc)
!
  complex z, w, w1, w2, z1, zr, u1, u2, u3, cz, cn, ex
  real nu, temp(1)
  complex cxp
!
!          cpi = 0.5*sqrt(pi)
!
  data pi/3.14159265358979e+00/
  data cpi/8.86226925452758e-01/
!
!          reduction of r to the range -0.5 < nu <= 0.5
!
  a = abs(r)
  n = a
  nu = a - real(n)
  t = nu - 0.5
  if (t <= 0.0) go to 10
     nu = t - 0.5
     n = n + 1
!
   10 z1 = z/2.0
  x = real(z1)
  y = aimag(z1)
  call crec (x, y, zr1, zr2)
  zr = cmplx (zr1, zr2)
  if (t /= 0.0) go to 20
!
!               calculation for nu = 0.5
!
  w = cpi*csqrt(zr)
  if (x < 0.0 .and. y == 0.0) w = conjg(w)
  w = w*cexp(-z)
  if (n == 0) return
     u1 = w
     u2 = u1
     nu = - 0.5
     n = n + 1
     go to 70
!
!           calculation for abs(nu) < 0.5
!
   20 znorm = cpabs(x, y)
  if (znorm > 1.0) go to 30
     call ckm (z, znorm, zr, nu, u1, u2)
     go to 60
   30 if (x < 0.0) go to 40
     call ckml (z, znorm, zr, nu, u1, u2)
     go to 60
   40 cz = - z
  zr = - zr
  if (y >= 0.0) go to 50
     cz = conjg(cz)
     zr = conjg(zr)
   50 call ckml (cz, znorm, zr, nu, u1, u2)
!
!                 recursion
!
   60 if (n > 1) go to 70
     w = u1
     if (n /= 0) w = u2
     go to 90
   70 n1 = n - 1
  do 80 i = 1, n1
     ai = i
     u3 = (nu + ai)*zr*u2 + u1
     u1 = u2
   80    u2 = u3
  w = u3
!
   90 if (x >= 0.0 .or. t == 0.0) return
  if (znorm <= 1.0) return
!
!            analytic continuation
!
  ex = cxp(n, nu)
  if (y /= 0.0) go to 100
     call besi (real(cz), a, 1, 1, temp, ind)
     w2 = cmplx (temp(1), 0.0)
     w2 = cmplx (pi*aimag(w2), - pi*real(w2))
     w = ex*ex*w + w2
     go to 110
  100 w1 = cmplx (- aimag(cz), real(cz))
  cn = cmplx (a, 0.0)
  call cbsslj (w1, cn, w2)
  w2 = cmplx (pi*aimag(w2), - pi*real(w2))
  w = ex*(ex*w + w2)
!
  110 if (y < 0.0) w = conjg(w)
  return
end
subroutine cbsubt(m,n,a,ka,ml,mu,b,kb,nl,nu,c,kc,l,mcl,mcu,ierr)
!
!*******************************************************************************
!
!! CBSUBT: subtraction of complex banded matrices
!
  complex a(ka,*), b(kb,*), c(kc,l)
  complex zero
!
  data zero /(0.0,0.0)/
!
!
!     subtraction of the diagonals below the main diagonals
!     and subtraction of the main diagonals
!
  ierr = 0
  if (nl - ml) 10,30,20
!
   10 if (ml >= l) go to 200
  mcl = ml
  ja = ml - nl
  jb = 0
  jc = ja
  jmax = nl + 1
  do 12 j = 1,jc
    do 11 i = 1,m
   11   c(i,j) = a(i,j)
   12 continue
  go to 60
!
   20 if (nl >= l) go to 210
  mcl = nl
  ja = 0
  jb = nl - ml
  jc = jb
  jmax = ml + 1
  do 22 j = 1,jc
    do 21 i = 1,m
   21   c(i,j) = -b(i,j)
   22 continue
  go to 60
!
   30 mcl = ml
  if (ml == 0) go to 40
  imin = ml + 1
  do 32 j = 1,ml
    do 31 i = imin,m
    if (a(i,j) - b(i,j) /= zero) go to 50
   31   continue
  mcl = mcl - 1
   32 imin = imin - 1
!
   40 ja = ml
  jb = ml
  jc = 0
  jmax = 1
  go to 60
!
   50 ja = j - 1
  jb = ja
  jc = 0
  jmax = ml + 1 - ja
  if (jmax > l) go to 220
!
   60 do 62 j = 1,jmax
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 61 i = 1,m
   61   c(i,jc) = a(i,ja) - b(i,jb)
   62 continue
!
!     subtraction of the diagonals above the main diagonals
!
  if (nu - mu) 100,140,120
!
  100 if (jc + mu > l) go to 230
  mcu = mu
  if (nu == 0) go to 110
  do 102 j = 1,nu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 101 i = 1,m
  101   c(i,jc) = a(i,ja) - b(i,jb)
  102 continue
!
  110 jmax = mu - nu
  do 112 j = 1,jmax
  ja = ja + 1
  jc = jc + 1
    do 111 i = 1,m
  111   c(i,jc) = a(i,ja)
  112 continue
  return
!
  120 if (jc + nu > l) go to 240
  mcu = nu
  if (mu == 0) go to 130
  do 122 j = 1,mu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 121 i = 1,m
  121   c(i,jc) = a(i,ja) - b(i,jb)
  122 continue
!
  130 jmax = nu - mu
  do 132 j = 1,jmax
  jb = jb + 1
  jc = jc + 1
    do 131 i = 1,m
  131   c(i,jc) = -b(i,jb)
  132 continue
  return
!
  140 mcu = mu
  if (mu == 0) return
  la = ml + mu + 1
  lb = nl + nu + 1
  do 142 j = 1,mu
  imax = min (m,n-mcu)
    do 141 i = 1,imax
    if (a(i,la) - b(i,lb) /= zero) go to 150
  141   continue
  mcu = mcu - 1
  la = la - 1
  142 lb = lb - 1
  return
!
  150 if (jc + mcu > l) go to 250
  do 152 j = 1,mcu
  ja = ja + 1
  jb = jb + 1
  jc = jc + 1
    do 151 i = 1,m
  151   c(i,jc) = a(i,ja) - b(i,jb)
  152 continue
  return
!
!     error return - c requires at least ierr columns
!
  200 ierr = ml + 1
  return
  210 ierr = nl + 1
  return
  220 ierr = jmax
  return
  230 ierr = jc + mu
  return
  240 ierr = jc + nu
  return
  250 ierr = jc + mcu
  return
end
subroutine cbtpd(m,n,a,ka,ml,mu,x,y)
!
!*******************************************************************************
!
!! CBTPD: product of a complex vector and a complex banded matrix
!
  complex a(ka,*), x(m), y(n)
  complex sum
!
!     compute the first mu components
!
  jcol = ml + 1
  if (mu == 0) go to 20
  do 11 j = 1,mu
  kmax = min (m,j+ml)
  jj = jcol
  sum = (0.0,0.0)
    do 10 k = 1,kmax
    sum = sum + x(k)*a(k,jj)
   10   jj = jj - 1
  y(j) = sum
   11 jcol = jcol + 1
!
!     compute the remaining nonzero components
!
   20 jmin = mu + 1
  jmax = min (n,m+mu)
  do 22 j = jmin,jmax
  kmin = j - mu
  kmax = min (m,j+ml)
  jj = jcol
  sum = (0.0,0.0)
    do 21 k = kmin,kmax
    sum = sum + x(k)*a(k,jj)
   21   jj = jj - 1
   22 y(j) = sum
!
!     store zeros in the final n-jmax components
!
  if (jmax == n) return
  jmin = jmax + 1
  do 30 j = jmin,n
   30 y(j) = (0.0,0.0)
  return
end
subroutine cbtpd1(m,n,a,ka,ml,mu,x,y)
!
!*******************************************************************************
!
!! CBTPD1: setting y = x*a + y where a is a complex banded matrix and
!     x,y are complex vectors
!
  complex a(ka,*), x(m), y(n)
  complex sum
!
!     compute the first mu components
!
  jcol = ml + 1
  if (mu == 0) go to 20
  do 11 j = 1,mu
  kmax = min (m,j+ml)
  jj = jcol
  sum = y(j)
    do 10 k = 1,kmax
    sum = sum + x(k)*a(k,jj)
   10   jj = jj - 1
  y(j) = sum
   11 jcol = jcol + 1
!
!     compute the remaining components
!
   20 jmin = mu + 1
  jmax = min (n,m+mu)
  do 22 j = jmin,jmax
  kmin = j - mu
  kmax = min (m,j+ml)
  jj = jcol
  sum = y(j)
    do 21 k = kmin,kmax
    sum = sum + x(k)*a(k,jj)
   21   jj = jj - 1
   22 y(j) = sum
  return
end
subroutine cbvpd(m,n,a,ka,ml,mu,x,y)
!
!*******************************************************************************
!
!! CBVPD: product of a complex banded matrix and a complex vector
!
  complex a(ka,*), x(n), y(m)
  complex sum
!
!     compute the first ml components
!
  mlp1 = ml + 1
  if (ml == 0) go to 20
  jmin = mlp1
  do 11 i = 1,ml
  kmax = min (n,i+mu)
  kk = jmin
  sum = (0.0,0.0)
    do 10 k = 1,kmax
    sum = sum + a(i,kk)*x(k)
   10   kk = kk + 1
  y(i) = sum
   11 jmin = jmin - 1
!
!     compute the remaining nonzero components
!
   20 imax = min (m,n+ml)
  do 22 i = mlp1,imax
  kmin = i - ml
  kmax = min (n,i+mu)
  kk = 1
  sum = (0.0,0.0)
    do 21 k = kmin,kmax
    sum = sum + a(i,kk)*x(k)
   21   kk = kk + 1
   22 y(i) = sum
!
!     store zeros in the final m-imax components
!
  if (imax == m) return
  imin = imax + 1
  do 30 i = imin,m
   30 y(i) = (0.0,0.0)
  return
end
subroutine cbvpd1(m,n,a,ka,ml,mu,x,y)
!
!*******************************************************************************
!
!! CBVPD1: setting y = a*x + y where a is a complex banded matrix and
!     x,y are complex vectors
!
  complex a(ka,*), x(n), y(m)
  complex sum
!
!     compute the first ml components
!
  mlp1 = ml + 1
  if (ml == 0) go to 20
  jmin = mlp1
  do 11 i = 1,ml
  kmax = min (n,i+mu)
  kk = jmin
  sum = y(i)
    do 10 k = 1,kmax
    sum = sum + a(i,kk)*x(k)
   10   kk = kk + 1
  y(i) = sum
   11 jmin = jmin - 1
!
!     compute the remaining components
!
   20 imax = min (m,n+ml)
  do 22 i = mlp1,imax
  kmin = i - ml
  kmax = min (n,i+mu)
  kk = 1
  sum = y(i)
    do 21 k = kmin,kmax
    sum = sum + a(i,kk)*x(k)
   21   kk = kk + 1
   22 y(i) = sum
  return
end
subroutine ccopy(n,cx,incx,cy,incy)
!
!*******************************************************************************
!
!! CCOPY copies a vector, x, to a vector, y.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*),cy(*)
  integer i,incx,incy,ix,iy,n
!
  if(n <= 0)return
  if(incx == 1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    cy(iy) = cx(ix)
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
    cy(i) = cx(i)
   30 continue
  return
end
function cdet(a,ka,n,x)
!
!*******************************************************************************
!
!! CDET: evaluation of the determinant of a-xi where a is an nxn matrix,
!     x is a scalar, and i is the nxn identity matrix.
!
!     ka is the row dimension of a in the calling program. it is
!     assumed that ka is greater than or equal to n.
!
  complex a(ka,n),x
  complex cdet
  complex pivot,t,zero
  real s,c
  data zero/(0.0,0.0)/
!
  if (n >= 2) go to 10
  cdet = a(1,1)-x
  return
!
!              replace a with a-xi
!
   10 if (x == zero) go to 20
  do 11 k=1,n
   11 a(k,k) = a(k,k)-x
!
!                initialization
!
   20 cdet = (1.0,0.0)
  nm1 = n-1
  do 52 k=1,nm1
  kp1 = k+1
!
!       search for the k-th pivot element
!
  s = abs(real(a(k,k))) + abs(aimag(a(k,k)))
  l = k
  do 30 i=kp1,n
  c = abs(real(a(i,k))) + abs(aimag(a(i,k)))
  if (s >= c) go to 30
  s = c
  l = i
   30 continue
  pivot = a(l,k)
!
!         update the calculation of cdet
!
  cdet = cdet*pivot
  if (cdet == zero) return
  if (k == l) go to 50
  cdet = -cdet
!
!          interchanging rows k and l
!
  do 40 j=k,n
  t = a(k,j)
  a(k,j) = a(l,j)
   40 a(l,j) = t
!
!        reduction of the non-pivot rows
!
   50 do 51 i=kp1,n
  t = a(i,k)/pivot
  do 51 j=kp1,n
   51 a(i,j) = a(i,j)-t*a(k,j)
   52 continue
!
!         final determinant calculation
!
  cdet = cdet*a(n,n)
  return
end
subroutine cdivid(ar,ai,br,bi,cr,ci)
!
!*******************************************************************************
!
!! CDIVID: double precision complex division c = a/b avoiding overflow
!
  double precision ar, ai, br, bi, cr, ci
  double precision d, t, u, v
  double precision dpmpar
!
  if (dabs(br) <= dabs(bi)) go to 10
  t = bi/br
  d = br + t*bi
  u = (ar + ai*t)/d
  v = (ai - ar*t)/d
  cr = u
  ci = v
  return
!
   10 if (bi == 0.d0) go to 20
  t = br/bi
  d = bi + t*br
  u = (ar*t + ai)/d
  v = (ai*t - ar)/d
  cr = u
  ci = v
  return
!
!     division by zero. c = infinity
!
   20 cr = dpmpar(3)
  ci = cr
  return
end
function cdotc(n,cx,incx,cy,incy)
!
!*******************************************************************************
!
!! CDOTC: forms the dot product of two vectors, conjugating the first vector.
!     jack dongarra, linpack,  3/11/78.
!
  complex cdotc
  complex cx(*),cy(*),ctemp
  integer i,incx,incy,ix,iy,n
!
  ctemp = (0.0,0.0)
  cdotc = (0.0,0.0)
  if(n <= 0)return
  if(incx == 1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    ctemp = ctemp + conjg(cx(ix))*cy(iy)
    ix = ix + incx
    iy = iy + incy
   10 continue
  cdotc = ctemp
  return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
    ctemp = ctemp + conjg(cx(i))*cy(i)
   30 continue
  cdotc = ctemp
  return
end
function cdotu(n,cx,incx,cy,incy)
!
!*******************************************************************************
!
!! CDOTU: forms the dot product of two vectors.
!     jack dongarra, linpack, 3/11/78.
!
  complex cdotu
  complex cx(*),cy(*),ctemp
  integer i,incx,incy,ix,iy,n
!
  ctemp = (0.0,0.0)
  cdotu = (0.0,0.0)
  if(n <= 0)return
  if(incx == 1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    ctemp = ctemp + cx(ix)*cy(iy)
    ix = ix + incx
    iy = iy + incy
   10 continue
  cdotu = ctemp
  return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
    ctemp = ctemp + cx(i)*cy(i)
   30 continue
  cdotu = ctemp
  return
end
subroutine ceez (del1,del2,sigma,c1,c2,c3,n)
!
!*******************************************************************************
!
!! CEEZ determines the coefficients c1, c2, and c3
! used to determine endpoint slopes. specifically, if
! function values y1, y2, and y3 are given at points x1, x2,
! and x3, respectively, the quantity c1*y1 + c2*y2 + c3*y3
! is the value of the derivative at x1 of a spline under
! tension (with tension factor sigma) passing through the
! three points and having third derivative equal to zero at
! x1. optionally, only two values, c1 and c2 are determined.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   del1 is x2-x1 ( >  0.).
!
!   del2 is x3-x1 ( >  0.). if n == 2, this parameter is
!   ignored.
!
!   sigma is the tension factor.
!
! and
!
!   n is a switch indicating the number of coefficients to
!   be returned. if n == 2 only two coefficients are
!   returned. otherwise all three are returned.
!
! on output--
!
!   c1, c2, and c3 contain the coefficients.
!
! none of the input parameters are altered.
!
! this subroutine references package module snhcsh.
!
  real del1,del2,sigma,c1,c2,c3
!
  if (n == 2) go to 2
  if (sigma /= 0.) go to 1
  del = del2-del1
!
! tension == 0.
!
  c1 = -(del1+del2)/(del1*del2)
  c2 = del2/(del1*del)
  c3 = -del1/(del2*del)
  return
!
! tension /= 0.
!
1 call snhcsh (dummy,coshm1,sigma*del1,1)
  call snhcsh (dummy,coshm2,sigma*del2,1)
  delp = sigma*(del2+del1)/2.
  delm = sigma*(del2-del1)/2.
  call snhcsh (sinhmp,dummy,delp,-1)
  call snhcsh (sinhmm,dummy,delm,-1)
  denom = coshm1*(del2-del1)-2.*del1*(sinhmp+delp)* &
          (sinhmm+delm)
  c1 = 2.*(sinhmp+delp)*(sinhmm+delm)/denom
  c2 = -coshm2/denom
  c3 = coshm1/denom
  return
!
! two coefficients
!
2 c1 = -1./del1
  c2 = -c1
  return
end
subroutine ceig(ibal,ar,ai,ka,n,wr,wi,ierr)
!
!*******************************************************************************
!
!! CEIG: eigenvalues of complex matrices
!
  real ar(ka,n), ai(ka,n), wr(n), wi(n)
!
  low = 1
  igh = n
  if (ibal /= 0) call cbal(ka,n,ar,ai,low,igh,wr)
  call corth(ka,n,low,igh,ar,ai,wr,wi)
  call comqr(ka,n,low,igh,ar,ai,wr,wi,ierr)
  return
end
subroutine ceigv(ibal,ar,ai,ka,n,wr,wi,zr,zi,ierr,temp)
!
!*******************************************************************************
!
!! CEIGV: eigenvalues and eigenvectors of complex matrices
!
  real ar(ka,n),ai(ka,n),wr(n),wi(n),zr(ka,n),zi(ka,n),temp(*)
!
!     temp is a temporary storage area
!        dimension(temp) >= 2*n    if ibal == 0
!        dimension(temp) >= 3*n    if ibal /= 0
!-
  i2 = 1
  i3 = n + 1
  i1 = n + i3
  low = 1
  igh = n
  if (ibal /= 0) call cbal(ka,n,ar,ai,low,igh,temp(i1))
  call corth(ka,n,low,igh,ar,ai,temp(i2),temp(i3))
  call comqr2(ka,n,low,igh,temp(i2),temp(i3),ar,ai,wr,wi,zr,zi,ierr)
  if (ierr /= 0) return
  if (ibal /= 0) call cbabk2(ka,n,low,igh,temp(i1),n,zr,zi)
  return
end
subroutine cerf (mo, z, w)
!
!*******************************************************************************
!
!! CERF: computation of the complex error function
!
!
!                        w = erf(z)   if mo = 0
!                        w = erfc(z)  otherwise
!
!
  complex z, w
  real cd(18), ce(18), ef(2), qf(2), sm(2), sz(2), tm(2), ts(2)
!
!     c = 1/sqrt(pi)
!
  data c /.564189583547756/
!
  data cd(1) /0.00000000000000e00/,  cd(2) /2.08605856013476e-2/, &
       cd(3) /8.29806940495687e-2/,  cd(4) /1.85421653326079e-1/, &
       cd(5) /3.27963479382361e-1/,  cd(6) /5.12675279912828e-1/, &
       cd(7) /7.45412958045105e-1/,  cd(8) /1.03695067418297e00/, &
       cd(9) /1.40378061255437e00/,  cd(10)/1.86891662214001e00/, &
       cd(11)/2.46314830523929e00/,  cd(12)/3.22719383737352e00/, &
       cd(13)/4.21534348280013e00/,  cd(14)/5.50178873151549e00/, &
       cd(15)/7.19258966683102e00/,  cd(16)/9.45170208076408e00/, &
       cd(17)/1.25710718314784e+1/,  cd(18)/1.72483537216334e+1/
  data ce(1) /8.15723083324096e-2/,  ce(2) /1.59285285253437e-1/, &
       ce(3) /1.48581625614499e-1/,  ce(4) /1.33219670836245e-1/, &
       ce(5) /1.15690392878957e-1/,  ce(6) /9.78580959447535e-2/, &
       ce(7) /8.05908834297624e-2/,  ce(8) /6.40204538609872e-2/, &
       ce(9) /4.81445242767885e-2/,  ce(10)/3.33540658473295e-2/, &
       ce(11)/2.05548099470193e-2/,  ce(12)/1.07847403887506e-2/, &
       ce(13)/4.55634892214219e-3/,  ce(14)/1.43984458138925e-3/, &
       ce(15)/3.07056139834171e-4/,  ce(16)/3.78156541168541e-5/, &
       ce(17)/2.05173509616121e-6/,  ce(18)/2.63564823682747e-8/
!
  x = real(z)
  y = aimag(z)
  sn = 1.0
  if (x >= 0.0) go to 10
     x = -x
     y = -y
     sn = -1.0
!
   10 r = x*x + y*y
  sz(1) = x*x - y*y
  sz(2) = 2.0*x*y
!
  if (r <= 1.0) go to 20
  if (r >= 38.0) go to 60
  if (sz(1) + 0.064*sz(2)*sz(2) > 0.0) go to 50
!
!                       taylor series
!
   20 c2 = c + c
  tm(1) = c2*x
  tm(2) = c2*y
  sm(1) = tm(1)
  sm(2) = tm(2)
  pm = 0.0
   30    pm = pm + 1.0
     dm = 2.0*pm + 1.0
     ts(1) = tm(1)*sz(1) - tm(2)*sz(2)
     ts(2) = tm(1)*sz(2) + tm(2)*sz(1)
     tm(1) = -ts(1)/pm
     tm(2) = -ts(2)/pm
     ts(1) = tm(1)/dm
     ts(2) = tm(2)/dm
     if (abs(sm(1)) + abs(ts(1)) /= abs(sm(1))) go to 31
     if (abs(sm(2)) + abs(ts(2)) == abs(sm(2))) go to 40
   31    sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     go to 30
!
!                       termination
!
   40 if (mo /= 0) go to 41
     w = cmplx(sn*sm(1), sn*sm(2))
     return
   41 if (sn < 0.0) go to 42
     sm(1) = 0.5 + (0.5 - sm(1))
     sm(2) = -sm(2)
     w = cmplx(sm(1), sm(2))
     return
   42 w = cmplx(1.0 + sm(1), sm(2))
  return
!
!              rational function approximation
!
   50 sm(1) = 0.0
  sm(2) = 0.0
  qm = c*exp(-sz(1))
  ts(1) = qm*cos(-sz(2))
  ts(2) = qm*sin(-sz(2))
  qf(1) = ts(1)*x - ts(2)*y
  qf(2) = ts(1)*y + ts(2)*x
  do 51 i = 1,18
     ts(1) = sz(1) + cd(i)
     ts(2) = sz(2)
     ss = ts(1)*ts(1) + ts(2)*ts(2)
     tm(1) =  ce(i)*ts(1)/ss
     tm(2) = -ce(i)*ts(2)/ss
     sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
   51 continue
  ef(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ef(2) = qf(1)*sm(2) + qf(2)*sm(1)
  go to 100
!
!                   asymptotic expansion
!
   60 qf(1) =  sz(1)/(r*r)
  qf(2) = -sz(2)/(r*r)
  qm = c*exp(-sz(1))
  ts(1) = qm*cos(-sz(2))
  ts(2) = qm*sin(-sz(2))
  tm(1) =  (ts(1)*x + ts(2)*y)/r
  tm(2) = -(ts(1)*y - ts(2)*x)/r
  sm(1) = tm(1)
  sm(2) = tm(2)
  pm = -0.5
   70    pm = pm + 1.0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = -pm*ts(1)
     tm(2) = -pm*ts(2)
     if (abs(sm(1)) + abs(tm(1)) /= abs(sm(1))) go to 71
     if (abs(sm(2)) + abs(tm(2)) == abs(sm(2))) go to 80
   71    sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
     if (pm < 25.5) go to 70
!
   80 if (x >= 0.01) go to 81
     sn = -sn
     go to 40
   81 ef(1) = sm(1)
  ef(2) = sm(2)
!
!                       termination
!
  100 if (mo == 0) go to 101
     w = cmplx(ef(1), ef(2))
     if (sn == 1.0) return
     w = cmplx(2.0 - ef(1), -ef(2))
     return
  101 ef(1) = sn*(1.0 - ef(1))
  ef(2) = -sn*ef(2)
  w = cmplx(ef(1),ef(2))
  return
end
subroutine cerfc (mo, z, w)
!
!*******************************************************************************
!
!! CERFC: computation of the complex coerror function
!
!
!
!           w = erfc(z)           if mo = 0 or real(z) < 0
!           w = exp(x*x)*erfc(z)  otherwise
!
!
  complex z, w
  real cd(18), ce(18), qf(2), sm(2), sz(2), tm(2), ts(2)
!
!     c = 1/sqrt(pi)
!
  data c /.564189583547756/
!
  data cd(1) /0.00000000000000e00/,  cd(2) /2.08605856013476e-2/, &
       cd(3) /8.29806940495687e-2/,  cd(4) /1.85421653326079e-1/, &
       cd(5) /3.27963479382361e-1/,  cd(6) /5.12675279912828e-1/, &
       cd(7) /7.45412958045105e-1/,  cd(8) /1.03695067418297e00/, &
       cd(9) /1.40378061255437e00/,  cd(10)/1.86891662214001e00/, &
       cd(11)/2.46314830523929e00/,  cd(12)/3.22719383737352e00/, &
       cd(13)/4.21534348280013e00/,  cd(14)/5.50178873151549e00/, &
       cd(15)/7.19258966683102e00/,  cd(16)/9.45170208076408e00/, &
       cd(17)/1.25710718314784e+1/,  cd(18)/1.72483537216334e+1/
  data ce(1) /8.15723083324096e-2/,  ce(2) /1.59285285253437e-1/, &
       ce(3) /1.48581625614499e-1/,  ce(4) /1.33219670836245e-1/, &
       ce(5) /1.15690392878957e-1/,  ce(6) /9.78580959447535e-2/, &
       ce(7) /8.05908834297624e-2/,  ce(8) /6.40204538609872e-2/, &
       ce(9) /4.81445242767885e-2/,  ce(10)/3.33540658473295e-2/, &
       ce(11)/2.05548099470193e-2/,  ce(12)/1.07847403887506e-2/, &
       ce(13)/4.55634892214219e-3/,  ce(14)/1.43984458138925e-3/, &
       ce(15)/3.07056139834171e-4/,  ce(16)/3.78156541168541e-5/, &
       ce(17)/2.05173509616121e-6/,  ce(18)/2.63564823682747e-8/
!
  x = real(z)
  y = aimag(z)
  sn = 1.0
  if (x >= 0.0) go to 10
     x = -x
     y = -y
     sn = -1.0
!
   10 if (mo /= 0  .and.  sn == 1.0  .and. &
     max ( x, abs(y)) >= 100.0) go to 60
  r = x*x + y*y
  sz(1) = x*x - y*y
  sz(2) = 2.0*x*y
!
  if (r <= 1.0) go to 20
  if (r >= 38.0) go to 60
  if (sz(1) + 0.064*sz(2)*sz(2) > 0.0) go to 50
!
!                       taylor series
!
   20 c2 = c + c
  tm(1) = c2*x
  tm(2) = c2*y
  sm(1) = tm(1)
  sm(2) = tm(2)
  pm = 0.0
   30    pm = pm + 1.0
     dm = 2.0*pm + 1.0
     ts(1) = tm(1)*sz(1) - tm(2)*sz(2)
     ts(2) = tm(1)*sz(2) + tm(2)*sz(1)
     tm(1) = -ts(1)/pm
     tm(2) = -ts(2)/pm
     ts(1) = tm(1)/dm
     ts(2) = tm(2)/dm
     if (abs(sm(1)) + abs(ts(1)) /= abs(sm(1))) go to 31
     if (abs(sm(2)) + abs(ts(2)) == abs(sm(2))) go to 40
   31    sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     go to 30
!
!                       termination
!
   40 if (sn == 1.0) go to 41
     w = cmplx(1.0 + sm(1), sm(2))
     return
   41 sm(1) = 0.5 + (0.5 - sm(1))
  sm(2) = -sm(2)
  if (mo == 0) go to 110
!
  qm = exp(sz(1))
  qf(1) = qm*cos(sz(2))
  qf(2) = qm*sin(sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  w = cmplx(ts(1),ts(2))
  return
!
!              rational function approximation
!
   50 sm(1) = 0.0
  sm(2) = 0.0
  do 51 i = 1,18
     ts(1) = sz(1) + cd(i)
     ts(2) = sz(2)
     ss = ts(1)*ts(1) + ts(2)*ts(2)
     tm(1) =  ce(i)*ts(1)/ss
     tm(2) = -ce(i)*ts(2)/ss
     sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
   51 continue
  ts(1) = x*sm(1) - y*sm(2)
  ts(2) = x*sm(2) + y*sm(1)
  sm(1) = c*ts(1)
  sm(2) = c*ts(2)
  go to 100
!
!                   asymptotic expansion
!
   60 call crec (x, y, tm(1), tm(2))
  sm(1) = tm(1)
  sm(2) = tm(2)
  qf(1) = tm(1)*tm(1) - tm(2)*tm(2)
  qf(2) = 2.0*tm(1)*tm(2)
  pm = -0.5
   70    pm = pm + 1.0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = -pm*ts(1)
     tm(2) = -pm*ts(2)
     if (abs(sm(1)) + abs(tm(1)) /= abs(sm(1))) go to 71
     if (abs(sm(2)) + abs(tm(2)) == abs(sm(2))) go to 80
   71    sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
     if (pm < 25.5) go to 70
   80 sm(1) = c*sm(1)
  sm(2) = c*sm(2)
  if (x < 0.01) go to 200
!
!                       termination
!
  100 if (mo /= 0 .and. sn == 1.0) go to 110
  qm = exp(-sz(1))
  qf(1) = qm*cos(-sz(2))
  qf(2) = qm*sin(-sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = ts(1)
  sm(2) = ts(2)
!
  if (sn == 1.0) go to 110
     w = cmplx(2.0 - sm(1), -sm(2))
     return
  110 w = cmplx(sm(1), sm(2))
  return
!
!               modified asymptotic expansion
!
  200 if (mo /= 0 .and. sn == 1.0) go to 210
  qm = exp(-sz(1))
  qf(1) = qm*cos(-sz(2))
  qf(2) = qm*sin(-sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = 1.0 + sn*ts(1)
  sm(2) = sn*ts(2)
  w = cmplx(sm(1),sm(2))
  return
!
  210 if (abs(y) >= 100.0) go to 110
  if (sz(1) <= exparg(1)) go to 110
  qm = exp(sz(1))
  sm(1) = qm*cos(sz(2)) + sm(1)
  sm(2) = qm*sin(sz(2)) + sm(2)
  w = cmplx(sm(1),sm(2))
  return
end
subroutine cerr (t, ft, gt, phit, del, ierr, l, lp1, m, np1, d)
!
!*******************************************************************************
!
!! CERR: compute the approximation error at point t
!
  double precision t, ft, gt, phit, del, d(np1)
  double precision p, q, r, zero, one
  data zero/0.d0/, one/1.d0/
!
  p = d(lp1)
  if (l <= 0) go to 20
  do 10 i = 1,l
  ii = lp1 - i
   10 p = p*phit + d(ii)
!
   20 q = zero
  if (m <= 0) go to 22
  do 21 i = 1,m
  ii = np1 - i
   21 q = (q + d(ii))*phit
   22 q = q + one
!
  if (q == zero) go to 110
  if (gt == zero) go to 100
  r = p/q
  del = (r - ft)/gt
  return
!
!     error return
!
!     the function g is zero at point t
!
  100 ierr = 1
  return
!
!     the routine has completely failed - the results should be ignored
!
  110 ierr = 6
  return
end
subroutine cexpli (mo, z, w)
!
!*******************************************************************************
!
!! CEXPLI: evaluation of the complex exponential integral
!
  real euler_constant
  complex w
  complex z
  real n, np1
  real cd(18), ce(18)
  real qf(2), sm(2), tm(2), ts(2)
  real g0(2), gn(2), h0(2), hn(2), wn(2)
  logical ind
!
  anorm(x,y) = max ( abs(x),abs(y))
!
  data pi /3.14159265358979/
!
  data cd(1)  /0.00000000000000e+00/, cd(2)  /.311105957086528e-01/, &
       cd(3)  /.103661260539112e+00/, cd(4)  /.216532335244554e+00/, &
       cd(5)  /.369931427960192e+00/, cd(6)  /.566766259990589e+00/, &
       cd(7)  /.814042066324748e+00/, cd(8)  /.112384247540813e+01/, &
       cd(9)  /.151400478148512e+01/, cd(10) /.200886795032284e+01/, &
       cd(11) /.264052411823592e+01/, cd(12) /.345098449933392e+01/, &
       cd(13) /.449583360763202e+01/, cd(14) /.585058263409822e+01/, &
       cd(15) /.762273501463380e+01/, cd(16) /.997814501584578e+01/, &
       cd(17) /.132122064896408e+02/, cd(18) /.180322948376021e+02/
  data ce(1)  /.850156516121093e-02/, ce(2)  /.505037465849058e-01/, &
       ce(3)  /.836817368956407e-01/, ce(4)  /.107047582417607e+00/, &
       ce(5)  /.120424719029462e+00/, ce(6)  /.125096631582229e+00/, &
       ce(7)  /.122314435224685e+00/, ce(8)  /.112621417553907e+00/, &
       ce(9)  /.963419407392582e-01/, ce(10) /.747398422757511e-01/, &
       ce(11) /.508596135953441e-01/, ce(12) /.290822706773628e-01/, &
       ce(13) /.132201640530101e-01/, ce(14) /.443802939829067e-02/, &
       ce(15) /.992612478987576e-03/, ce(16) /.126579795112011e-03/, &
       ce(17) /.702150908253350e-05/, ce(18) /.910281532564632e-07/
!
                  eps = epsilon ( eps )
!
  x = real(z)
  y = aimag(z)
  r = cpabs(x,y)
  eps = max ( eps,1.e-15)
!
  if (r <= 1.0) go to 20
  if (r >= 40.0) go to 60
  if (r < 4.0) go to 10
     if (x <= 0.0 .or. abs(y) > 8.0) go to 60
     if (r < 10.0 .and. abs(y) > 1.8*x) go to 60
     go to 20
   10 if (x < 0.09*y*y) go to 50
  if (r > 3.6 .and. abs(y)  >  1.8*x) go to 60
!
!                        taylor series
!
   20 sm(1) = 0.0
  sm(2) = 0.0
  tm(1) = x
  tm(2) = y
  n = 1.0
   30    n = n + 1.0
     ts(1) = tm(1)*x - tm(2)*y
     ts(2) = tm(1)*y + tm(2)*x
     tm(1) = ts(1)/n
     tm(2) = ts(2)/n
     ts(1) = tm(1)/n
     ts(2) = tm(2)/n
     sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     if (anorm(ts(1),ts(2)) > eps*anorm(sm(1),sm(2))) &
          go to 30
  sm(1) = x + sm(1)
  sm(2) = y + sm(2)

  sm(1) = ( euler_constant ( ) + alog(r)) + sm(1)
  sm(2) = atan2(-y, -x) + sm(2)
  go to 110
!
!                      rational expansion
!
   50 sm(1) = 0.0
  sm(2) = 0.0
  do 51 i = 1,18
     ts(1) = x - cd(i)
     ts(2) = y
     ss = ts(1)*ts(1) + ts(2)*ts(2)
     sm(1) = sm(1) + ce(i)*ts(1)/ss
     sm(2) = sm(2) - ce(i)*ts(2)/ss
   51 continue
  go to 100
!
!         pade approximation for the asymptotic expansion
!                       for exp(-z)*ei(z)
!
   60 x = - x
  y = - y
  d = 4.0*r
  if (r < 10.0) d = 32.0
  g0(1) = 1.0
  g0(2) = 0.0
  gn(1) = (1.0 + x)/d
  gn(2) = y/d
  h0(1) = 1.0
  h0(2) = 0.0
  u = x + 2.0
  hn(1) = u/d
  hn(2) = gn(2)
  w = cmplx(1.0 + x, y)/cmplx(u,y)
  wn(1) = real(w)
  wn(2) = aimag(w)
  np1 = 1.0
  tol = 4.0*eps
!
   70    n = np1
     np1 = n + 1.0
     e = (n*np1)/d
     u = u + 2.0
     tm(1) = ((u*gn(1) - y*gn(2)) - e*g0(1))/d
     tm(2) = ((u*gn(2) + y*gn(1)) - e*g0(2))/d
     g0(1) = gn(1)
     g0(2) = gn(2)
     gn(1) = tm(1)
     gn(2) = tm(2)
     tm(1) = ((u*hn(1) - y*hn(2)) - e*h0(1))/d
     tm(2) = ((u*hn(2) + y*hn(1)) - e*h0(2))/d
     h0(1) = hn(1)
     h0(2) = hn(2)
     hn(1) = tm(1)
     hn(2) = tm(2)
!
     tm(1) = wn(1)
     tm(2) = wn(2)
     w = cmplx(gn(1),gn(2))/cmplx(hn(1),hn(2))
     wn(1) = real(w)
     wn(2) = aimag(w)
     if (anorm(tm(1) - wn(1), tm(2) - wn(2)) > &
           tol*anorm(wn(1), wn(2))) go to 70
!
  x = real(z)
  y = aimag(z)
  w = w/z
  sm(1) = real(w)
  sm(2) = aimag(w)
!
!                         termination
!
  100 ind = x <= 0.0 .or. abs(y) > 1.e-2
  if (ind .and. mo /= 0) go to 130
  c = pi
  if (y > 0.0) c = -pi
  qm = exp(x)
  cy = cos(y)
  sy = sin(y)
  qf(1) = qm*cy
  qf(2) = qm*sy
  if (mo == 0) go to 120
!
  r = c/qm
  sm(1) = sm(1) + r*sy
  sm(2) = sm(2) + r*cy
  go to 130
!
  110 if (mo == 0) go to 130
  ind = .true.
  qm = exp(-x)
  qf(1) = qm*cos(-y)
  qf(2) = qm*sin(-y)
!
  120 ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = ts(1)
  sm(2) = ts(2)
  if (.not. ind) sm(2) = sm(2) + c
!
  130 w = cmplx(sm(1),sm(2))
  return
end
function cflect(z)
!
!*******************************************************************************
!
!! CFLECT: reflects z with respect to the origin if real(z)
!     < 0.0 or if z is on the negative imaginary axis.
!
  complex cflect
  complex z
!
  if (real(z)) 10,20,30
   10 cflect = -z
  return
   20 cflect = cmplx(0.0, abs(aimag(z)))
  return
   30 cflect = z
  return
end
subroutine cfod  (meth, elco, tesco)
!
!*******************************************************************************
!
!! CFOD defines coefficients needed in the integrator package sfode
!
  integer meth, i, ib, nq, nqm1, nqp1
  real elco, tesco, agamq, fnq, fnqm1, pc, pint, ragq, &
     rqfac, rq1fac, tsign, xpin
  dimension elco(13, *), tesco(3, *)
!
! cfod  is called by the integrator routine to set coefficients
! needed there.  the coefficients for the current method, as
! given by the value of meth, are set for all orders and saved.
! the maximum order assumed here is 12 if meth = 1 and 5 if meth = 2.
! (a smaller value of the maximum order is also allowed.)
! cfod  is called once at the beginning of the problem,
! and is not called again unless and until meth is changed.
!
! the elco array contains the basic method coefficients.
! the coefficients el(i), 1 <= i <= nq+1, for the method of
! order nq are stored in elco(i,nq).  they are given by a genetrating
! polynomial, i.e.,
!     l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq.
! for the implicit adams methods, l(x) is given by
!     dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1),    l(-1) = 0.
! for the bdf methods, l(x) is given by
!     l(x) = (x+1)*(x+2)* ... *(x+nq)/k,
! where         k = factorial(nq)*(1 + 1/2 + ... + 1/nq).
!
! the tesco array contains test constants used for the
! local error test and the selection of step size and/or order.
! at order nq, tesco(k,nq) is used for the selection of step
! size at order nq - 1 if k = 1, at order nq if k = 2, and at order
! nq + 1 if k = 3.
!
  dimension pc(12)
!
  go to (100, 200), meth
!
 100  elco(1,1) = 1.0e0
  elco(2,1) = 1.0e0
  tesco(1,1) = 0.0e0
  tesco(2,1) = 2.0e0
  tesco(1,2) = 1.0e0
  tesco(3,12) = 0.0e0
  pc(1) = 1.0e0
  rqfac = 1.0e0
  do 140 nq = 2,12
!
! the pc array will contain the coefficients of the polynomial
!     p(x) = (x+1)*(x+2)*...*(x+nq-1).
! initially, p(x) = 1.
!
    rq1fac = rqfac
    rqfac = rqfac/real(nq)
    nqm1 = nq - 1
    fnqm1 = real(nqm1)
    nqp1 = nq + 1
! form coefficients of p(x)*(x+nq-1).
    pc(nq) = 0.0e0
    do 110 ib = 1,nqm1
      i = nqp1 - ib
 110      pc(i) = pc(i-1) + fnqm1*pc(i)
    pc(1) = fnqm1*pc(1)
! compute integral, -1 to 0, of p(x) and x*p(x).
    pint = pc(1)
    xpin = pc(1)/2.0e0
    tsign = 1.0e0
    do 120 i = 2,nq
      tsign = -tsign
      pint = pint + tsign*pc(i)/real(i)
 120      xpin = xpin + tsign*pc(i)/real(i+1)
! store coefficients in elco and tesco.
    elco(1,nq) = pint*rq1fac
    elco(2,nq) = 1.0e0
    do 130 i = 2,nq
 130      elco(i+1,nq) = rq1fac*pc(i)/real(i)
    agamq = rqfac*xpin
    ragq = 1.0e0/agamq
    tesco(2,nq) = ragq
  if(nq < 12)tesco(1,nqp1)=ragq*rqfac/real(nqp1)
    tesco(3,nqm1) = ragq
 140    continue
  return
!
 200  pc(1) = 1.0e0
  rq1fac = 1.0e0
  do 230 nq = 1,5
!
! the pc array will contain the coefficients of the polynomial
!     p(x) = (x+1)*(x+2)*...*(x+nq).
! initially, p(x) = 1.
!
    fnq = real(nq)
    nqp1 = nq + 1
! form coefficients of p(x)*(x+nq).
    pc(nqp1) = 0.0e0
    do 210 ib = 1,nq
      i = nq + 2 - ib
 210      pc(i) = pc(i-1) + fnq*pc(i)
    pc(1) = fnq*pc(1)
! store coefficients in elco and tesco.
    do 220 i = 1,nqp1
 220      elco(i,nq) = pc(i)/pc(2)
    elco(2,nq) = 1.0e0
    tesco(1,nq) = rq1fac
    tesco(2,nq) = real(nqp1)/elco(1,nq)
    tesco(3,nq) = real(nq+2)/elco(1,nq)
    rq1fac = rq1fac/fnq
 230    continue
  return
!-- end of subroutine cfod
end
subroutine cfrnli (mo, z, w)
!
!*******************************************************************************
!
!! CFRNLI: computation of the complex Fresnel integral e(z)
!
!
!                      w = e(z)          if mo = 0
!                      w = exp(-z)*e(z)  otherwise
!
!
  complex z, w
  real cd(18), ce(18), qf(2), sm(2), tm(2), ts(2), zr(2)
!
!     c = 1/sqrt(pi)
!     c0 = -1/sqrt(2)
!
  data c  / .564189583547756/
  data c0 /-.707106781186548/
!
  data cd(1) /0.00000000000000e00/,  cd(2) /2.08605856013476e-2/, &
       cd(3) /8.29806940495687e-2/,  cd(4) /1.85421653326079e-1/, &
       cd(5) /3.27963479382361e-1/,  cd(6) /5.12675279912828e-1/, &
       cd(7) /7.45412958045105e-1/,  cd(8) /1.03695067418297e00/, &
       cd(9) /1.40378061255437e00/,  cd(10)/1.86891662214001e00/, &
       cd(11)/2.46314830523929e00/,  cd(12)/3.22719383737352e00/, &
       cd(13)/4.21534348280013e00/,  cd(14)/5.50178873151549e00/, &
       cd(15)/7.19258966683102e00/,  cd(16)/9.45170208076408e00/, &
       cd(17)/1.25710718314784e+1/,  cd(18)/1.72483537216334e+1/
  data ce(1) /8.15723083324096e-2/,  ce(2) /1.59285285253437e-1/, &
       ce(3) /1.48581625614499e-1/,  ce(4) /1.33219670836245e-1/, &
       ce(5) /1.15690392878957e-1/,  ce(6) /9.78580959447535e-2/, &
       ce(7) /8.05908834297624e-2/,  ce(8) /6.40204538609872e-2/, &
       ce(9) /4.81445242767885e-2/,  ce(10)/3.33540658473295e-2/, &
       ce(11)/2.05548099470193e-2/,  ce(12)/1.07847403887506e-2/, &
       ce(13)/4.55634892214219e-3/,  ce(14)/1.43984458138925e-3/, &
       ce(15)/3.07056139834171e-4/,  ce(16)/3.78156541168541e-5/, &
       ce(17)/2.05173509616121e-6/,  ce(18)/2.63564823682747e-8/
!
  x = real(z)
  y = aimag(z)
  r = cpabs(x, y)
  if (r == 0.0) go to 200
!
!              evaluation of zr = sqrt(2*z/pi)
!
  if (x >= 0.0) go to 10
     zr(2) = sqrt(r - x)
     zr(1) = y/zr(2)
     go to 11
   10 zr(1) = sqrt(r + x)
  if (y < 0.0) zr(1) = -zr(1)
  zr(2) = y/zr(1)
   11 zr(1) = c*zr(1)
  zr(2) = c*zr(2)
!
  if (r <= 1.0) go to 20
  if (r >= 38.0) go to 60
  if (x < 0.016*y*y) go to 50
!
!                       taylor series
!
   20 sm(1) = 0.0
  sm(2) = 0.0
  tm(1) = zr(1)
  tm(2) = zr(2)
  pm = 0.0
   30    pm = pm + 1.0
     dm = 2.0*pm + 1.0
     ts(1) = tm(1)*x - tm(2)*y
     ts(2) = tm(1)*y + tm(2)*x
     tm(1) = ts(1)/pm
     tm(2) = ts(2)/pm
     ts(1) = tm(1)/dm
     ts(2) = tm(2)/dm
     if (abs(sm(1)) + abs(ts(1)) /= abs(sm(1))) go to 31
     if (abs(sm(2)) + abs(ts(2)) == abs(sm(2))) go to 40
   31    sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     go to 30
   40 sm(1) = zr(1) + sm(1)
  sm(2) = (c0 + zr(2)) + sm(2)
!
  if (mo == 0) go to 120
  qm = exp(-x)
  qf(1) = qm*cos(-y)
  qf(2) = qm*sin(-y)
  go to 110
!
!              rational function approximation
!
   50 sm(1) = 0.0
  sm(2) = 0.0
  do 51 i = 1,18
     ts(1) = x - cd(i)
     ts(2) = y
     ss = ts(1)*ts(1) + ts(2)*ts(2)
     tm(1) =  ce(i)*ts(1)/ss
     tm(2) = -ce(i)*ts(2)/ss
     sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
   51 continue
  ts(1) = zr(1)*sm(1) - zr(2)*sm(2)
  ts(2) = zr(1)*sm(2) + zr(2)*sm(1)
  sm(1) = 0.5*ts(1)
  sm(2) = 0.5*ts(2)
  go to 100
!
!                   asymptotic expansion
!
   60 qf(1) = (x/r)/r
  qf(2) = -(y/r)/r
  tm(1) = qf(1)
  tm(2) = qf(2)
  sm(1) = tm(1)
  sm(2) = tm(2)
  pm = -0.5
   70    pm = pm + 1.0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = pm*ts(1)
     tm(2) = pm*ts(2)
     if (abs(sm(1)) + abs(tm(1)) /= abs(sm(1))) go to 71
     if (abs(sm(2)) + abs(tm(2)) == abs(sm(2))) go to 80
   71    sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
     if (pm < 25.5) go to 70
   80 ts(1) = zr(1)*sm(1) - zr(2)*sm(2)
  ts(2) = zr(1)*sm(2) + zr(2)*sm(1)
  sm(1) = 0.5*ts(1)
  sm(2) = 0.5*ts(2)
  if (zr(2) < 8.e-3) go to 210
!
!                       termination
!
  100 if (mo /= 0) go to 120
  qm = exp(x)
  qf(1) = qm*cos(y)
  qf(2) = qm*sin(y)
!
  110 ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = ts(1)
  sm(2) = ts(2)
!
  120 w = cmplx(sm(1),sm(2))
  return
!
!                      case when z = 0
!
  200 w = cmplx(0.0,c0)
  return
!
!               modified asymptotic expansion
!
  210 if (mo /= 0) go to 220
  qm = exp(x)
  qf(1) = qm*cos(y)
  qf(2) = qm*sin(y)
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  w = cmplx(ts(1), c0 + ts(2))
  return
!
  220 if (-x <= exparg(1)) go to 120
  qm = c0*exp(-x)
  sm(1) = sm(1) + qm*sin(y)
  sm(2) = sm(2) + qm*cos(y)
  w = cmplx(sm(1),sm(2))
  return
end
subroutine cgamma (mo, z, w)
!
!*******************************************************************************
!
!! CGAMMA: evaluation of the complex gamma and loggamma functions
!
!
!     mo is an integer, z a complex argument, and w a complex variable.
!
!                 w = gamma(z)       if mo = 0
!                 w = ln(gamma(z))   otherwise
!
!
  integer imax
  complex z, w
  complex eta, eta2, sum
  real c0(12)
!
!     alpi = log(pi)
!     hl2p = 0.5 * log(2*pi)
!
  data pi  /3.14159265358979/
  data pi2 /6.28318530717959/
  data alpi/1.14472988584940/
  data hl2p/.918938533204673/
!
  data c0(1) /.833333333333333e-01/, c0(2) /-.277777777777778e-02/, &
       c0(3) /.793650793650794e-03/, c0(4) /-.595238095238095e-03/, &
       c0(5) /.841750841750842e-03/, c0(6) /-.191752691752692e-02/, &
       c0(7) /.641025641025641e-02/, c0(8) /-.295506535947712e-01/, &
       c0(9) /.179644372368831e+00/, c0(10)/-.139243221690590e+01/, &
       c0(11)/.134028640441684e+02/, c0(12)/-.156848284626002e+03/
!
  imax = huge ( imax )
  eps = epsilon ( eps )
  x = real(z)
  y = aimag(z)
  if (x >= 0.0) go to 50
!
!            case when the real part of z is negative
!
  y = abs(y)
  t = -pi*y
  et = exp(t)
  e2t = et*et
!
!     set  a1 = (1 + e2t)/2  and  a2 = (1 - e2t)/2
!
  a1 = 0.5*(1.0 + e2t)
  t2 = t + t
  if (t2 < -0.15) go to 10
     a2 = -0.5*rexp(t2)
     go to 20
   10 a2 = 0.5*(0.5 + (0.5 - e2t))
!
!     compute sin(pi*x) and cos(pi*x)
!
   20 if (abs(x) >= amin1(real(imax), 1.0/eps)) go to 200
  k = abs(x)
  u = x + k
  k = mod(k,2)
  if (u > -0.5) go to 21
     u = 0.5 + (0.5 + u)
     k = k + 1
   21 u = pi*u
  sn = sin(u)
  cn = cos(u)
  if (k /= 1) go to 30
  sn = -sn
  cn = -cn
!
!     set  h1 + h2*i  to  pi/sin(pi*z)  or  log(pi/sin(pi*z))
!
   30 a1 = sn*a1
  a2 = cn*a2
  a = a1*a1 + a2*a2
  if (a == 0.0) go to 200
  if (mo /= 0) go to 40
!
  h1 = a1/a
  h2 = -a2/a
  c = pi*et
  h1 = c*h1
  h2 = c*h2
  go to 41
!
   40 h1 = (alpi + t) - 0.5*alog(a)
  h2 = -atan2(a2,a1)
   41 if (aimag(z) < 0.0) go to 42
     x = 1.0 - x
     y = -y
     go to 50
   42 h2 = -h2
  x = 1.0 - x
!
!           case when the real part of z is nonnegative
!
   50 w1 = 0.0
  w2 = 0.0
  n = 0
  t = x
  y2 = y*y
  a = t*t + y2
  cut = 36.0
  if (eps > 1.e-8) cut = 16.0
  if (a >= cut) go to 80
  if (a == 0.0) go to 200
   51    n = n + 1
     t = t + 1.0
     a = t*t + y2
     if (a < cut) go to 51
!
!     let s1 + s2*i be the product of the terms (z+j)/(z+n)
!
  u1 = (x*t + y2)/a
  u2 = y/a
  s1 = u1
  s2 = n*u2
  if (n < 2) go to 70
  u = t/a
  nm1 = n - 1
  do 60 j = 1,nm1
     v1 = u1 + j*u
     v2 = (n - j)*u2
     c = s1*v1 - s2*v2
     d = s1*v2 + s2*v1
     s1 = c
     s2 = d
   60 continue
!
!     set  w1 + w2*i = log(s1 + s2*i)  when mo is nonzero
!
   70 s = s1*s1 + s2*s2
  if (mo == 0) go to 80
  w1 = 0.5 * alog(s)
  w2 = atan2(s2,s1)
!
!     set  v1 + v2*i = (z - 0.5) * log(z + n) - z
!
   80 t1 = 0.5 * alog(a) - 1.0
  t2 = atan2(y,t)
  u = x - 0.5
  v1 = (u*t1 - 0.5) - y*t2
  v2 = u*t2 + y*t1
!
!     let a1 + a2*i be the asymptotic sum
!
  eta  = cmplx(t/a,-y/a)
  eta2 = eta*eta
  m = 12
  if (a >= 289.0) m = 6
  if (eps > 1.e-8) m = m/2
  sum  = cmplx(c0(m),0.0)
  l = m
  do 90 j = 2,m
     l = l - 1
     sum = cmplx(c0(l),0.0) + sum*eta2
   90 continue
  sum = sum*eta
  a1 = real(sum)
  a2 = aimag(sum)
!
!                 gathering together the results
!
  w1 = (((a1 + hl2p) - w1) + v1) - n
  w2 = (a2 - w2) + v2
  if (real(z) < 0.0) go to 120
  if (mo /= 0) go to 110
!
!     case when the real part of z is nonnegative and mo = 0
!
  a = exp(w1)
  w1 = a * cos(w2)
  w2 = a * sin(w2)
  if (n == 0) go to 140
  c = (s1*w1 + s2*w2)/s
  d = (s1*w2 - s2*w1)/s
  w1 = c
  w2 = d
  go to 140
!
!     case when the real part of z is nonnegative and mo is nonzero.
!     the angle w2 is reduced to the interval -pi < w2 <= pi.
!
  110 if (w2 > pi) go to 111
     k = 0.5 - w2/pi2
     w2 = w2 + pi2*k
     go to 140
  111 k = w2/pi2 - 0.5
  w2 = w2 - pi2*real(k + 1)
  if (w2 <= -pi) w2 = pi
  go to 140
!
!     case when the real part of z is negative and mo is nonzero
!
  120 if (mo == 0) go to 130
  w1 = h1 - w1
  w2 = h2 - w2
  go to 110
!
!     case when the real part of z is negative and mo = 0
!
  130 a = exp(-w1)
  t1 = a * cos(-w2)
  t2 = a * sin(-w2)
  w1 = h1*t1 - h2*t2
  w2 = h1*t2 + h2*t1
  if (n == 0) go to 140
  c = w1*s1 - w2*s2
  d = w1*s2 + w2*s1
  w1 = c
  w2 = d
!
!     termination
!
  140 w = cmplx(w1,w2)
  return
!
!             the requested value cannot be computed
!
  200 w = (0.0, 0.0)
  return
end
subroutine cgeco(a,lda,n,ipvt,rcond,z)
!
!*******************************************************************************
!
!! CGECO factors a complex matrix by gaussian elimination
!     and estimates the condition of the matrix.
!
!     if  rcond  is not needed, cgefa is slightly faster.
!     to solve  a*x = b , follow cgeco by cgesl.
!     to compute  inverse(a)*c , follow cgeco by cgesl.
!     to compute  determinant(a) , follow cgeco by cgedi.
!     to compute  inverse(a) , follow cgeco by cgedi.
!
!     on entry
!
!        a       complex(lda, n)
!                the matrix to be factored.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        a       an upper triangular matrix and the multipliers
!                which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l  is a product of permutation and unit lower
!                triangular matrices and  u  is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        rcond   real
!                an estimate of the reciprocal condition of  a .
!                for the system  a*x = b , relative perturbations
!                in  a  and  b  of size  epsilon  may cause
!                relative perturbations in  x  of size  epsilon/rcond .
!                if  rcond  is so small that the logical expression
!                           1.0 + rcond == 1.0
!                is true, then  a  may be singular to working
!                precision.  in particular,  rcond  is zero  if
!                exact singularity is detected or the estimate
!                underflows.
!
!        z       complex(n)
!                a work vector whose contents are usually unimportant.
!                if  a  is close to a singular matrix, then  z  is
!                an approximate null vector in the sense that
!                norm(a*z) = rcond*norm(a)*norm(z) .
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     linpack cgefa
!     blas caxpy,cdotc,csscal,scasum
!     fortran abs,aimag,cmplx,conjg,real
!
  integer lda,n,ipvt(*)
  complex a(lda,*),z(*)
  real rcond
!
!     internal variables
!
  complex cdotc,ek,t,wk,wkm
  real anorm,s,scasum,sm,ynorm
  integer info,j,k,kb,kp1,l
!
  complex zdum,zdum1,zdum2,csign1
  real cabs1
  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
  csign1(zdum1,zdum2) = cabs1(zdum1)*(zdum2/cabs1(zdum2))
!
!     compute 1-norm of a
!
  anorm = 0.0e0
  do 10 j = 1, n
     anorm = max ( anorm,scasum(n,a(1,j),1))
   10 continue
!
!     factor
!
  call cgefa(a,lda,n,ipvt,info)
!
!     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
!     estimate = norm(z)/norm(y) where  a*z = y  and  ctrans(a)*y = e .
!     ctrans(a)  is the conjugate transpose of a .
!     the components of  e  are chosen to cause maximum local
!     growth in the elements of w  where  ctrans(u)*w = e .
!     the vectors are frequently rescaled to avoid overflow.
!
!     solve ctrans(u)*w = e
!
  ek = (1.0e0,0.0e0)
  do 20 j = 1, n
     z(j) = (0.0e0,0.0e0)
   20 continue
  do 100 k = 1, n
     if (cabs1(z(k)) /= 0.0e0) ek = csign1(ek,-z(k))
     if (cabs1(ek-z(k)) <= cabs1(a(k,k))) go to 30
        s = cabs1(a(k,k))/cabs1(ek-z(k))
        call csscal(n,s,z,1)
        ek = cmplx(s,0.0e0)*ek
   30    continue
     wk = ek - z(k)
     wkm = -ek - z(k)
     s = cabs1(wk)
     sm = cabs1(wkm)
     if (cabs1(a(k,k)) == 0.0e0) go to 40
        wk = wk/conjg(a(k,k))
        wkm = wkm/conjg(a(k,k))
     go to 50
   40    continue
        wk = (1.0e0,0.0e0)
        wkm = (1.0e0,0.0e0)
   50    continue
     kp1 = k + 1
     if (kp1 > n) go to 90
        do 60 j = kp1, n
           sm = sm + cabs1(z(j)+wkm*conjg(a(k,j)))
           z(j) = z(j) + wk*conjg(a(k,j))
           s = s + cabs1(z(j))
   60       continue
        if (s >= sm) go to 80
           t = wkm - wk
           wk = wkm
           do 70 j = kp1, n
              z(j) = z(j) + t*conjg(a(k,j))
   70          continue
   80       continue
   90    continue
     z(k) = wk
  100 continue
  s = 1.0e0/scasum(n,z,1)
  call csscal(n,s,z,1)
!
!     solve ctrans(l)*y = w
!
  do 120 kb = 1, n
     k = n + 1 - kb
     if (k < n) z(k) = z(k) + cdotc(n-k,a(k+1,k),1,z(k+1),1)
     if (cabs1(z(k)) <= 1.0e0) go to 110
        s = 1.0e0/cabs1(z(k))
        call csscal(n,s,z,1)
  110    continue
     l = ipvt(k)
     t = z(l)
     z(l) = z(k)
     z(k) = t
  120 continue
  s = 1.0e0/scasum(n,z,1)
  call csscal(n,s,z,1)
!
  ynorm = 1.0e0
!
!     solve l*v = y
!
  do 140 k = 1, n
     l = ipvt(k)
     t = z(l)
     z(l) = z(k)
     z(k) = t
     if (k < n) call caxpy(n-k,t,a(k+1,k),1,z(k+1),1)
     if (cabs1(z(k)) <= 1.0e0) go to 130
        s = 1.0e0/cabs1(z(k))
        call csscal(n,s,z,1)
        ynorm = s*ynorm
  130    continue
  140 continue
  s = 1.0e0/scasum(n,z,1)
  call csscal(n,s,z,1)
  ynorm = s*ynorm
!
!     solve  u*z = v
!
  do 160 kb = 1, n
     k = n + 1 - kb
     if (cabs1(z(k)) <= cabs1(a(k,k))) go to 150
        s = cabs1(a(k,k))/cabs1(z(k))
        call csscal(n,s,z,1)
        ynorm = s*ynorm
  150    continue
     if (cabs1(a(k,k)) /= 0.0e0) z(k) = z(k)/a(k,k)
     if (cabs1(a(k,k)) == 0.0e0) z(k) = (1.0e0,0.0e0)
     t = -z(k)
     call caxpy(k-1,t,a(1,k),1,z(1),1)
  160 continue
!     make znorm = 1.0
  s = 1.0e0/scasum(n,z,1)
  call csscal(n,s,z,1)
  ynorm = s*ynorm
!
  if (anorm /= 0.0e0) rcond = ynorm/anorm
  if (anorm == 0.0e0) rcond = 0.0e0
  return
end
subroutine cgedi(a,lda,n,ipvt,det,work,job)
!
!*******************************************************************************
!
!! CGEDI computes the determinant and inverse of a matrix
!     using the factors computed by cgeco or cgefa.
!
!     on entry
!
!        a       complex(lda, n)
!                the output from cgeco or cgefa.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!        ipvt    integer(n)
!                the pivot vector from cgeco or cgefa.
!
!        work    complex(n)
!                work vector.  contents destroyed.
!
!        job     integer
!                = 11   both determinant and inverse.
!                = 01   inverse only.
!                = 10   determinant only.
!
!     on return
!
!        a       inverse of original matrix if requested.
!                otherwise unchanged.
!
!        det     complex(2)
!                determinant of original matrix if requested.
!                otherwise not referenced.
!                determinant = det(1) * 10.0**det(2)
!                with  1.0 <= cabs1(det(1)) < 10.0
!                or  det(1) == 0.0 .
!
!     error condition
!
!        a division by zero will occur if the input factor contains
!        a zero on the diagonal and the inverse is requested.
!        it will not occur if the subroutines are called correctly
!        and if cgeco has set rcond > 0.0 or cgefa has set
!        info == 0 .
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas caxpy,cscal,cswap
!     fortran abs,aimag,cmplx,mod,real
!
  integer lda,n,ipvt(*),job
  complex a(lda,*),det(2),work(*)
!
!     internal variables
!
  complex t
  real ten
  integer i,j,k,kb,kp1,l,nm1
!
  complex zdum
  real cabs1
  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
!
!     compute determinant
!
  if (job/10 == 0) go to 70
     det(1) = (1.0e0,0.0e0)
     det(2) = (0.0e0,0.0e0)
     ten = 10.0e0
     do 50 i = 1, n
        if (ipvt(i) /= i) det(1) = -det(1)
        det(1) = a(i,i)*det(1)
!        ...exit
        if (cabs1(det(1)) == 0.0e0) go to 60
   10       if (cabs1(det(1)) >= 1.0e0) go to 20
           det(1) = cmplx(ten,0.0e0)*det(1)
           det(2) = det(2) - (1.0e0,0.0e0)
        go to 10
   20       continue
   30       if (cabs1(det(1)) < ten) go to 40
           det(1) = det(1)/cmplx(ten,0.0e0)
           det(2) = det(2) + (1.0e0,0.0e0)
        go to 30
   40       continue
   50    continue
   60    continue
   70 continue
!
!     compute inverse(u)
!
  if (mod(job,10) == 0) go to 150
     do 100 k = 1, n
        a(k,k) = (1.0e0,0.0e0)/a(k,k)
        t = -a(k,k)
        call cscal(k-1,t,a(1,k),1)
        kp1 = k + 1
        if (n < kp1) go to 90
        do 80 j = kp1, n
           t = a(k,j)
           a(k,j) = (0.0e0,0.0e0)
           call caxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
!
!        form inverse(u)*inverse(l)
!
     nm1 = n - 1
     if (nm1 < 1) go to 140
     do 130 kb = 1, nm1
        k = n - kb
        kp1 = k + 1
        do 110 i = kp1, n
           work(i) = a(i,k)
           a(i,k) = (0.0e0,0.0e0)
  110       continue
        do 120 j = kp1, n
           t = work(j)
           call caxpy(n,t,a(1,j),1,a(1,k),1)
  120       continue
        l = ipvt(k)
        if (l /= k) call cswap(n,a(1,k),1,a(1,l),1)
  130    continue
  140    continue
  150 continue
  return
end
subroutine cgefa(a,lda,n,ipvt,info)
!
!*******************************************************************************
!
!! CGEFA factors a complex matrix by gaussian elimination.
!
!     cgefa is usually called by cgeco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!     (time for cgeco) = (1 + 9/n)*(time for cgefa) .
!
!     on entry
!
!        a       complex(lda, n)
!                the matrix to be factored.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        a       an upper triangular matrix and the multipliers
!                which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l  is a product of permutation and unit lower
!                triangular matrices and  u  is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if  u(k,k) == 0.0 .  this is not an error
!                     condition for this subroutine, but it does
!                     indicate that cgesl or cgedi will divide by zero
!                     if called.  use  rcond  in cgeco for a reliable
!                     indication of singularity.
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas caxpy,cscal,icamax
!     fortran abs,aimag,real
!
  integer lda,n,ipvt(*),info
  complex a(lda,*)
!
!     internal variables
!
  complex t
  integer icamax,j,k,kp1,l,nm1
!
  complex zdum
  real cabs1
  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
!
!     gaussian elimination with partial pivoting
!
  info = 0
  nm1 = n - 1
  if (nm1 < 1) go to 70
  do 60 k = 1, nm1
     kp1 = k + 1
!
!        find l = pivot index
!
     l = icamax(n-k+1,a(k,k),1) + k - 1
     ipvt(k) = l
!
!        zero pivot implies this column already triangularized
!
     if (cabs1(a(l,k)) == 0.0e0) go to 40
!
!           interchange if necessary
!
        if (l == k) go to 10
           t = a(l,k)
           a(l,k) = a(k,k)
           a(k,k) = t
   10       continue
!
!           compute multipliers
!
        t = -(1.0e0,0.0e0)/a(k,k)
        call cscal(n-k,t,a(k+1,k),1)
!
!           row elimination with column indexing
!
        do 30 j = kp1, n
           t = a(l,j)
           if (l == k) go to 20
              a(l,j) = a(k,j)
              a(k,j) = t
   20          continue
           call caxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
     go to 50
   40    continue
        info = k
   50    continue
   60 continue
   70 continue
  ipvt(n) = n
  if (cabs1(a(n,n)) == 0.0e0) info = n
  return
end
subroutine cgesl(a,lda,n,ipvt,b,job)
!
!*******************************************************************************
!
!! CGESL solves the complex system
!     a * x = b  or  ctrans(a) * x = b
!     using the factors computed by cgeco or cgefa.
!
!     on entry
!
!        a       complex(lda, n)
!                the output from cgeco or cgefa.
!
!        lda     integer
!                the leading dimension of the array  a .
!
!        n       integer
!                the order of the matrix  a .
!
!        ipvt    integer(n)
!                the pivot vector from cgeco or cgefa.
!
!        b       complex(n)
!                the right hand side vector.
!
!        job     integer
!                = 0         to solve  a*x = b ,
!                = nonzero   to solve  ctrans(a)*x = b  where
!                            ctrans(a)  is the conjugate transpose.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains a
!        zero on the diagonal.  technically this indicates singularity
!        but it is often caused by improper arguments or improper
!        setting of lda .  it will not occur if the subroutines are
!        called correctly and if cgeco has set rcond > 0.0
!        or cgefa has set info == 0 .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call cgeco(a,lda,n,ipvt,rcond,z)
!           if (rcond is too small) go to ...
!           do 10 j = 1, p
!              call cgesl(a,lda,n,ipvt,c(1,j),0)
!        10 continue
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas caxpy,cdotc
!     fortran conjg
!
  integer lda,n,ipvt(*),job
  complex a(lda,*),b(*)
!
!     internal variables
!
  complex cdotc,t
  integer k,kb,l,nm1
!
  nm1 = n - 1
  if (job /= 0) go to 50
!
!        job = 0 , solve  a * x = b
!        first solve  l*y = b
!
     if (nm1 < 1) go to 30
     do 20 k = 1, nm1
        l = ipvt(k)
        t = b(l)
        if (l == k) go to 10
           b(l) = b(k)
           b(k) = t
   10       continue
        call caxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
!
!        now solve  u*x = y
!
     do 40 kb = 1, n
        k = n + 1 - kb
        b(k) = b(k)/a(k,k)
        t = -b(k)
        call caxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
  go to 100
   50 continue
!
!        job = nonzero, solve  ctrans(a) * x = b
!        first solve  ctrans(u)*y = b
!
     do 60 k = 1, n
        t = cdotc(k-1,a(1,k),1,b(1),1)
        b(k) = (b(k) - t)/conjg(a(k,k))
   60    continue
!
!        now solve ctrans(l)*x = y
!
     if (nm1 < 1) go to 90
     do 80 kb = 1, nm1
        k = n - kb
        b(k) = b(k) + cdotc(n-k,a(k+1,k),1,b(k+1),1)
        l = ipvt(k)
        if (l == k) go to 70
           t = b(l)
           b(l) = b(k)
           b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
  return
end
subroutine cheby (a, b, f, g, phi, eps, itno, mxiter, l, m, &
                      p, q, error, ierr, w)
!
!*******************************************************************************
!
!! CHEBY: rational chebychev approximation of continuous functions
!
  double precision a, b, f, g, phi, eps, error
  double precision p(*), q(*), w(*)
  external f, g, phi
!
  if (l < 0 .or. m  <  0) go to 10
  lp1 = l + 1
  mp1 = m + 1
  lpm = l + m
  n = lpm + 1
  np1 = n + 1
!
  i1 = np1 + 1
  i2 = i1 + np1
  i3 = i2 + np1*np1
  i4 = i3 + np1
  i5 = i4 + np1
  call cheby1 (a, b, f, g, phi, eps, itno, mxiter, l, m, p, q, &
                error, ierr, lp1, mp1, lpm, n, np1, w(1), &
                w(i1), w(i2), w(i3), w(i4), w(i5))
  return
!
!     error return
!
   10 ierr = 1
  return
end
subroutine cheby1 (a, b, f, g, phi, eps, itno, mxiter, l, m, &
                     p, q, error, ierr, lp1, mp1, lpm, n, np1, &
                     x, xval, c, d, err, h)
!
!*******************************************************************************
!
!! CHEBY1 ???
!
  double precision a, b, f, g, phi, eps, error
  double precision p(lp1), q(mp1), x(np1), xval(np1), c(np1,np1), &
            d(np1), err(np1), h(np1)
  double precision b1, c0, del, dn, dnp1, eps0, half, h1, &
            olderr, one, pi, sign, sum, tau, templ, ten, test, &
            u, xi, xlb, xm1, y, y2, y3, z, zero, zz, z1, z2, z3
  external f, g, phi
!
  data pi/3.14159265358979323846264338328d0/
  data zero/0.d0/, half/.5d0/, one/1.d0/, ten/10.d0/
  data eps0/1.d-2/, tau/.015d0/, c0/.0625d0/
!
  error = zero
  if (eps <= zero .or. eps >= eps0) go to 200
  ierr = 0
!
  itno = 1
  xlb = zero
  dn = n
  dnp1 = np1
!
  do 10 i = 1,lp1
   10 p(i) = zero
  do 11 i = 1,mp1
   11 q(i) = zero
  q(1) = one
!
!     compute initial approximations of the critical points
!
  x(1) = a
  x(np1) = b
  k = n/2
  if (k <= 0) go to 30
  b1 = half*(b - a)
  xm1 = half*(a + b)
  do 20 i = 1,k
  xi = i
  z = -b1*dcos(pi*(xi/dn))
  x(i+1) = z + xm1
  ii = np1 - i
   20 x(ii) = xm1 - z
!
!     evaluate phi at the critical points
!
   30 do 31 i = 1,np1
   31 xval(i) = phi(x(i))
  kount = 1
!
!     set up the linear equations
!
   40 k = l + 2
  sign = one
  do 45 i = 1,np1
  sign = -sign
  c(i,1) = one
  if (l <= 0) go to 42
  do 41 j = 2,lp1
   41 c(i,j) = c(i,j-1)*xval(i)
   42 d(i) = f(x(i))
  if (m <= 0) go to 44
  templ = sign*xlb*g(x(i)) - d(i)
  c(i,k) = xval(i)*templ
  if (k > lpm) go to 44
  do 43 j = k,lpm
   43 c(i,j+1) = c(i,j)*xval(i)
   44 c(i,np1) = sign*g(x(i))
   45 continue
!
!     solve the equations cx = d and store the results in d
!
  call dpslv (np1, 1, c, np1, d, np1, ierr)
  if (ierr /= 0) go to 220
  if (kount > 1) go to 50
!
!     redefine the equations and solve
!
  xlb = (d(np1) + xlb*dn)/dnp1
  if (m <= 0) go to 61
  kount = 2
  go to 40
!
   50 test = dabs(xlb - d(np1))
  xlb = (d(np1) + xlb*dn)/dnp1
  kount = kount + 1
  if (kount <= 4 .and. test > eps0*dabs(xlb)) go to 40
!
!     store the results in p and q
!
  do 60 i = 2,mp1
  lpi = l + i
   60 q(i) = d(lpi)
   61 do 62 i = 1,lp1
   62 p(i) = d(i)
!
!     search for new critical points
!
  olderr = error
  error = zero
  z1 = zero
  u = one
  if (xlb < zero) u = -u
!
  if (n > 1) go to 70
  h(1) = tau*(x(2) - x(1))
  h(2) = -h(1)
  go to 72
   70 do 71 i = 2,n
   71 h(i) = tau*(x(i+1) - x(i-1))
  h(1) = half*h(2)
  h(np1) = -half*h(n)
   72 continue
!
  do 92 i = 1,np1
  y2 = x(i)
  h1 = h(i)
  y3 = y2 + h1
  call cerr(y2, f(y2), g(y2), phi(y2), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  z2 = u*del
  call cerr(y3, f(y3), g(y3), phi(y3), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  z3 = u*del
  if (z2 < z3) go to 80
  h1 = -h1
  z = z3
  z3 = z2
  z2 = z
  y = y3
  y3 = y2
  y2 = y
!
   80 y = y3 + h1
  if (y >= a) go to 81
  y = a
  go to 90
   81 if (y <= b) go to 82
  y = b
  go to 90
   82 call cerr(y, f(y), g(y), phi(y), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  z = u*del
  if (z <= z3) go to 83
  y2 = y3
  y3 = y
  z2 = z3
  z3 = z
  go to 80
   83 y = (z - z3) + (z2 - z3)
  if (y /= zero) go to 84
  y = y3
  go to 90
   84 y = half*(y2 + y3) + h1*(z2 - z3)/y
!
   90 x(i) = y
  call cerr(y, f(y), g(y), phi(y), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  err(i) = del
  u = -u
  if (i == 1) go to 91
  if (x(i) <= x(i-1)) go to 230
   91 z = dabs(err(i))
  error = dmax1(error, z)
  if (z >= ten) go to 240
  y = dabs(xlb)
  zz = one
  if (y /= zero) zz = dabs(z - y)/y
  if (z1 < zz) z1 = zz
   92 continue
!
!     search for an extra extremal point between the endpoints
!     of the interval and the critical points
!
  if (x(1) <= a) go to 110
  h1 = c0*(x(1) - a)
  u = one
  if (xlb >= zero) u = -u
  z3 = zero
  y = a
  do 100 i = 1,16
  call cerr(y, f(y), g(y), phi(y), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  z = u*del
  if (z <= z3) go to 100
  z3 = z
  z2 = y
  100 y = y + h1
  error = dmax1(error, z3)
  z = dabs(xlb)
  if (z3 <= z) go to 110
  i = np1
  do 101 ii = 2,np1
  err(i) = err(i-1)
  x(i) = x(i-1)
  101 i = i - 1
  x(1) = z2
  err(1) = u*z3
  go to 113
!
  110 if (x(np1) >= b) go to 120
  h1 = c0*(b - x(np1))
  u = one
  if (err(np1) >= zero) u = -u
  z3 = zero
  y = b
  do 111 i = 1,16
  call cerr(y, f(y), g(y), phi(y), del, ierr, l, lp1, m, np1, d)
  if (ierr /= 0) return
  z = u*del
  if (z <= z3) go to 111
  z3 = z
  z2 = y
  111 y = y - h1
  error = dmax1(error, z3)
  z = dabs(xlb)
  if (z3 <= z) go to 120
  do 112 i = 1,n
  err(i) = err(i+1)
  112 x(i) = x(i+1)
  x(np1) = z2
  err(np1) = u*z3
  113 xlb = -xlb
  zz = one
  if (z /= zero) zz = dabs(z3 - z)/z
  if (z1 < zz) z1 = zz
!
!     check for convergence
!
  120 if (z1 <= eps) return
!
!     set up for the next iteration
!
  if (itno >= mxiter) go to 210
  sum = zero
  sign = one
  do 130 i = 1,np1
  sum = sum + sign*err(i)
  130 sign = -sign
  xlb = sum/dnp1
  itno = itno + 1
  go to 30
!
!     error return
!
!     input error
!
  200 ierr = 1
  return
!
!     mxiter iterations were performed - more iterations are needed
!
  210 ierr = 2
  return
!
!     the linear equations cannot be solved
!
  220 if (itno == 1) go to 250
  ierr = 3
  return
!
!     the sequence of critical points is not monotonically increasing
!
  230 ierr = 4
  if (i <= n) error = olderr
  return
!
!     it appears that the algorithm has failed to converge
!     there may be poles in the rational approximation
!
  240 ierr = 5
  return
!
!     the routine has completely failed - the results should be ignored
!
  250 ierr = 6
  return
end
subroutine chkprm (intl,iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx, &
                     cofy,idmn,mn,ierror)
!
!*******************************************************************************
!
!! CHKPRM checks the input parameters for errors
!
!
!     check definition of solution region
!
  ierror = 1
  if (a >= b .or. c >= d) return
!
!     check boundary switches
!
  ierror = 2
  if (mbdcnd < 0 .or. mbdcnd > 4) return
  ierror = 3
  if (nbdcnd < 0 .or. nbdcnd > 4) return
!
!     check first dimension in calling routine
!
  ierror = 5
  if (mn < 7 .or. idmn  <  7) return
!
!     check m
!
  ierror = 6
  if (m > (idmn-1) .or. m < 6) return
  if (m > mn - 1) return
!
!     check n
!
  ierror = 7
  if (n < 5) return
!
!     check iorder
!
  ierror = 8
  if (iorder/=2 .and. iorder/=4) return
!
!     check intl
!
  ierror = 9
  if (intl/=0 .and. intl/=1) return
!
!     check that equation is elliptic
!
  dlx = (b-a)/real(m)
  dly = (d-c)/real(n)
  do  30 i=2,m
     xi = a+real(i-1)*dlx
     call cofx (xi,ai,bi,ci)
     do  20 j=2,n
        yj = c+real(j-1)*dly
        call cofy (yj,dj,ej,fj)
        if (ai*dj > 0.0) go to  10
        ierror = 10
        return
   10       continue
   20    continue
   30 continue
!
!     no error found
!
  ierror = 0
  return
end
subroutine chksng (mbdcnd,nbdcnd,alpha,beta,gama,xnu,cofx,cofy, &
                     singlr)
!
!*******************************************************************************
!
!! CHKSNG checks if the pde sepell must solve is a singular operator
!
  logical         singlr
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
!
  singlr = .false.
!
!     check if the boundary conditions are
!     entirely periodic and/or mixed
!
  if ((mbdcnd/=0 .and. mbdcnd/=3) .or. &
      (nbdcnd/=0 .and. nbdcnd/=3)) return
!
!     check that mixed conditions are pure neuman
!
  if (mbdcnd /= 3) go to  10
  if (alpha/=0.0 .or. beta/=0.0) return
   10 if (nbdcnd /= 3) go to  20
  if (gama/=0.0 .or. xnu/=0.0) return
   20 continue
!
!     check that non-derivative coefficient functions
!     are zero
!
  do  30 i=is,ms
     xi = ait+real(i-1)*dlx
     call cofx (xi,ai,bi,ci)
     if (ci /= 0.0) return
   30 continue
  do  40 j=js,ns
     yj = cit+real(j-1)*dly
     call cofy (yj,dj,ej,fj)
     if (fj /= 0.0) return
   40 continue
!
!     the operator must be singular if this point is reached
!
  singlr = .true.
  return
end
subroutine ci_values ( n, x, fx )
!
!*******************************************************************************
!
!! CI_VALUES returns some values of the cosine integral function.
!
!
!  Discussion:
!
!    CI(X) = gamma + log ( X ) 
!            + integral ( 0 <= T <= X ) ( 1 - cos ( T ) ) / T  dT
!
!    where gamma is Euler's constant.
!
!  Modified:
!
!    27 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
   -0.1777840788E+00, -0.0222707070E+00,  0.1005147070E+00,  0.1982786160E+00, &
    0.2760678305E+00,  0.3374039229E+00,  0.4204591829E+00,  0.4620065851E+00, &
    0.4717325169E+00,  0.4568111294E+00,  0.4229808288E+00,  0.2858711964E+00, &
    0.1196297860E+00, -0.0321285485E+00, -0.1409816979E+00, -0.1934911221E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.5E+00,  0.6E+00,  0.7E+00,  0.8E+00, &
     0.9E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
     1.6E+00,  1.8E+00,  2.0E+00,  2.5E+00, &
     3.0E+00,  3.5E+00,  4.0E+00,  4.5E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
function cin ( x )
!
!*******************************************************************************
!
!! CIN computes the integral of (1-cos(t))/t on (0,x) 
!
!
!  Discussion:
!
!    Chebyshev expansions are used on (0,5) and (5,infinity).
!
!  Author:
!
!    d.e. amos and s.l. daniel
!
!  Reference:
!
!    y.l. luke
!    the special functions and their approximations, vol. ii,
!    academic press, new york, 1969.
!
!  Parameters:
!
!    Input, real X, the argument.
!
!         output
!           cin    - value of the integral
!
!
  real bb(16)
  real cc(46)
!
  data n1,n2,m1,m2     / 16, 46, 14, 21 /
  data econ            / 5.77215664901533e-01/
!
  data bb(1) / 1.82820351064538e-01/, bb(2) /-8.23768704567135e-02/, &
       bb(3) /-1.03468764544958e-02/, bb(4) / 5.05085201960312e-03/, &
       bb(5) / 5.73772812356328e-05/, bb(6) /-1.42717916181096e-04/, &
       bb(7) / 2.89263664732599e-06/, bb(8) / 2.43068098304909e-06/, &
       bb(9) /-7.90337487433443e-08/, bb(10)/-2.80205535437371e-08/, &
       bb(11)/ 1.05488738052065e-09/, bb(12)/ 2.34186901801115e-10/, &
       bb(13)/-9.27762554764014e-12/, bb(14)/-1.48682586858284e-12/, &
       bb(15)/ 5.95210263082868e-14/, bb(16)/ 7.42057835287916e-15/
!
  data cc(1) / 9.76155271128712e-01/, cc(2) / 8.96845854916423e-02/, &
       cc(3) /-3.04656658030696e-02/, cc(4) / 8.50892472922945e-02/, &
       cc(5) /-5.78073683148386e-03/, cc(6) /-5.07182677775691e-03/, &
       cc(7) / 8.38643256650893e-04/, cc(8) /-3.34223415981738e-04/, &
       cc(9) /-2.15746207281216e-05/, cc(10)/ 1.28560650086065e-04/, &
       cc(11)/-1.56456413510232e-05/, cc(12)/-1.52025513597262e-05/, &
       cc(13)/ 4.04001013843204e-06/, cc(14)/-5.95896122752160e-07/, &
       cc(15)/-4.34985305974340e-07/, cc(16)/ 7.13472533530840e-07/, &
       cc(17)/-5.34302186061100e-08/, cc(18)/-1.76003581156610e-07/, &
       cc(19)/ 3.85028855125900e-08/, cc(20)/ 1.92576544441700e-08/, &
       cc(21)/-1.00735358217200e-08/, cc(22)/ 3.36359194377000e-09/, &
       cc(23)/ 1.28049619406000e-09/, cc(24)/-2.42546870827000e-09/, &
       cc(25)/ 1.86917288950000e-10/, cc(26)/ 7.13431298340000e-10/, &
       cc(27)/-1.70673483710000e-10/, cc(28)/-1.14604070350000e-10/, &
       cc(29)/ 5.88004411500000e-11/, cc(30)/-6.78417843000000e-12/, &
       cc(31)/-1.21572380900000e-11/, cc(32)/ 1.26561248700000e-11/, &
       cc(33)/ 4.74814180000000e-13/, cc(34)/-5.32309477000000e-12/, &
       cc(35)/ 9.05903810000000e-13/, cc(36)/ 1.40046450000000e-12/, &
       cc(37)/-5.00968320000000e-13/, cc(38)/-1.80458040000000e-13/
  data cc(39)/ 1.66162910000000e-13/, cc(40)/-5.02616400000000e-14/, &
       cc(41)/-3.48453600000000e-14/, cc(42)/ 4.60056600000000e-14/, &
       cc(43)/ 5.74000000000000e-16/, cc(44)/-1.95310700000000e-14/, &
       cc(45)/ 3.68837000000000e-15/, cc(46)/ 5.62862000000000e-15/
!
!     ****** amax is a machine dependent constant. it is assumed that
!            sin(x) and cos(x) are defined for  abs(x) <= amax, and
!            that econ + ln(x) - (1 + 1/x)/x = econ + ln(x)
!            for x > amax.
!
  amax = 0.1 / epsilon ( amax )

  ax = abs(x)

  if (ax > 5.0) go to 20
  j=n1
  bx=0.40*ax-1.0
  tx=bx+bx
  b1=bb(j)
  b2=0.0
  do i=1,m1
    j=j-1
    temp=b1
    b1=tx*b1-b2+bb(j)
    b2=temp
  end do

  cin=x*x*(bx*b1-b2+bb(1))
  return

   20 if (ax > amax) go to 50
  bx=10./ax-1.0
  tx=bx+bx
  j=n2
  b1=cc(j)
  b2=0.0
  do i=1,m2
    j=j-2
    temp=b1
    b1=tx*b1-b2+cc(j)
    b2=temp
  end do
  aic=bx*b1-b2+cc(2)

  j=n2-1
  b1=cc(j)
  b2=0.0
  do i=1,m2
    j=j-2
    temp=b1
    b1=tx*b1-b2+cc(j)
    b2=temp
  end do
  rc=bx*b1-b2+cc(1)

  cin=(rc*sin(ax)-aic*cos(ax))/ax
  cin=(econ-cin)+alog(ax)
  return

   50 continue

  cin=econ+alog(ax)

  return
end
subroutine cin_values ( n, x, fx )
!
!*******************************************************************************
!
!! CIN_VALUES returns some values of the cosine integral function.
!
!
!  Discussion:
!
!    CIN(X) = integral ( 0 <= T <= X ) ( 1 - cos ( T ) ) / T  dT
!
!  Modified:
!
!    20 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.6185257435E-01, 0.8866080642E-01, 0.1200259924E+00, 0.1557935178E+00, &  
    0.1957873106E+00, 0.2398117483E+00, 0.3390780687E+00, 0.4516812861E+00, &   
    0.5754867792E+00, 0.7081911564E+00, 0.8473820686E+00, 1.207635164E+00, &    
    1.556198120E+00,  1.862107158E+00,  2.104491711E+00,  2.274784088E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.5E+00,  0.6E+00,  0.7E+00,  0.8E+00, &
     0.9E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
     1.6E+00,  1.8E+00,  2.0E+00,  2.5E+00, &
     3.0E+00,  3.5E+00,  4.0E+00,  4.5E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine circv ( r, d, i, p, ierr )
!
!*******************************************************************************
!
!! CIRCV: circular coverage and circular error functions
!
!
!  Parameters:
!
!    Input, real R, ?.  Must be nonnegative.
!
!    Input, real D, ?.  Must be nonnegative.
!
!    I
!
!    Output, real P, ?
!
!    Output, integer IERR, error flag.
!    0, no error.
!    Nonzero, an error occurred.
!
  real d
  real, parameter :: eps = 5.0E-07
  integer ierr
  real m
  real n
  real p
  real r
  real, parameter :: rt2inv = 0.70710678118655
  real, parameter :: rtpinv = 0.56418958354776
  real, parameter :: tol = 5.0E-04
!
  if ( r < 0.0E+00 ) then
    ierr = 1
    p = -1.0E+00
    return
  end if

  if ( d < 0.0E+00 ) then
    ierr = 2
    p = -1.0E+00
    return
  end if

  ierr = 0
  p = 0.0E+00

  if (i /= 0 ) go to 30
!
!  evaluation of v(r,d)
!
  if ( d > 1.0 ) then
    return
  end if

  if ( r == 0.0 ) then
    return
  end if

  if ( r >= 5.386773 ) then
    p = 1.0
    return
  end if

  if ( d == 0.0 ) then
    a = rt2inv*r
    p = erf0(a)
    return
  end if

  t = 0.5/d
  rr = r*(1.0 + d)*t
  dd = r*(1.0 - d)*t
  diff = r
  a = r
  go to 40
!
!                    evaluation of p(r,d)
!
   30 continue

  if (r == 0.0) then
    return
  end if

  rr = r
  dd = d
  diff = r - d
  a = abs(diff)
  if (a < 5.386773) go to 40

  if ( diff >= 0.0 ) then
    p = 1.0
  end if

  return

   40 continue

  t = rr*dd
  t3 = 0.5*rr*rr
  b = 0.5*dd*dd
  n = 0.0
  if (t > 7.0) go to 70
!
!     evaluation of p(rr,dd) when abs(rr-dd) < 5.386773
!                     and rr*dd <= 7.0
!
  t1 = rt2inv*t - 1.0
  t2 = t3*b
  s0 = exp(-t3 - b)
  s1 = exp(-b)
  if (t3 > tol) go to 50
      s1 = s1*t3
      go to 51
   50 s1 = s1 - s0
   51 s2 = s0
  t0 = s1
!
   60 n = n + 1.0
  m = 1.0/n
  s0 = t2*m*m*s0
  t0 = b*m*t0 - s0
  s1 = s1 + t0
  s2 = s2 + s0
  if (t1 >= n .or. t0 > eps) go to 60
  p = s1
  if (i == 0) p = abs(p + p + s2 - 1.0)
  return
!
!     evaluation of p(rr,dd) when abs(rr-dd) < 5.386773
!                     and rr*dd > 7.0
!
   70 a = rt2inv*a
  s1 = 0.5*diff*diff
  s2 = exp(-s1)
  e = erfc0(a,s1,s2)
  t1 = 2.0*abs(t3 - b)
  t3 = 0.5/t
  t2 = sqrt(t3)

  s0 = rtpinv*t2*s2
  t0 = (rr + dd)*rt2inv*t2*e
  t2 = s1*t3
  t3 = 0.5*t3
  s1 = t0
  s2 = s0

   80 n = n + 2.0
  m = n - 1.0
  a = m/n
  s0 = a*t3*s0
  t0 = t1*s0 - t2*a*t0
  s0 = m*s0
  s1 = s1 + t0
  s2 = s2 + s0
  if (t0 > eps) go to 80

   90 continue

  if (s0 <= eps) go to 100
  n = n + 2.0
  m = n - 1.0
  s0 = m*m*t3*s0/n
  s2 = s2 + s0
  go to 90

  100 if (diff) 101,102,103
  101 p = 0.5*abs(s1 - s2)
  return
  102 p = 0.5*abs(1.0 - s2)
  return
  103 p = 0.5*abs(2.0 - s2 - s1)
  if (i == 0) p = abs(p + p + s2 - 1.0)

  return
end
function ck ( k, l )
!
!*******************************************************************************
!
!! CK calculates the complete elliptic integral f(k) for complex modulus K.
!
!  It is assumed that l/=0 and that k**2 + l**2 = 1.
!
  complex ck
  complex k,l,ak,al,ak1,al1,al2,ckk,ckp,f1,f2,f3,fxk,aktemp,ck1,j
  complex cflect,km,z
  real ln4,x1(12),x2(12),w1(12),w2(12),fl(12),fa(12),fb(12)
  logical branch
!
  data x1(1)/ 6.5487222790801e-03/, x1(2)/ 3.8946809560450e-02/, &
       x1(3)/ 9.8150263106007e-02/, x1(4)/ 1.8113858159063e-01/, &
       x1(5)/ 2.8322006766737e-01/, x1(6)/ 3.9843443516344e-01/, &
       x1(7)/ 5.1995262679235e-01/, x1(8)/ 6.4051091671611e-01/, &
       x1(9)/ 7.5286501205183e-01/, x1(10)/8.5024002416230e-01/, &
       x1(11)/9.2674968322391e-01/, x1(12)/9.7775612969000e-01/
!
  data w1(1)/ 9.3192691443932e-02/, w1(2)/ 1.4975182757632e-01/, &
       w1(3)/ 1.6655745436459e-01/, w1(4)/ 1.5963355943699e-01/, &
       w1(5)/ 1.3842483186484e-01/, w1(6)/ 1.1001657063572e-01/, &
       w1(7)/ 7.9961821770829e-02/, w1(8)/ 5.2406954824642e-02/, &
       w1(9)/ 3.0071088873761e-02/, w1(10)/1.4249245587998e-02/, &
       w1(11)/4.8999245823217e-03/, w1(12)/8.3402903805690e-04/
!
  data fl(1)/ 1.5708005371203e+00/, fl(2)/ 1.5709452753591e+00/, &
       fl(3)/ 1.5717433742881e+00/, fl(4)/ 1.5740325056162e+00/, &
       fl(5)/ 1.5787613653341e+00/, fl(6)/ 1.5867393901613e+00/, &
       fl(7)/ 1.5983969635617e+00/, fl(8)/ 1.6135762587884e+00/, &
       fl(9)/ 1.6313677113831e+00/, fl(10)/1.6500349733510e+00/, &
       fl(11)/1.6671202200919e+00/, fl(12)/1.6798403417359e+00/
!
  data x2(1)/-9.8156063424672e-01/, x2(2)/-9.0411725637048e-01/, &
       x2(3)/-7.6990267419431e-01/, x2(4)/-5.8731795428662e-01/, &
       x2(5)/-3.6783149899818e-01/, x2(6)/-1.2523340851147e-01/, &
       x2(7)/ 1.2523340851147e-01/, x2(8)/ 3.6783149899818e-01/, &
       x2(9)/ 5.8731795428662e-01/, x2(10)/7.6990267419431e-01/, &
       x2(11)/9.0411725637048e-01/, x2(12)/9.8156063424672e-01/
!
  data w2(1)/ 4.7175336386512e-02/, w2(2)/ 1.0693932599532e-01/, &
       w2(3)/ 1.6007832854335e-01/, w2(4)/ 2.0316742672307e-01/, &
       w2(5)/ 2.3349253653836e-01/, w2(6)/ 2.4914704581340e-01/, &
       w2(7)/ 2.4914704581340e-01/, w2(8)/ 2.3349253653836e-01/, &
       w2(9)/ 2.0316742672307e-01/, w2(10)/1.6007832854335e-01/, &
       w2(11)/1.0693932599532e-01/, w2(12)/4.7175336386512e-02/
!
  data fa(1)/ 2.0794472764428e+00/, fa(2)/ 2.0795966441739e+00/, &
       fa(3)/ 2.0803359313463e+00/, fa(4)/ 2.0823286205438e+00/, &
       fa(5)/ 2.0862633195105e+00/, fa(6)/ 2.0926508621232e+00/, &
       fa(7)/ 2.1016440761258e+00/, fa(8)/ 2.1128974786197e+00/, &
       fa(9)/ 2.1254857173540e+00/, fa(10)/2.1379218133017e+00/, &
       fa(11)/2.1483404506064e+00/, fa(12)/2.1548934173960e+00/
!
  data fb(1)/ 1.5744273529551e+00/, fb(2)/ 1.5899097325063e+00/, &
       fb(3)/ 1.6176685384410e+00/, fb(4)/ 1.6574605448620e+00/, &
       fb(5)/ 1.7087245795822e+00/, fb(6)/ 1.7703459462057e+00/, &
       fb(7)/ 1.8403280188791e+00/, fb(8)/ 1.9154060277115e+00/, &
       fb(9)/ 1.9907093877047e+00/, fb(10)/2.0596975322636e+00/, &
       fb(11)/2.1146977530430e+00/, fb(12)/2.1482986855683e+00/
!
  data j/(0.0, 1.0)/
  data ln4 /1.3862943611199/
  data c1  /.20264236728467/, c2/.15915494309189/
!
  eps = epsilon ( eps )

  if (l == (0.0, 0.0)) go to 200
  ind = 0
  branch = .true.
  tol = 8.0*max ( eps, 1.e-14)
!
  ak1 = cflect(k)
  al1 = cflect(l)
  ak = ak1
  al = al1
!
  x = real(ak)
  y = aimag(ak)
  u = real(al)
  v = aimag(al)
  if (max ( x,abs(y)) >= 1.0/eps) go to 90
  if (max ( u,abs(v)) >= 1.1/eps) go to 200
!
!     check that k**2 + l**2 = 1
!
  if (x < u) go to 1
     t = u/x
     if (abs(x*x/(v*v + 1.0/(1.0 + t*t)) - 1.0) > tol) go to 200
     if (abs(y + t*v) > tol*max ( 1.0, abs(v))) go to 200
     go to 10
1 t = x/u
  if (abs(u*u/(y*y + 1.0/(1.0 + t*t)) - 1.0) > tol) go to 200
  if (abs(v + t*y) > tol*max ( 1.0, abs(y))) go to 200
!
!     uses  logarithmic series when cabs(al)
!     is less than or equal to 0.55
!
   10 if (u > 1.42 .or. abs(v)  >  1.42) go to 50
   11 if (cabs(al) > 0.55) go to 20
  call kl(al,ckk,ckp)
  if (branch) go to 22
  ck1 = ckk
  ck = ckp
  al = ak
  go to 80
!
!     uses maclaurin expansion when the absolute value of
!     the modulus ak is less than or equal to 0.55
!
   20 r = cabs(ak)
  if (r > 0.55) go to 30
  if (branch) go to 21
  call kl(ak,ckp,ck1)
  ck = ckp
  al = ak
  go to 80
   21 ckk = km(ak*ak)
   22 ck = ckk
  go to 70
!
!     numerical quadrature approximation
!
   30 if (ind == 0 .and. r > 1.0) go to 50
   31 al2 = al*al
!
  f1 = (0.0, 0.0)
  do 40 i = 1,12
     xx = x1(i)/2.
     fxk = ak*xx
   40    f1 = f1 + w1(i)*fl(i)/(al2 + fxk*fxk)
  f2 = (0.0, 0.0)
  do 41 i = 1,12
     xx = .25*(1.+ x2(i))
     fxk = ak*xx
   41    f2 = f2 + w2(i)*fa(i)/(al2 + fxk*fxk)
  f3 = (0.0, 0.0)
  do 42 i = 1,12
     xx = .25*(3.- x2(i))
     fxk = ak*xx
   42    f3 = f3 + w2(i)*fb(i)/(al2 + fxk*fxk)
!
  ck = al*(c1*f1 + c2*(f2 + f3))
!
!     end of numerical quadrature approximation
!
  if (branch) go to 70
  ck1 = ck
  branch = .true.
!
!     interchange ak and al
!
  aktemp = ak
  ak = al
  al = aktemp
  go to 31
!
!     uses inverse modulus transformation when cabs(ak) is greater
!     than 1 and real(ak**2) is greater than 0.5.
!
   50 if (x*x <= y*y + 0.5) go to 60
  ind = 1
  branch = .false.
  ak = 1.0/ak1
  al = cflect(j*al1/ak1)
  go to 11
!
!     uses complementary inverse modulus transformation when cabs(ak)
!     is greater than 1 and real(ak**2) is less than or equal to 0.5
!
   60 ind = 2
  ak = cflect(j*ak1/al1)
  al = 1.0/al1
  go to 11
!
!     return if no transformations have been performed
!
   70 if (ind == 0) return
  if (ind == 1) go to 80
!
!     complementary inverse modulus transformation
!
  ck = al*ck
  return
!
!     inverse modulus transformation
!
   80 if (aimag(ak1) >= 0.0) go to 81
     ck = al*(ck1 - j*ck)
     return
   81 ck = al*(ck1 + j*ck)
  return
!
!     calculation of f(k) for large k and l
!
   90 if (x <= abs(y)) go to 100
  if (abs(abs(v/x) - 1.0) > tol) go to 200
  if (abs(u/x + y/v) > tol) go to 200
  t = y/x
  phi = atan2(x,abs(y))
  r = (ln4 + 0.5*alnrel(t*t)) + alog(x)
  if (y < 0.0) r = -r
  ck = (cmplx(phi,r)/cmplx(1.0,t))/x
  return
!
  100 if (abs(abs(u/y) - 1.0) > tol) go to 200
  if (abs(x/u + v/y) > tol) go to 200
  t = v/u
  z = cmplx((ln4 + 0.5*alnrel(t*t)) + alog(u), atan2(v,u))
  ck = (z/cmplx(1.0,t))/u
  return
!
!     error return
!
  200 ck = (0.0, 0.0)
  return
end
subroutine cke(k,l,ck,ce,ierr)
!
!*******************************************************************************
!
!! CKE calculates the complete elliptic integrals f(k) and e(k)
!     for complex values of the modulus k. 
!
!  it is assumed that l/=0 and that k**2 + l**2 = 1.
!
  complex k,l,ak,al,ak1,al1,ckk,ckp,f1,f2,f3,aktemp,ck1,j
  complex ce,ck,cee,cep,ce1,e1,e2,e3,at,fx,fxk,atn
  complex cflect,k1,l1,ak2,al2,z,g,g1,gg,gp
  real ln4,x1(12),x2(12),w1(12),w2(12),fl(12),fa(12),fb(12)
  logical branch
!
  data x1(1)/ 6.5487222790801e-03/, x1(2)/ 3.8946809560450e-02/, &
       x1(3)/ 9.8150263106007e-02/, x1(4)/ 1.8113858159063e-01/, &
       x1(5)/ 2.8322006766737e-01/, x1(6)/ 3.9843443516344e-01/, &
       x1(7)/ 5.1995262679235e-01/, x1(8)/ 6.4051091671611e-01/, &
       x1(9)/ 7.5286501205183e-01/, x1(10)/8.5024002416230e-01/, &
       x1(11)/9.2674968322391e-01/, x1(12)/9.7775612969000e-01/
!
  data w1(1)/ 9.3192691443932e-02/, w1(2)/ 1.4975182757632e-01/, &
       w1(3)/ 1.6655745436459e-01/, w1(4)/ 1.5963355943699e-01/, &
       w1(5)/ 1.3842483186484e-01/, w1(6)/ 1.1001657063572e-01/, &
       w1(7)/ 7.9961821770829e-02/, w1(8)/ 5.2406954824642e-02/, &
       w1(9)/ 3.0071088873761e-02/, w1(10)/1.4249245587998e-02/, &
       w1(11)/4.8999245823217e-03/, w1(12)/8.3402903805690e-04/
!
  data fl(1)/ 1.5708005371203e+00/, fl(2)/ 1.5709452753591e+00/, &
       fl(3)/ 1.5717433742881e+00/, fl(4)/ 1.5740325056162e+00/, &
       fl(5)/ 1.5787613653341e+00/, fl(6)/ 1.5867393901613e+00/, &
       fl(7)/ 1.5983969635617e+00/, fl(8)/ 1.6135762587884e+00/, &
       fl(9)/ 1.6313677113831e+00/, fl(10)/1.6500349733510e+00/, &
       fl(11)/1.6671202200919e+00/, fl(12)/1.6798403417359e+00/
!     --------------------------------------------------------------
  data x2(1)/-9.8156063424672e-01/, x2(2)/-9.0411725637048e-01/, &
       x2(3)/-7.6990267419431e-01/, x2(4)/-5.8731795428662e-01/, &
       x2(5)/-3.6783149899818e-01/, x2(6)/-1.2523340851147e-01/, &
       x2(7)/ 1.2523340851147e-01/, x2(8)/ 3.6783149899818e-01/, &
       x2(9)/ 5.8731795428662e-01/, x2(10)/7.6990267419431e-01/, &
       x2(11)/9.0411725637048e-01/, x2(12)/9.8156063424672e-01/
!     --------------------------------------------------------------
  data w2(1)/ 4.7175336386512e-02/, w2(2)/ 1.0693932599532e-01/, &
       w2(3)/ 1.6007832854335e-01/, w2(4)/ 2.0316742672307e-01/, &
       w2(5)/ 2.3349253653836e-01/, w2(6)/ 2.4914704581340e-01/, &
       w2(7)/ 2.4914704581340e-01/, w2(8)/ 2.3349253653836e-01/, &
       w2(9)/ 2.0316742672307e-01/, w2(10)/1.6007832854335e-01/, &
       w2(11)/1.0693932599532e-01/, w2(12)/4.7175336386512e-02/
!     --------------------------------------------------------------
  data fa(1)/ 2.0794472764428e+00/, fa(2)/ 2.0795966441739e+00/, &
       fa(3)/ 2.0803359313463e+00/, fa(4)/ 2.0823286205438e+00/, &
       fa(5)/ 2.0862633195105e+00/, fa(6)/ 2.0926508621232e+00/, &
       fa(7)/ 2.1016440761258e+00/, fa(8)/ 2.1128974786197e+00/, &
       fa(9)/ 2.1254857173540e+00/, fa(10)/2.1379218133017e+00/, &
       fa(11)/2.1483404506064e+00/, fa(12)/2.1548934173960e+00/
!     --------------------------------------------------------------
  data fb(1)/ 1.5744273529551e+00/, fb(2)/ 1.5899097325063e+00/, &
       fb(3)/ 1.6176685384410e+00/, fb(4)/ 1.6574605448620e+00/, &
       fb(5)/ 1.7087245795822e+00/, fb(6)/ 1.7703459462057e+00/, &
       fb(7)/ 1.8403280188791e+00/, fb(8)/ 1.9154060277115e+00/, &
       fb(9)/ 1.9907093877047e+00/, fb(10)/2.0596975322636e+00/, &
       fb(11)/2.1146977530430e+00/, fb(12)/2.1482986855683e+00/
!     --------------------------------------------------------------
  data j/(0.0, 1.0)/
  data ln4 /1.3862943611199/
  data c1  /.20264236728467/, c2/.15915494309189/
!     ---------------------------------------------------
!
  eps = epsilon ( eps )
  if (l == (0.0, 0.0)) go to 200
  ind = 0
  branch = .true.
  tol = 8.0*max ( eps, 1.e-14)
!
  ak1 = cflect(k)
  al1 = cflect(l)
  ak = ak1
  al = al1
  ierr = 0
!
  x = real(ak)
  y = aimag(ak)
  u = real(al)
  v = aimag(al)
  if (max ( x,abs(y)) >= 1.0/eps) go to 90
  if (max ( u,abs(v)) >= 1.1/eps) go to 210
!
!     check that k**2 + l**2 = 1
!
  if (x < u) go to 1
     t = u/x
     if (abs(x*x/(v*v + 1.0/(1.0 + t*t)) - 1.0) > tol) go to 210
     if (abs(y + t*v) > tol*max ( 1.0, abs(v))) go to 210
     go to 10
1 t = x/u
  if (abs(u*u/(y*y + 1.0/(1.0 + t*t)) - 1.0) > tol) go to 210
  if (abs(v + t*y) > tol*max ( 1.0, abs(y))) go to 210
!
!     uses  logarithmic series when cabs(al)
!     is less than or equal to 0.55
!
   10 if (u > 1.42 .or. abs(v)  >  1.42) go to 50
   11 if (cabs(al) > 0.55) go to 20
  call ekl(al,ckk,ckp,cee,cep,gg,gp)
  if (branch) go to 22
  ck1 = ckk
  ck = ckp
  ce1 = cee
  ce = cep
  g1 = gg
  g = gp
  ak2 = al*al
  al = ak
  al2 = al*al
  go to 81
!
!     uses maclaurin expansion when the absolute value of
!     the modulus ak is less than or equal to 0.55
!
   20 r = cabs(ak)
  if (r > 0.55) go to 30
  if (branch) go to 21
  call ekl(ak,ckp,ck1,cep,ce1,gp,g1)
  ck = ckp
  ce = cep
  g = gp
  ak2 = al*al
  al = ak
  al2 = al*al
  go to 81
   21 call ekm(ak*ak,ckk,cee)
   22 ck = ckk
  ce = cee
  go to 70
!
!     numerical quadrature approximation
!
   30 if (ind == 0 .and. r > 1.0) go to 50
   31 al2 = al*al
  ak2 = ak*ak
!
  f1 = (0.0, 0.0)
  e1 = (0.0, 0.0)
  do 40 i = 1,12
     xx = x1(i)/2.
     fx = ak*xx/al
     fxk = ak*xx
     at = atn(fx)
     e1 = e1 + w1(i)*fl(i)*(1.0 + at)
   40    f1 = f1 + w1(i)*fl(i)/(al2 + fxk*fxk)
  f2 = (0.0, 0.0)
  e2 = (0.0, 0.0)
  do 41 i = 1,12
     xx = .25*(1.+ x2(i))
     fx = ak*xx/al
     fxk = ak*xx
     at = atn(fx)
     e2 = e2 + w2(i)*fa(i)*(1.0 + at)
   41    f2 = f2 + w2(i)*fa(i)/(al2 + fxk*fxk)
  f3 = (0.0, 0.0)
  e3 = (0.0, 0.0)
  do 42 i = 1,12
     xx = .25*(3.- x2(i))
     fx = ak*xx/al
     fxk = ak*xx
     at = atn(fx)
     e3 = e3 + w2(i)*fb(i)*(1.0 + at)
   42    f3 = f3 + w2(i)*fb(i)/(al2 + fxk*fxk)
!
  ck = al*(c1*f1 + c2*(f2 + f3))
  ce = al*(c1*e1 + c2*(e2 + e3))
!
!     end of numerical quadrature approximation
!
  if (branch) go to 70
  ck1 = ck
  ce1 = ce
  branch = .true.
!
!     interchange ak and al
!
  aktemp = ak
  ak = al
  al = aktemp
  go to 31
!
!     uses inverse modulus transformation when cabs(ak) is greater
!     than 1 and real(ak**2) is greater than 0.5.
!
   50 if (x*x <= y*y + 0.5) go to 60
  ind = 1
  branch = .false.
  ak = 1.0/ak1
  al = cflect(j*al1/ak1)
  go to 11
!
!     uses complementary inverse modulus transformation when cabs(ak)
!     is greater than 1 and real(ak**2) is less than or equal to 0.5
!
   60 ind = 2
  ak = cflect(j*ak1/al1)
  al = 1.0/al1
  go to 11
!
!     return if no transformations have been performed
!
   70 if (ind == 0) return
  if (ind == 1) go to 80
!
!     complementary inverse modulus transformation
!
  ck = al*ck
  ce = ce/al
  return
!
!     inverse modulus transformation
!
   80 g = ce - al2*ck
  g1 = ce1 - ak2*ck1
   81 if (aimag(ak2) >= 0.0) go to 82
     ce = (g1 + j*g)/al
     ck = al*(ck1 - j*ck)
     return
   82 ce = (g1 - j*g)/al
  ck = al*(ck1 + j*ck)
  return
!
!     calculation of f(k) and e(k) for large k and l
!
   90 if (x <= abs(y)) go to 100
  if (abs(abs(v/x) - 1.0) > tol) go to 210
  if (abs(u/x + y/v) > tol) go to 210
  t = y/x
  k1 = cmplx(1.0,t)
  phi = atan2(x,abs(y))
  r = (ln4 + 0.5*alnrel(t*t)) + alog(x)
  c = 0.5*r + 0.25
  z = cmplx(y,-x)
  if (y >= 0.0) go to 91
     r = -r
     c = -c
     z = -z
   91 ck = (cmplx(phi,r)/k1)/x
  ce = z + (cmplx(0.5*phi,c)/k1)/x
  return
!
  100 if (abs(abs(u/y) - 1.0) > tol) go to 210
  if (abs(x/u + v/y) > tol) go to 210
  t = v/u
  l1 = cmplx(1.0,t)
  r = (ln4 + 0.5*alnrel(t*t)) + alog(u)
  phi = atan2(v,u)
  ck = (cmplx(r, phi)/l1)/u
  ce = al + (cmplx(0.5*r - 0.25, 0.5*phi)/l1)/u
  return
!
!     error return
!
  200 ierr = 1
  return
  210 ierr = 2
  return
end
subroutine ckm (z, r, zr, nu, w1, w2)
!
!*******************************************************************************
!
!! CKM calculates the modified Bessel function of the second kind
!  for real order nu between -0.5 and 0.5 and for complex
!     argument z by use of power series expansions.  it is assumed
!     that abs(z) <= 2 and -pi < arg z <= pi.
!
  complex z,w,z1,z2,c,cl,cmu,cz,czr,f,p,q,sh,ch,s1,s2, &
          t1,t2,w1,w2,zr
  real d(5), nu, nu2
!
  data tol/1.e-10/
  data pi/3.14159265358979/
  data d(1)/ 5.77215664901533e-01/, d(2)/-4.20026350340952e-02/, &
       d(3)/-4.21977345555443e-02/, d(4)/ 7.21894324666310e-03/, &
       d(5)/-2.15241674114951e-04/
!
  anorm(w) = max ( abs(real(w)), abs(aimag(w)))
  eps = epsilon ( eps )
  eps0 = max ( eps, 5.e-15)
!
  z1 = z/2.0
  z2 = z1*z1
  x = real(z1)
  y = aimag(z1)
!
!               initialization of summation
!
  phi = atan2(y,x)
  cl = - cmplx(alog(r), phi)
!
  cmu = nu*cl
  cz = cexp(cmu)
  czr = 1.0/cz
  t = pi*nu
  if (abs(nu) > tol) go to 10
     a = 1.0 + (t*t)/6.0
     go to 20
   10 a = t/sin(t)
!
!                   g1 = gamma(1 + nu)
!                   g2 = gamma(1 - nu)
!
   20 t = 0.5 + (0.5 + gam1(nu))
  g1 = 1.0/t
  g2 = a*t
  gm2 = (1.0/g2 + t)/2.0
  if (abs(nu) > 0.1) go to 30
     nu2 = nu*nu
     gm1 = -(d(1) + nu2*(d(2) + nu2*(d(3) + nu2*(d(4) + &
             nu2*d(5)))))
     go to 40
   30 gm1 = (1.0/g2 - t)/(nu + nu)
!
   40 p = 0.5*cz*g1
  q = 0.5*czr*g2
  x = real(cmu)
  y = aimag(cmu)
  if (anorm(cmu) > tol) go to 50
     t = x*y
     sh = cmplx(1.0,t/3.0)
     ch = cmplx(1.0,t)
     go to 60
   50 w = cmplx (-y, x)
  sh = csin(w)/w
  ch = ccos(w)
!
   60 f = a*(gm1*ch + gm2*cl*sh)
  c = 1.0
  s1 = f
  s2 = p
!
!               summation of series
!
  do 70 k = 1, 50
     ak = k
     f = (ak*f + p + q)/((ak - nu)*(ak + nu))
     p = p/(ak - nu)
     q = q/(ak + nu)
     c = c*z2/ak
     t1 = c*f
     s1 = s1 + t1
     t2 = c*(p - ak*f)
     s2 = s2 + t2
     if (anorm(t1) <= eps0*anorm(s1)) go to 80
   70 continue
!
!               final assembly
!
   80 w1 = s1
  w2 = s2 * zr
  return
end
subroutine ckml(z, r, zr, nu, k1, k2)
!
!*******************************************************************************
!
!! CKML calculates the modified Bessel function of the second
!     kind for orders nu and nu + 1 and for complex argument z
!     by use of the miller algorithm.  k1 is replaced by the
!     function of order nu, and k2 by the function of order
!     nu + 1.  for greatest accuracy, z should lie in a
!     sector slightly larger than the right half plane.
!
  complex z, k1, k2, bi, u1, u2, u3, s, zr
  real l, nu
!
!     c1 = sqrt(pi/2)
!
  data pi/3.1415926535898/
  data c1/1.25331413731559/
!
  eps = epsilon ( eps )
  eps0 = max ( eps, 5.e-15)
  x = real(z)
  y = aimag(z)
!
!     calculation of m for use in miller algorithm.
!
  th = atan2(y,x)
  a = 3.0/(1.0 + r)
  b = 14.7/(28.0 + r)
  c = 4.0*cos(pi*nu)/(c1*eps0*(2.0*r)**(0.25))
  m = (0.485/r)*(alog(c) + r*cos(a*th)/(1.0 + 0.008*r))**2/ &
      (2.0*cos(b*th))**2 + 1.5
!
!     backward recurrence in miller algorithm.
!
  s = 0.0
  u2 = 0.0
  u1 = eps0
  l = m
  do 10 i = 1, m
     u3 = u2
     u2 = u1
     ai = ((l - 0.5)**2 - nu*nu)/(l*(l + 1.0))
     bi = (2.0/(l + 1.0))*(l + z)
     u1 = (bi*u2 - u3)/ai
     s = s + u1
   10 l = l - 1.0
!
!     final assembly
!
  k1 = c1*cexp(-z)*u1/(s*csqrt(z))
  k2 = 0.5*k1*(z + nu + 0.5 - u2/u1)*zr
  return
end
subroutine ckprod(a,ka,m,n,b,kb,k,l,c,kc)
!
!*******************************************************************************
!
!! CKPROD: kronecker product of complex matrices a and b
!
  complex a(ka,n),b(kb,l),c(kc,*)
  integer r,s
!
  j = 0
  do 40 s = 1,n
     do 30 jj = 1,l
     j = j + 1
!
!        compute the j-th column of c
!
        i = 0
        do 20 r = 1,m
           do ii = 1,k
             i = i + 1
             c(i,j) = a(r,s)*b(ii,jj)
           end do
   20       continue

   30    continue
   40 continue
  return
end
subroutine cl1(k, l, m, n, q, kq, kode, toler, iter, x, res, &
                    error, wk, iwk)
!
!*******************************************************************************
!
!! CL1 ???
!
  dimension q(kq,*), x(*), res(*), wk(*), iwk(*)
!
  klm = k + l + m
  call xl1(k, l, m, n, klm, kq, klm + n, n + 2, q, kode, toler, &
           iter, x, res, error, wk, iwk(klm+1), iwk(1))
  return
end
subroutine cle (rowk,n,b,c,d,ip,ierr)
!
!*******************************************************************************
!
!! CLE: solution of complex linear equations with reduced storage
!
  complex b(n),c(n),d(*)
  integer ip(*)
  complex bk,cj,ck,c1,dkj,zero
  external rowk
  data zero/(0.0,0.0)/
!
!     set the necessary constants
!
  ierr = 0
  np1 = n + 1
  max = n*n/4 + n + 3
  k = 1
  iflag = -1
!
!     get the first column of the transposed system
!
  call rowk(n,1,c)
  bk = b(1)
!
  if (n > 1) go to 10
  if (c(1) == zero) go to 200
  c(1) = bk/c(1)
  return
!
!     find the pivot for column 1
!
   10 m = 1
  s = abs(real(c(1))) + abs(aimag(c(1)))
  do 20 i = 2,n
  si = abs(real(c(i))) + abs(aimag(c(i)))
  if (si <= s) go to 20
  m = i
  s = si
   20 continue
!
  ip(1) = m
  c1 = c(m)
  c(m) = c(1)
  c(1) = c1
  if (c(1) == zero) go to 200
!
!     find the first elementary matrix and store it in d
!
  do 30 i = 2,n
   30 d(i-1) = -c(i)/c(1)
  d(n) = bk/c(1)
!
!     k loop - each k for a new column of the transposed system
!
  do 120 k = 2,n
  kp1 = k + 1
  km1 = k - 1
!
!       get column k
!
  call rowk(n,k,c)
  do 40 j = 1,km1
  m = ip(j)
  cj = c(j)
  c(j) = c(m)
   40 c(m) = cj
  bk = b(k)
!
  iflag = -iflag
  lcol = np1 - k
  lcolp1 = lcol + 1
  lastm1 = 1
  last = max - n + k
  if (k == 2) go to 50
!
  lastm1 = max - n + km1
  if (iflag < 0) last = last - n + k - 2
  if (iflag > 0) lastm1 = lastm1 - n + k - 3
!
!     j loop - effect of columns 1 to k-1 of l-inverse
!
   50 do 61 j = 1,km1
  cj = c(j)
  ij = (j-1)*lcolp1
  if (j == km1) ij = lastm1 - 1
!
!     i loop - effect of l-inverse on rows k to n+1
!
  do 60 i = k,n
  ij = ij + 1
   60 c(i) = c(i) + d(ij)*cj
   61 bk = bk - d(ij+1)*cj
!
!       k=n case
!
  m = k
  if (k < n) go to 70
  if (c(k) == zero) go to 200
  d(last) = bk/c(k)
  go to 90
!
!     find the pivot
!
   70 s = abs(real(c(k))) + abs(aimag(c(k)))
  do 71 i = kp1,n
  si = abs(real(c(i))) + abs(aimag(c(i)))
  if (si <= s) go to 71
  m = i
  s = si
   71 continue
!
  ip(k) = m
  ck = c(m)
  c(m) = c(k)
  c(k) = ck
  if (c(k) == zero) go to 200
!
!     find the k-th elementary matrix
!
  ik = last
  do 80 i = kp1,n
  d(ik) = -c(i)/c(k)
   80 ik = ik + 1
  d(ik) = bk/c(k)
!
!     form the product of the elementary matrices
!
   90 do 110 j = 1,km1
  kjold = j*lcolp1 + k - np1
  mjold = kjold + m - k
  ij = (j-1)*lcol
  ijold = ij + j
  if (j /= km1) go to 100
!
  kjold = lastm1
  mjold = lastm1 + m - k
  ijold = lastm1
!
  100 ik = last - 1
  dkj = d(mjold)
  d(mjold) = d(kjold)
  do 110 i = kp1,np1
  ij = ij + 1
  ijold = ijold + 1
  ik = ik + 1
  d(ij) = d(ijold) + d(ik)*dkj
  110 continue
  120 continue
!
  last = max
  if (iflag < 0) last = max - 2
  d(n) = d(last)
!
!     insert the solution in c
!
  do 130 i = 1,n
  130 c(i) = d(i)
!
  nm1 = n - 1
  do 140 i = 1,nm1
  k = n - i
  m = ip(k)
  ck = c(k)
  c(k) = c(m)
  140 c(m) = ck
  return
!
!     the system is singular
!
  200 ierr = k
  return
end
function cli(z)
!
!*******************************************************************************
!
!! CLI: computation of the complex logarithmic integral
!
  complex cli
  complex z
  real qb(25), qf(2), dl(2), ds, zd(2), zl(2)
  real az(2), c, pm, r, sm(2), tm(2), ts(2), sr(2)
!
!     c = pi**2/6
!     ---------------------
  data c /1.64493406684823/
!     ---------------------
  data qb(1) / 2.77777777777778e-2/,  qb(2) /-1.00000000000000e-2/, &
       qb(3) /-1.70068027210884e-2/,  qb(4) /-1.94444444444444e-2/, &
       qb(5) /-2.06611570247934e-2/,  qb(6) /-2.14173006480699e-2/, &
       qb(7) /-2.19488663772311e-2/,  qb(8) /-2.23492338111715e-2/, &
       qb(9) /-2.26636891351914e-2/,  qb(10)/-2.29178211549926e-2/, &
       qb(11)/-2.31276449354844e-2/,  qb(12)/-2.33038680700203e-2/, &
       qb(13)/-2.34539766464373e-2/,  qb(14)/-2.35833786876607e-2/, &
       qb(15)/-2.36960832049849e-2/,  qb(16)/-2.37951264448373e-2/, &
       qb(17)/-2.38828504258091e-2/,  qb(18)/-2.39610907251825e-2/, &
       qb(19)/-2.40313063764460e-2/,  qb(20)/-2.40946717197585e-2/, &
       qb(21)/-2.41521426124012e-2/,  qb(22)/-2.42045049812210e-2/, &
       qb(23)/-2.42524109782181e-2/,  qb(24)/-2.42964062815807e-2/, &
       qb(25)/-2.43369509729144e-2/
!     ---------------------
  az(1) = real(z)
  az(2) = aimag(z)
  r = cpabs(az(1),az(2))
  if (r > 0.5) go to 10
  sr(1) = 0.0
  sr(2) = 0.0
  qf(1) = -az(1)
  qf(2) = -az(2)
  tm(1) =  az(1)
  tm(2) =  az(2)
  go to 30
!
   10 if (r < 3.0) go to 20
  zl(1) = alog(r)
  zl(2) = atan2(az(2),az(1))
  sr(1) = c + 0.5*(zl(1)*zl(1) - zl(2)*zl(2))
  sr(2) = zl(1)*zl(2)
  qf(1) = (-az(1)/r)/r
  qf(2) = (az(2)/r)/r
  tm(1) = qf(1)
  tm(2) = qf(2)
  go to 30
!
   20 zd(1) = 1.0 + az(1)
  zd(2) = az(2)
  ds = zd(1)*zd(1) + zd(2)*zd(2)
  if (ds == 0.0) go to 100
  dl(1) = 0.5*alog(ds)
  dl(2) = atan2(zd(2),zd(1))
  if (ds > 0.25) go to 50
     zl(1) = alog(r)
     zl(2) = atan2(-az(2),-az(1))
     sr(1) = -c + (dl(1)*zl(1) - dl(2)*zl(2))
     sr(2) = dl(1)*zl(2) + dl(2)*zl(1)
     qf(1) = zd(1)
     qf(2) = zd(2)
     tm(1) = qf(1)
     tm(2) = qf(2)
!
!             evaluation of the taylor series
!
   30 sr(1) = sr(1) + tm(1)
  sr(2) = sr(2) + tm(2)
  sm(1) = 0.0
  sm(2) = 0.0
  pm = 1.0
   40    pm = pm + 1.0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = ts(1)
     tm(2) = ts(2)
     ts(1) = tm(1)/(pm*pm)
     ts(2) = tm(2)/(pm*pm)
     if (abs(sm(1)) + abs(ts(1)) /= abs(sm(1))) go to 41
     if (abs(sm(2)) + abs(ts(2)) == abs(sm(2))) go to 80
   41    sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     go to 40
!
!        evaluation of the series in  u = -ln(1 + z)
!
   50 qf(1) = dl(1)*dl(1) - dl(2)*dl(2)
  qf(2) = 2.0*dl(1)*dl(2)
  sr(1) = dl(1) + 0.25*qf(1)
  sr(2) = dl(2) + 0.25*qf(2)
  sm(1) = 0.0
  sm(2) = 0.0
  tm(1) = dl(1)
  tm(2) = dl(2)
  do 61 n = 1,25
     ts(1) = qb(n)*(tm(1)*qf(1) - tm(2)*qf(2))
     ts(2) = qb(n)*(tm(1)*qf(2) + tm(2)*qf(1))
     tm(1) = ts(1)
     tm(2) = ts(2)
     if (abs(sm(1)) + abs(tm(1)) /= abs(sm(1))) go to 60
     if (abs(sm(2)) + abs(tm(2)) == abs(sm(2))) go to 80
   60    sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
   61 continue
!
   80 cli = cmplx(sr(1) + sm(1), sr(2) + sm(2))
  return
!
!                  evaluation at z = -1
!
  100 cli = cmplx(-c, 0.0)
  return
end
function cloc2 (x, y)
!
!*******************************************************************************
!
!! CLOC2 determines if two arrays begin at the same spot.
!
!
!     x and y are arrays. it is assumed that x(1) and y(1) contain data.
!
!     cloc2(x,y) = .true.   if x and y begin in the same location
!     cloc2(x,y) = .false.  if x and y begin in different locations
!
!     it is recommended that this coding not be optimized by eliminating
!     the subroutine cychg. if it is optimized then cloc2 may not compile
!     properly.
!
  logical cloc2 
  complex x(*), y(*), xold, yold
!
  xold = x(1)
  yold = y(1)
  call cychg(x,y,yold)
  if (x(1) == xold) go to 10
!
!     x and y begin in the same location
!
  y(1) = yold
  cloc2 = .true.
  return
!
!     x and y begin in different locations
!
   10 y(1) = yold
  cloc2 = .false.
  return
end
subroutine cluimp(a, ka, n, q, kq, ipvt, b, x, r, ind)
!
!*******************************************************************************
!
!! CLUIMP tries to improve the solution of a complex linear system.
!
!
!  Purpose:
!
!       given an approximate solution x of a complex system ax = b
!       obtained using cgeco or cgefa. cluimp attempts to compute
!       an improved solution correct to machine precision.
!
!  Parameters:
!
!       a    a complex array of dimension (ka,n) containing the
!            matrix a of order n.
!       q    a complex array of dimension (kq,n) containing the
!            lu decomposition of a produced by cgeco or cgefa.
!       ipvt an array of dimension n containing the permutation
!            information given by cgeco or cgefa.
!       b    the right hand side of the equation ax = b.
!       x    on input x is the approximate solution of ax = b to
!            be improved. on output x is the solution obtained.
!       r    a complex array for internal use by the routine.
!       ind  variable that reports the status of the results.
!            ind = 0 if improvement of x is successful with a
!            gain in accuracy of at least 50 per cent each
!            iteration. otherwise ind = 1.
!
  complex a(ka,n), q(kq,n), b(n), x(n), r(n)
  integer ipvt(n)
  double precision ra, ia, rx, ix, rsum, isum
!
  eps = epsilon ( eps )
  ind = 0
  xnrm = 0.0
  do 10 i = 1,n
   10 xnrm = xnrm + (real(x(i))**2 + aimag(x(i))**2)
  if (xnrm == 0.0) return
  eps2 = eps*eps
  ratio = 1.0
!
!                  compute the residual vector
!
   20 do 22 i = 1,n
  rsum = dble(real(b(i)))
  isum = dble(aimag(b(i)))
    do 21 j = 1,n
    ra = dble(real(a(i,j)))
    ia = dble(aimag(a(i,j)))
    rx = dble(real(x(j)))
    ix = dble(aimag(x(j)))
    rsum = rsum - ra*rx + ia*ix
   21   isum = isum - ra*ix - ia*rx
   22 r(i) = cmplx(sngl(rsum),sngl(isum))
!
!                  find the correction vector
!
  call cgesl(q, kq, n, ipvt, r, 0)
  rnrm = 0.0
  do 30 i = 1,n
   30 rnrm = rnrm + (real(r(i))**2 + aimag(r(i))**2)
  if (rnrm <= eps2*xnrm) return
!
!                form a new approximate solution
!
  do 40 i = 1,n
   40 x(i) = x(i) + r(i)
  xnrm = 0.0
  do 41 i = 1,n
   41 xnrm = xnrm + (real(x(i))**2 + aimag(x(i))**2)
!
  if (xnrm == 0.0) return
  rat = ratio
  ratio = rnrm/xnrm
  if (ratio <= 0.25*rat) go to 20
!
  if (ratio > amin1(rat,4.0*eps2)) ind = 1
  return
end
subroutine cmadd (m, n, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! CMADD: addition of complex matrices
!
  complex a(ka,n), b(kb,n), c(kc,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
        c(i,j) = a(i,j) + b(i,j)
   10    continue
   20 continue
  return
end
subroutine cmadj(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CMADJ copies the complex conjugate transpose of a matrix.
!
  complex a(ka,n),b(kb,m)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(j,i) = conjg(a(i,j))
   20 continue
  return
end
subroutine cmconj(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CMCONJ copies the conjugate of a complex matrix.
!
  complex a(ka,n),b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = conjg(a(i,j))
   20 continue
  return
end
subroutine cmcopy(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CMCOPY copies a complex matrix.
!
  complex a(ka,n),b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = a(i,j)
   20 continue
  return
end
subroutine cmcvbs(a,ka,m,n,ml,mu,b,ib,jb,num,ierr)
!
!*******************************************************************************
!
!! CMCVBS: conversion of complex matrices from banded to sparse form
!
  complex a(ka,*), b(*)
  integer ib(*), jb(*)
  complex zero
!     -----------------
  data zero /(0.0,0.0)/
!     -----------------
  kdim = ml + mu + 1
  l = 1
  nu = ml + 1
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 20
  do 11 i = 1,ml
  ib(i) = l
  nu = nu - 1
  kmin = 1 + nu
  kmax = min (kdim,n+nu)
     do 10 k = kmin,kmax
     if (a(i,k) == zero) go to 10
     if (l > num) go to 40
        b(l) = a(i,k)
        jb(l) = k - nu
        l = l + 1
   10    continue
   11 continue
!
!     store the remaining nonzero data
!
   20 imin = ml + 1
  imax = min (m,ml+n)
  do 22 i = imin,imax
  ib(i) = l
  nu = nu - 1
  kmax = min (kdim,n+nu)
     do 21 k = 1,kmax
     if (a(i,k) == zero) go to 21
     if (l > num) go to 40
        b(l) = a(i,k)
        jb(l) = k - nu
        l = l + 1
   21    continue
   22 continue
!
!     set up the remaining m-imax rows
!
  ierr = 0
  ibeg = imax + 1
  mp1 = m + 1
  do 30 i = ibeg,mp1
   30 ib(i) = l
  return
!
!     error return
!
   40 ierr = i
  return
end
subroutine cmcvsb(a,ia,ja,m,n,b,kb,nb,ml,mu,ierr)
!
!*******************************************************************************
!
!! CMCVSB: conversion of complex matrices from sparse to banded form
!
  complex a(*), b(kb,nb)
  integer ia(*), ja(*)
  complex zero
!     -----------------
  data zero /(0.0,0.0)/
!     -----------------
!
!     computation of ml and mu
!
  ml = 0
  mu = 0
  do 11 i = 1,m
  lmin = ia(i)
  lmax = ia(i+1) - 1
  if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
     if (a(l) == zero) go to 10
        k = ja(l) - i
        mu = max (mu, k)
        ml = max (ml,-k)
   10    continue
   11 continue
!
!     set b = 0 if b provides sufficient storage
!
  kmax = ml + mu + 1
  if (kmax > nb) go to 40
!
  ierr = 0
  do 21 k = 1,kmax
     do 20 i = 1,m
   20    b(i,k) = zero
   21 continue
!
!     store the matrix in b
!
  nu = ml + 1
  do 31 i = 1,m
  nu = nu - 1
  lmin = ia(i)
  lmax = ia(i+1) - 1
  if (lmin > lmax) go to 31
     do 30 l = lmin,lmax
     if (a(l) == zero) go to 30
        k = ja(l) + nu
        b(i,k) = a(l)
   30    continue
   31 continue
  return
!
!     error return
!
   40 ierr = kmax
  return
end
subroutine cmimag(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CMIMAG ???
!
  complex a(ka,n)
  real b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = aimag(a(i,j))
   20 continue
  return
end
subroutine cmprod (m, n, l, a, ka, b, kb, c, kc, row)
!
!*******************************************************************************
!
!! CMPROD: product of complex matrices
!
  complex a(ka,n), b(kb,l), c(kc,l), row(*), w
  logical cloc2
!
  w = c(1,1)
  c(1,1) = (1.0,0.0)
  if (cloc2(c,a)) go to 20
  if (cloc2(c,b)) go to 30
!
  do 12 j = 1,l
     do 11 i = 1,m
     w = (0.0,0.0)
        do 10 k = 1,n
   10       w = w + a(i,k)*b(k,j)
   11    c(i,j) = w
   12 continue
  return
!
!     here c begins in the same location as a. the dimension of row
!     must be greater than or equal to l. it is assumed that kc=ka.
!
   20 a(1,1) = w
  do 24 i = 1,m
     do 22 j = 1,l
     w = (0.0,0.0)
        do k = 1,n
          w = w + a(i,k)*b(k,j)
        end do
   22    row(j) = w
     do 23 j = 1,l
   23    a(i,j) = row(j)
   24 continue
  return
!
!     here c begins in the same location as b. the dimension of row
!     must be greater than or equal to m. it is assumed that kc=kb.
!
   30 b(1,1) = w
  do 34 j = 1,l
     do 32 i = 1,m
     w = (0.0,0.0)
        do 31 k = 1,n
   31       w = w + a(i,k)*b(k,j)
   32    row(i) = w
     do 33 i = 1,m
   33    b(i,j) = row(i)
   34 continue
  return
end
subroutine cmreal(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CMREAL ???
!
  complex a(ka,n)
  real b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = real(a(i,j))
   20 continue
  return
end
subroutine cmslv(mo,n,m,a,ka,b,kb,det,rcond,ierr,ipvt,wk)
!
!*******************************************************************************
!
!! CMSLV: partial pivot gauss procedure for inverting complex matrices
!     and solving complex equations
!
  complex a(ka,n), b(*), det(2), wk(n)
  real rcond, t
  integer ipvt(n), onej
!
!          matrix factorization and computation of rcond
!
  ierr = 0
  call cgeco (a, ka, n, ipvt, rcond, wk)
  t = 1.0 + rcond
  if (t == 1.0) go to 30
!
!                  solution of the equation ax=b
!
  if (m < 1) go to 20
  onej = 1
  do 10 j = 1,m
     call cgesl (a, ka, n, ipvt, b(onej), 0)
   10    onej = onej + kb
!
!             calculation of det and the inverse of a
!
   20 job = 10
  if (mo == 0) job = 11
  call cgedi (a, ka, n, ipvt, det, wk, job)
  return
!
!                  the problem cannot be solved
!
   30 ierr = 1
  return
end
subroutine cmslv1 (mo, n, m, a, ka, b, kb, ierr, ipvt, wk)
!
!*******************************************************************************
!
!! CMSLV1: partial pivot gauss procedure for inverting complex matrices
!     and solving complex equations
!
  complex a(ka,n), b(*), wk(*)
  integer ipvt(n)
  complex d(2)
  integer onej
!
  if (n < 1 .or. ka  <  n) go to 30
!
!                      matrix factorization
!
  call cgefa (a, ka, n, ipvt, ierr)
  if (ierr /= 0) return
!
!                 solution of the equation ax = b
!
  if (m <= 0) go to 20
  if (kb < n) go to 30
  onej = 1
  do 10 j = 1,m
     call cgesl (a, ka, n, ipvt, b(onej), 0)
   10    onej = onej + kb
!
!                 calculation of the inverse of a
!
   20 if (mo == 0) call cgedi (a, ka, n, ipvt, d, wk, 1)
  return
!
!                          error return
!
   30 ierr = -1
  return
end
subroutine cmsubt (m, n, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! CMSUBT: subtraction of complex matrices
!
  complex a(ka,n), b(kb,n), c(kc,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
        c(i,j) = a(i,j) - b(i,j)
   10    continue
   20 continue
  return
end
subroutine cmtms (m, n, l, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! CMTMS: product of complex matrices
!
  complex a(ka,n), b(kb,l), c(kc,l), w
!
  do 30 j = 1,l
     do 20 i = 1,m
        w = (0.0,0.0)
        do 10 k = 1,n
           w = w + a(i,k)*b(k,j)
   10       continue
        c(i,j) = w
   20    continue
   30 continue
  return
end
subroutine cnspiv (n,ia,ja,a,b,max,r,c,ic,x,y,p,iu,ju,u,ierr)
!
!*******************************************************************************
!
!! CNSPIV uses sparse gaussian elimination with
!  column interchanges to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!
!  see cspslv for descriptions of all input and output arguments
!  other than those described below
!
!  ic  integer array of n entries which is the inverse of c
!      (i.e., ic(c(i)) = i). ic is both an input and output
!      argument.
!
!  input arguments (used internally only)---
!
!  y   complex array of n entries used to compute the updated
!      right hand side
!
!  p   integer array of n+1 entries used for a linked list.
!      p(n+1) is the list header, and the entry following
!      p(k) is in p(p(k)).  thus, p(n+1) is the first data
!      item, p(p(n+1)) is the second, etc.  a pointer of
!      n+1 marks the end of the list
!
!  iu  integer array of n+1 entries used for row pointers to u
!      (see matrix storage description below)
!
!  ju  integer array of max entries used for column numbers of
!      the nonzeros in the strict upper triangle of u.  (see
!      matrix storage description below)
!
!  u   complex array of max entries used for the actual nonzeros in
!      the strict upper triangle of u.  (see matrix storage
!      description below)
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzeros in
!  a.  iu, ju, and u are used in a similar way to store the strict upper
!  triangle of u, except that ju actually contains c(j) instead of j
!
!
  complex a(*), b(n), u(max), x(n), y(n)
  complex dk, lki, one, yk, zero
  real xpv, xpvmax
  integer c(n), ia(*), ic(n), iu(*), ja(*), ju(max), p(*), r(n)
  integer ck, pk, ppk, pv, v, vi, vj, vk
!
  one = (1.0,0.0)
  zero = (0.0,0.0)
!
!  initialize work storage and pointers to ju
!
  x(1:n) = zero
  iu(1) = 1
  juptr = 0
!
!  perform symbolic and numeric factorization row by row
!  vk (vi,vj) is the graph vertex for row k (i,j) of u
!
  do 170 k = 1,n
!
!  initialize linked list and free storage for this row
!  the r(k)-th row of a becomes the k-th row of u.
!
    p(n+1) = n+1
    vk = r(k)
!
!  set up adjacency list for vk, ordered in
!  current column order of u.  the loop index
!  goes downward to exploit any columns
!  from a in correct relative order
!
    jmin = ia(vk)
    jmax = ia(vk+1) - 1
    if (jmin > jmax)  go to 1002
    j = jmax
 20       jaj = ja(j)
      vj = ic(jaj)
!
!  store a(k,j) in work vector
!
      x(vj) = a(j)
!  this code inserts vj into adjacency list of vk
      ppk = n+1
 30       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  30,1003,40
 40       p(vj) = ppk
      p(pk) = vj
      j = j - 1
      if (j >= jmin) go to 20
!
!  the following code computes the k-th row of u
!
    vi = n+1
    yk = b(vk)
 50     vi = p(vi)
    if (vi >= k) go to 110
!
!  vi lt vk -- process the l(k,i) element and merge the
!  adjacency of vi with the ordered adjacency of vk
!
    lki = - x(vi)
    x(vi) = zero
!
!  adjust right hand side to reflect elimination
!
    yk = yk + lki * y(vi)
    ppk = vi
    jmin = iu(vi)
    jmax = iu(vi+1) - 1
    if (jmin > jmax)  go to 50
    do 100 j = jmin,jmax
      juj = ju(j)
      vj = ic(juj)
!
!  if vj is already in the adjacency of vk,
!  skip the insertion
!
      if (x(vj) /= zero)  go to 90
!
!  insert vj in adjacency list of vk.
!  reset ppk to vi if we have passed the correct
!  insertion spot.  (this happens when the adjacency of
!  vi is not in current column order due to pivoting.)
!
      if (vj - ppk) 60,90,70
 60       ppk = vi
 70       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  70,90,80
 80       p(vj) = ppk
      p(pk) = vj
      ppk = vj
!
!  compute l(k,j) = l(k,j) - l(k,i)*u(i,j) for l(k,i) nonzero
!  compute u*(k,j) = u*(k,j) - l(k,i)*u(i,j) for u(k,j) nonzero
!  (u*(k,j) = u(k,j)*d(k,k))
!
 90       x(vj) = x(vj) + lki * u(j)
 100    continue
    go to 50
!
!  pivot--interchange largest entry of k-th row of u with
!  the diagonal entry.
!
!  find largest entry, counting off-diagonal nonzeros
!
 110    if (vi > n) go to 1004
    xpvmax = abs(real(x(vi))) + abs(aimag(x(vi)))
    maxc = vi
    nzcnt = 0
    pv = vi
 120      v = pv
      pv = p(pv)
      if (pv > n) go to 130
      nzcnt = nzcnt + 1
      xpv = abs(real(x(pv))) + abs(aimag(x(pv)))
      if (xpv <= xpvmax) go to 120
      xpvmax = xpv
      maxc = pv
      maxcl = v
      go to 120
 130    if (xpvmax == 0.0) go to 1004
!
!  if vi = k, then there is an entry for diagonal
!  which must be deleted.  otherwise, delete the
!  entry which will become the diagonal entry
!
    if (vi == k) go to 140
    if (vi == maxc) go to 140
    p(maxcl) = p(maxc)
    go to 150
 140    vi = p(vi)
!
!  compute d(k) = 1/l(k,k) and perform interchange.
!
 150    dk = one / x(maxc)
    x(maxc) = x(k)
    i = c(k)
    c(k) = c(maxc)
    c(maxc) = i
    ck = c(k)
    ic(ck) = k
    ic(i) = maxc
    x(k) = zero
!
!  update right hand side.
!
    y(k) = yk * dk
!
!  compute value for iu(k+1) and check for storage overflow
!
    iu(k+1) = iu(k) + nzcnt
    if (iu(k+1) > max+1) go to 1005
!
!  move column indices from linked list to ju.
!  columns are stored in current order with original
!  column number (c(j)) stored for current column j
!
    if (vi > n)  go to 170
    j = vi
 160      juptr = juptr + 1
      ju(juptr) = c(j)
      u(juptr) = x(j) * dk
      x(j) = zero
      j = p(j)
      if (j <= n) go to 160
 170    continue
!
!  backsolve u x = y, and reorder x to correspond with a
!
  k = n
  do 200 i = 1,n
    yk = y(k)
    jmin = iu(k)
    jmax = iu(k+1) - 1
    if (jmin > jmax)  go to 190
    do 180 j = jmin,jmax
      juj = ju(j)
      juj = ic(juj)
      yk = yk - u(j) * y(juj)
 180    continue
 190    y(k) = yk
    ck = c(k)
    x(ck) = yk
    k = k - 1
 200  continue
!
!  return with ierr = number of off-diagonal nonzeros in u
!
  ierr = iu(n+1) - iu(1)
  return
!
!  error returns
!
!  row k of a is null
!
 1002 ierr = -k
  return
!
!  row k of a has a duplicate entry
!
 1003 ierr = -(n+k)
  return
!
!  zero pivot in row k
!
 1004 ierr = -(2*n+k)
  return
!
!  storage for u exceeded on row k
!
 1005 ierr = -(3*n+k)
  return
end
subroutine compb (n,ierror,an,bn,cn,b,ah,bh)
!
!*******************************************************************************
!
!! COMPB computes the roots of the b polynomials using tqlrt0,
!     which is a modification of the eispack subroutine tqlrat.
!     ierror is set to 4 if either tqlrt0 fails or a(j+1)*c(j) is
!     less than 0 for some j. ah and bh are temporary work arrays.
!
  dimension       an(*)      ,bn(*)      ,cn(*)      ,b(*)       , &
                  ah(*)      ,bh(*)
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  eps = epsilon ( eps )
  bnorm = abs(bn(1))
  do  40 j=2,nm
     bnorm = max ( bnorm,abs(bn(j)))
     arg = an(j)*cn(j-1)
     if (arg) 220, 30, 30
   30    b(j) = sign(sqrt(arg),an(j))
   40 continue
  cnv = eps*bnorm
  if = 2**k
  kdo = k-1
  do 100 l=1,kdo
     ir = l-1
     i2 = 2**ir
     i4 = i2+i2
     ipl = i4-1
     ifd = if-i4
     do  90 i=i4,ifd,i4
        call indxb (i,l,ib,nb)
        if (nb) 100,100, 50
   50       js = i-ipl
        jf = js+nb-1
        ls = 0
        do  60 j=js,jf
           ls = ls+1
           bh(ls) = bn(j)
           ah(ls) = b(j)
   60       continue
        call tqlrt0 (nb,bh,ah,ierror)
        if (ierror) 210, 70,210
   70       lh = ib-1
        do  80 j=1,nb
           lh = lh+1
           b(lh) = -bh(j)
   80       continue
   90    continue
  100 continue
  do 110 j=1,nm
     b(j) = -bn(j)
  110 continue
  if (npp /= 0) return
!
  nmp = nm+1
  nb = nm+nmp
  do 150 j=1,nb
     l1 = mod(j-1,nmp)+1
     l2 = mod(j+nm-1,nmp)+1
     arg = an(l1)*cn(l2)
     if (arg < 0.0) go to 220
     bh(j) = sign(sqrt(arg),-an(l1))
     ah(j) = -bn(l1)
  150 continue
  call tqlrt0 (nb,ah,bh,ierror)
  if (ierror /= 0) go to 210
!
  call indxb (if,k-1,j2,lh)
  call indxb (if/2,k-1,j1,lh)
  j2 = j2+1
  lh = j2
  n2m2 = j2+nm+nm-2
  170 d1 = abs(b(j1)-b(j2-1))
  d2 = abs(b(j1)-b(j2))
  d3 = abs(b(j1)-b(j2+1))
  if ((d2 < d1) .and. (d2  <  d3)) go to 180
  b(lh) = b(j2)
  j2 = j2+1
  lh = lh+1
  if (j2-n2m2) 170,170,190
  180 j2 = j2+1
  j1 = j1+1
  if (j2-n2m2) 170,170,190
  190 b(lh) = b(n2m2+1)
  call indxb (if,k-1,j1,j2)
  j2 = j1+nmp+nmp
  call ppadd (nm+1,ierror,an,cn,b(j1),b(j1),b(j2))
  return
!
!     error return
!
  210 ierror = 4
  return
  220 ierror = 5
  return
end
subroutine comqr(nm,n,low,igh,hr,hi,wr,wi,ierr)
!
!*******************************************************************************
!
!! COMQR is a translation of a unitary analogue of the
!     algol procedure  comlr, num. math. 12, 369-376(1968) by martin
!     and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 396-403(1971).
!     the unitary analogue substitutes the qr algorithm of francis
!     (comp. jour. 4, 332-345(1962)) for the lr algorithm.
!
!     this subroutine finds the eigenvalues of a complex
!     upper hessenberg matrix by the qr method.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  cbal.  if  cbal  has not been used,
!          set low=1, igh=n,
!
!        hr and hi contain the real and imaginary parts,
!          respectively, of the complex upper hessenberg matrix.
!          their lower triangles below the subdiagonal contain
!          information about the unitary transformations used in
!          the reduction by  corth, if performed.
!
!     on output-
!
!        the upper hessenberg portions of hr and hi have been
!          destroyed.  therefore, they must be saved before
!          calling  comqr  if subsequent calculation of
!          eigenvectors is to be performed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  if an error
!          exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     arithmetic is real except for the replacement of the algol
!     procedure cdiv by complex division and use of the subroutines
!     csqrt and cmplx in computing complex square roots.
!
!
  integer i,j,l,n,en,ll,nm,igh,its,low,lp1,enm1,ierr
  real hr(nm,n),hi(nm,n),wr(n),wi(n)
  real si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,machep
  complex z3
!     integer min0
!     real sqrt,cabs,abs,real,aimag
!     complex csqrt,cmplx
!
             machep = epsilon ( machep )
!
!                **********
!
  ierr = 0
  if (low == igh) go to 180
!     ********** create real subdiagonal elements **********
  l = low + 1
!
  do 170 i = l, igh
     ll = min (i+1,igh)
     if (hi(i,i-1) == 0.0) go to 170
     norm = cabs(cmplx(hr(i,i-1),hi(i,i-1)))
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0
!
     do 155 j = i, igh
        si = yr * hi(i,j) - yi * hr(i,j)
        hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
        hi(i,j) = si
  155    continue
!
     do 160 j = low, ll
        si = yr * hi(j,i) + yi * hr(j,i)
        hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
        hi(j,i) = si
  160    continue
!
  170 continue
!     ********** store roots isolated by cbal **********
  180 do 200 i = 1, n
     if (i >= low .and. i <= igh) go to 200
     wr(i) = hr(i,i)
     wi(i) = hi(i,i)
  200 continue
!
  en = igh
  tr = 0.0
  ti = 0.0
!     ********** search for next eigenvalue.
  220 if (en < low) go to 1001
  its = 0
  enm1 = en - 1
!     ********** look for single small sub-diagonal element
!                for l=en step -1 until low  -- **********
  240 do 260 ll = low, en
     l = en + low - ll
     if (l == low) go to 300
     if (abs(hr(l,l-1)) <= &
        machep * (abs(hr(l-1,l-1)) + abs(hi(l-1,l-1)) &
               + abs(hr(l,l)) +abs(hi(l,l)))) go to 300
  260 continue
!     ********** form shift **********
  300 if (l == en) go to 660
  if (its == 30) go to 1000
  if (its == 10 .or. its == 20) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if (xr == 0.0 .and. xi == 0.0) go to 340
  yr = (hr(enm1,enm1) - sr) / 2.0
  yi = (hi(enm1,enm1) - si) / 2.0
  z3 = csqrt(cmplx(yr**2-yi**2+xr,2.0*yr*yi+xi))
  zzr = real(z3)
  zzi = aimag(z3)
  if (yr * zzr + yi * zzi >= 0.0) go to 310
  zzr = -zzr
  zzi = -zzi
  310 z3 = cmplx(xr,xi) / cmplx(yr+zzr,yi+zzi)
  sr = sr - real(z3)
  si = si - aimag(z3)
  go to 340
!     ********** form exceptional shift **********
  320 sr = abs(hr(en,enm1)) + abs(hr(enm1,en-2))
  si = 0.0
!
  340 do 360 i = low, en
     hr(i,i) = hr(i,i) - sr
     hi(i,i) = hi(i,i) - si
  360 continue
!
  tr = tr + sr
  ti = ti + si
  its = its + 1
!     ********** reduce to triangle (rows) **********
  lp1 = l + 1
!
  do 500 i = lp1, en
     sr = hr(i,i-1)
     hr(i,i-1) = 0.0
     norm = sqrt(hr(i-1,i-1)*hr(i-1,i-1)+hi(i-1,i-1)*hi(i-1,i-1) &
                 +sr*sr)
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0
     hi(i,i-1) = sr / norm
!
     do 490 j = i, en
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
  490    continue
!
  500 continue
!
  si = hi(en,en)
  if (si == 0.0) go to 540
  norm = cabs(cmplx(hr(en,en),si))
  sr = hr(en,en) / norm
  si = si / norm
  hr(en,en) = norm
  hi(en,en) = 0.0
!     ********** inverse operation (columns) **********
  540 do 600 j = lp1, en
     xr = wr(j-1)
     xi = wi(j-1)
!
     do 580 i = l, j
        yr = hr(i,j-1)
        yi = 0.0
        zzr = hr(i,j)
        zzi = hi(i,j)
        if (i == j) go to 560
        yi = hi(i,j-1)
        hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
  560       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  580    continue
!
  600 continue
!
  if (si == 0.0) go to 240
!
  do 630 i = l, en
     yr = hr(i,en)
     yi = hi(i,en)
     hr(i,en) = sr * yr - si * yi
     hi(i,en) = sr * yi + si * yr
  630 continue
!
  go to 240
!     ********** a root found **********
  660 wr(en) = hr(en,en) + tr
  wi(en) = hi(en,en) + ti
  en = enm1
  go to 220
!     ********** set error -- no convergence to an
!                eigenvalue after 30 iterations **********
 1000 ierr = en
 1001 return
!     ********** last card of comqr **********
end
subroutine comqr2(nm,n,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr)
!
!*******************************************************************************
!
!! COMQR2 is a translation of a unitary analogue of the
!     algol procedure  comlr2, num. math. 16, 181-204(1970) by peters
!     and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
!     the unitary analogue substitutes the qr algorithm of francis
!     (comp. jour. 4, 332-345(1962)) for the lr algorithm.
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a complex upper hessenberg matrix by the qr
!     method.  the eigenvectors of a complex general matrix
!     can also be found if  corth  has been used to reduce
!     this general matrix to hessenberg form.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  cbal.  if  cbal  has not been used,
!          set low=1, igh=n,
!
!        ortr and orti contain information about the unitary trans-
!          formations used in the reduction by  corth, if performed.
!          only elements low through igh are used.  if the eigenvectors
!          of the hessenberg matrix are desired, set ortr(j) and
!          orti(j) to 0.0 for these elements,
!
!        hr and hi contain the real and imaginary parts,
!          respectively, of the complex upper hessenberg matrix.
!          their lower triangles below the subdiagonal contain further
!          information about the transformations which were used in the
!          reduction by  corth, if performed.  if the eigenvectors of
!          the hessenberg matrix are desired, these elements may be
!          arbitrary.
!
!     on output-
!
!        ortr, orti, and the upper hessenberg portions of hr and hi
!          have been destroyed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  if an error
!          exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the eigenvectors.  the eigenvectors
!          are unnormalized.  if an error exit is made, none of
!          the eigenvectors has been found,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     arithmetic is real except for the replacement of the algol
!     procedure cdiv by complex division and use of the subroutines
!     csqrt and cmplx in computing complex square roots.
!
!
  integer i,j,k,l,m,n,en,ii,jj,ll,nm,nn,igh,ip1, &
          its,low,lp1,enm1,iend,ierr
  real hr(nm,n),hi(nm,n),wr(n),wi(n),zr(nm,n),zi(nm,n), &
         ortr(igh),orti(igh)
  real si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,machep
  complex z3
!     integer min0
!     real sqrt,cabs,abs,real,aimag
!     complex csqrt,cmplx
!
             machep = epsilon ( machep )
!
!                **********
!
  ierr = 0
!     ********** initialize eigenvector matrix **********
  do 100 i = 1, n
!
     do 100 j = 1, n
        zr(i,j) = 0.0
        zi(i,j) = 0.0
        if (i == j) zr(i,j) = 1.0
  100 continue
!     ********** form the matrix of accumulated transformations
!                from the information left by corth **********
  iend = igh - low - 1
  if (iend) 180, 150, 105
!     ********** for i=igh-1 step -1 until low+1 do -- **********
  105 do 140 ii = 1, iend
     i = igh - ii
     if (ortr(i) == 0.0 .and. orti(i) == 0.0) go to 140
     if (hr(i,i-1) == 0.0 .and. hi(i,i-1) == 0.0) go to 140
!     ********** norm below is negative of h formed in corth **********
     norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
     ip1 = i + 1
!
     do 110 k = ip1, igh
        ortr(k) = hr(k,i-1)
        orti(k) = hi(k,i-1)
  110    continue
!
     do 130 j = i, igh
        sr = 0.0
        si = 0.0
!
        do 115 k = i, igh
           sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
           si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
  115       continue
!
        sr = sr / norm
        si = si / norm
!
        do 120 k = i, igh
           zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
           zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
  120       continue
!
  130    continue
!
  140 continue
!     ********** create real subdiagonal elements.
  150 l = low + 1
!
  do 170 i = l, igh
     ll = min (i+1,igh)
     if (hi(i,i-1) == 0.0) go to 170
     norm = cabs(cmplx(hr(i,i-1),hi(i,i-1)))
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0
!
     do 155 j = i, n
        si = yr * hi(i,j) - yi * hr(i,j)
        hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
        hi(i,j) = si
  155    continue
!
     do 160 j = 1, ll
        si = yr * hi(j,i) + yi * hr(j,i)
        hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
        hi(j,i) = si
  160    continue
!
     do 165 j = low, igh
        si = yr * zi(j,i) + yi * zr(j,i)
        zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
        zi(j,i) = si
  165    continue
!
  170 continue
!     ********** store roots isolated by CBAL.
  180 do 200 i = 1, n
     if (i >= low .and. i <= igh) go to 200
     wr(i) = hr(i,i)
     wi(i) = hi(i,i)
  200 continue
!
  en = igh
  tr = 0.0
  ti = 0.0
!     ********** search for next eigenvalue **********
  220 if (en < low) go to 680
  its = 0
  enm1 = en - 1
!     ********** look for single small sub-diagonal element
!                for l=en step -1 until low do -- **********
  240 do 260 ll = low, en
     l = en + low - ll
     if (l == low) go to 300
     if (abs(hr(l,l-1)) <= &
        machep * (abs(hr(l-1,l-1)) + abs(hi(l-1,l-1)) &
               + abs(hr(l,l)) +abs(hi(l,l)))) go to 300
  260 continue
!     ********** form shift **********
  300 if (l == en) go to 660
  if (its == 30) go to 1000
  if (its == 10 .or. its == 20) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if (xr == 0.0 .and. xi == 0.0) go to 340
  yr = (hr(enm1,enm1) - sr) / 2.0
  yi = (hi(enm1,enm1) - si) / 2.0
  z3 = csqrt(cmplx(yr**2-yi**2+xr,2.0*yr*yi+xi))
  zzr = real(z3)
  zzi = aimag(z3)
  if (yr * zzr + yi * zzi >= 0.0) go to 310
  zzr = -zzr
  zzi = -zzi
  310 z3 = cmplx(xr,xi) / cmplx(yr+zzr,yi+zzi)
  sr = sr - real(z3)
  si = si - aimag(z3)
  go to 340
!     ********** form exceptional shift **********
  320 sr = abs(hr(en,enm1)) + abs(hr(enm1,en-2))
  si = 0.0
!
  340 do 360 i = low, en
     hr(i,i) = hr(i,i) - sr
     hi(i,i) = hi(i,i) - si
  360 continue
!
  tr = tr + sr
  ti = ti + si
  its = its + 1
!     ********** reduce to triangle (rows) **********
  lp1 = l + 1
!
  do 500 i = lp1, en
     sr = hr(i,i-1)
     hr(i,i-1) = 0.0
     norm = sqrt(hr(i-1,i-1)*hr(i-1,i-1)+hi(i-1,i-1)*hi(i-1,i-1) &
                 +sr*sr)
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0
     hi(i,i-1) = sr / norm
!
     do 490 j = i, n
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
  490    continue
!
  500 continue
!
  si = hi(en,en)
  if (si == 0.0) go to 540
  norm = cabs(cmplx(hr(en,en),si))
  sr = hr(en,en) / norm
  si = si / norm
  hr(en,en) = norm
  hi(en,en) = 0.0
  if (en == n) go to 540
  ip1 = en + 1
!
  do 520 j = ip1, n
     yr = hr(en,j)
     yi = hi(en,j)
     hr(en,j) = sr * yr + si * yi
     hi(en,j) = sr * yi - si * yr
  520 continue
!     ********** inverse operation (columns) **********
  540 do 600 j = lp1, en
     xr = wr(j-1)
     xi = wi(j-1)
!
     do 580 i = 1, j
        yr = hr(i,j-1)
        yi = 0.0
        zzr = hr(i,j)
        zzi = hi(i,j)
        if (i == j) go to 560
        yi = hi(i,j-1)
        hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
  560       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  580    continue
!
     do 590 i = low, igh
        yr = zr(i,j-1)
        yi = zi(i,j-1)
        zzr = zr(i,j)
        zzi = zi(i,j)
        zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
        zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  590    continue
!
  600 continue
!
  if (si == 0.0) go to 240
!
  do 630 i = 1, en
     yr = hr(i,en)
     yi = hi(i,en)
     hr(i,en) = sr * yr - si * yi
     hi(i,en) = sr * yi + si * yr
  630 continue
!
  do 640 i = low, igh
     yr = zr(i,en)
     yi = zi(i,en)
     zr(i,en) = sr * yr - si * yi
     zi(i,en) = sr * yi + si * yr
  640 continue
!
  go to 240
!     ********** a root found **********
  660 hr(en,en) = hr(en,en) + tr
  wr(en) = hr(en,en)
  hi(en,en) = hi(en,en) + ti
  wi(en) = hi(en,en)
  en = enm1
  go to 220
!     ********** all roots found.  backsubstitute to find
!                vectors of upper triangular form **********
  680 norm = 0.0
!
  do 720 i = 1, n
!
     do 720 j = i, n
        norm = norm + abs(hr(i,j)) + abs(hi(i,j))
  720 continue
!
  if (n == 1 .or. norm == 0.0) go to 1001
!     ********** for en=n step -1 until 2 do -- **********
  do 800 nn = 2, n
     en = n + 2 - nn
     xr = wr(en)
     xi = wi(en)
     enm1 = en - 1
!     ********** for i=en-1 step -1 until 1 do -- **********
     do 780 ii = 1, enm1
        i = en - ii
        zzr = hr(i,en)
        zzi = hi(i,en)
        if (i == enm1) go to 760
        ip1 = i + 1
!
        do 740 j = ip1, enm1
           zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
           zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
  740       continue
!
  760       yr = xr - wr(i)
        yi = xi - wi(i)
        if (yr == 0.0 .and. yi == 0.0) yr = machep * norm
        z3 = cmplx(zzr,zzi) / cmplx(yr,yi)
        hr(i,en) = real(z3)
        hi(i,en) = aimag(z3)
  780    continue
!
  800 continue
!     ********** end backsubstitution **********
  enm1 = n - 1
!     ********** vectors of isolated roots **********
  do  840 i = 1, enm1
     if (i >= low .and. i <= igh) go to 840
     ip1 = i + 1
!
     do 820 j = ip1, n
        zr(i,j) = hr(i,j)
        zi(i,j) = hi(i,j)
  820    continue
!
  840 continue
!     ********** multiply by transformation matrix to give
!                vectors of original full matrix.
!                for j=n step -1 until low+1 do -- **********
  do 880 jj = low, enm1
     j = n + low - jj
     m = min (j-1,igh)
!
     do 880 i = low, igh
        zzr = zr(i,j)
        zzi = zi(i,j)
!
        do 860 k = low, m
           zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
           zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
  860       continue
!
        zr(i,j) = zzr
        zi(i,j) = zzi
  880 continue
!
  go to 1001
!     ********** set error -- no convergence to an
!                eigenvalue after 30 iterations **********
 1000 ierr = en
 1001 return
!     ********** last card of comqr2 **********
end
function conew(cond,elinsy,relrsd,averr,pastc,pastre)
!
!*******************************************************************************
!
!! CONEW updates the value of the condition number in iegs.
!
  averr=sqrt(elinsy*pastre)
  pastre=elinsy
  if(relrsd == 0.0) go to 1
  c=max ( 1.0,elinsy/relrsd)
  conew=sqrt(c*pastc)
  pastc=c
  return
1     conew=cond
  return
end
subroutine constr (xk,yk,zk, cx,sx,cy,sy)
  real xk, yk, zk, cx, sx, cy, sy
!
!*******************************************************************************
!
!! CONSTR constructs the elements of a 3 by 3
! orthogonal matrix r which rotates a point (xk,yk,zk) on
! the unit sphere to the north pole, i.e.
!
!      (xk)     (cy  0 -sy)   (1   0   0)   (xk)     (0)
!  r * (yk)  =  ( 0  1   0) * (0  cx -sx) * (yk)  =  (0)
!      (zk)     (sy  0  cy)   (0  sx  cx)   (zk)     (1)
!
!                                               robert renka
!                                       oak ridge natl. lab.
!
! input parameters - xk,yk,zk - components of a unit vector
!                               to be rotated to (0,0,1).
!
! input parameters are not altered by this routine.
!
! output parameters - cx,sx,cy,sy - elements of r -- cx,sx
!                                   define a rotation about
!                                   the x-axis and cy,sy de-
!                                   fine a rotation about
!                                   the y-axis.
!
  cy = sqrt(yk*yk + zk*zk)
  sy = xk
  if (cy == 0.) go to 1
  cx = zk/cy
  sx = yk/cy
  return
!
! (xk,yk,zk) lies on the x-axis
!
1 cx = 1.
  sx = 0.
  return
end
subroutine corth(nm,n,low,igh,ar,ai,ortr,orti)
!
!*******************************************************************************
!
!! CORTH is a translation of a complex analogue of
!     the algol procedure orthes, num. math. 12, 349-368(1968)
!     by martin and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
!
!     given a complex general matrix, this subroutine
!     reduces a submatrix situated in rows and columns
!     low through igh to upper hessenberg form by
!     unitary similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  cbal.  if  cbal  has not been used,
!          set low=1, igh=n,
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the complex input matrix.
!
!     on output-
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the hessenberg matrix.  information
!          about the unitary transformations used in the reduction
!          is stored in the remaining triangles under the
!          hessenberg matrix,
!
!        ortr and orti contain further information about the
!          transformations.  only elements low through igh are used.
!
!
  integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
  real ar(nm,n),ai(nm,n),ortr(igh),orti(igh)
  real f,g,h,fi,fr,scale
!     real sqrt,cabs,abs
!     complex cmplx
!
  la = igh - 1
  kp1 = low + 1
  if (la < kp1) go to 200
!
  do 180 m = kp1, la
     h = 0.0
     ortr(m) = 0.0
     orti(m) = 0.0
     scale = 0.0
!     ********** scale column (algol tol then not needed) **********
     do 90 i = m, igh
   90    scale = scale + abs(ar(i,m-1)) + abs(ai(i,m-1))
!
     if (scale == 0.0) go to 180
     mp = m + igh
!     ********** for i=igh step -1 until m do -- **********
     do 100 ii = m, igh
        i = mp - ii
        ortr(i) = ar(i,m-1) / scale
        orti(i) = ai(i,m-1) / scale
        h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
  100    continue
!
     g = sqrt(h)
     f = cabs(cmplx(ortr(m),orti(m)))
     if (f == 0.0) go to 103
     h = h + f * g
     g = g / f
     ortr(m) = (1.0 + g) * ortr(m)
     orti(m) = (1.0 + g) * orti(m)
     go to 105
!
  103    ortr(m) = g
     ar(m,m-1) = scale
!     ********** form (i-(u*ut)/h) * a
  105    do 130 j = m, n
        fr = 0.0
        fi = 0.0
!     ********** for i=igh step -1 until m do -- **********
        do 110 ii = m, igh
           i = mp - ii
           fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
           fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
  110       continue
!
        fr = fr / h
        fi = fi / h
!
        do 120 i = m, igh
           ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
           ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
  120       continue
!
  130    continue
!     ********** form (i-(u*ut)/h)*a*(i-(u*ut)/h) **********
     do 160 i = 1, igh
        fr = 0.0
        fi = 0.0
!     ********** for j=igh step -1 until m do -- **********
        do 140 jj = m, igh
           j = mp - jj
           fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
           fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
  140       continue
!
        fr = fr / h
        fi = fi / h
!
        do 150 j = m, igh
           ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
           ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
  150       continue
!
  160    continue
!
     ortr(m) = scale * ortr(m)
     orti(m) = scale * orti(m)
     ar(m,m-1) = -g * ar(m,m-1)
     ai(m,m-1) = -g * ai(m,m-1)
  180 continue
!
  200 return

end
function cos0 (x)
!
!*******************************************************************************
!
!! COS0: computation of cos(x*pi/2) for abs(x) <= 0.5
!
  real cos0
!
  data a1 /-.123370055013615e+01/, a2 /.253669507899753e+00/, &
       a3 /-.208634807330586e-01/, a4 /.919259935580283e-03/, &
       a5 /-.252000841382533e-04/, a6 /.465461768260405e-06/
!
  t = x*x
  cos0 = (((((a6*t + a5)*t + a4)*t + a3)*t + a2)*t + a1)*t + 1.0
  return
end
function cos1 (x)
!
!*******************************************************************************
!
!! COS1: evaluation  of cos(x*pi)
!
  real cos1
  integer imax
!
  data a0 /.314159265358979e+01/, a1 /-.516771278004995e+01/, &
       a2 /.255016403987327e+01/, a3 /-.599264528932149e+00/, &
       a4 /.821458689493251e-01/, a5 /-.737001831310553e-02/, &
       a6 /.461514425296398e-03/
  data b1 /-.493480220054460e+01/, b2 /.405871212639605e+01/, &
       b3 /-.133526276691575e+01/, b4 /.235330543508553e+00/, &
       b5 /-.258048861575714e-01/, b6 /.190653140279462e-02/
!
  imax = huge ( imax )

  a = abs(x)

  if ( a >= real(imax) ) then
    cos1 = 1.0
    return
  end if

  n = a
  a = a - real(n)
  if (a > 0.75) go to 20
  if (a < 0.25) go to 21
!
!                    0.25 <= a <= 0.75
!
  a = 0.25 + (0.25 - a)
  t = a*a
  cos1 = ((((((a6*t + a5)*t + a4)*t + a3)*t + a2)*t &
                    + a1)*t + a0)*a
  go to 30
!
!                 a < 0.25  or  a > 0.75
!
   20 a = 0.25 + (0.75 - a)
  n = n - 1
   21 t = a*a
  cos1 = ((((((b6*t + b5)*t + b4)*t + b3)*t + b2)*t &
                    + b1)*t + 0.5) + 0.5
!
!                        termination
!
   30 if (mod(n,2) /= 0) cos1 = - cos1
  return
end
subroutine cosqb (n,x,wsave)
!
!*******************************************************************************
!
!! COSQB: ???
!
  dimension x(*), wsave(*)
  data tsqrt2 /2.82842712474619/
  if (n-2) 101,102,103
  101 x(1) = 4.*x(1)
  return
  102 x1 = 4.*(x(1)+x(2))
  x(2) = tsqrt2*(x(1)-x(2))
  x(1) = x1
  return
  103 call cosqb1 (n,x,wsave,wsave(n+1))
  return
end
subroutine cosqb1 (n,x,w,xh)
!
!*******************************************************************************
!
!! COSQB1: ???
!
  dimension       x(*)       ,w(*)       ,xh(*)
  ns2 = (n+1)/2
  np2 = n+2
  do 101 i=3,n,2
     xim1 = x(i-1)+x(i)
     x(i) = x(i)-x(i-1)
     x(i-1) = xim1
  101 continue
  x(1) = x(1)+x(1)
  modn = mod(n,2)
  if (modn == 0) x(n) = x(n)+x(n)
  call rfftb (n,x,xh)
  do 102 k=2,ns2
     kc = np2-k
     xh(k) = w(k-1)*x(kc)+w(kc-1)*x(k)
     xh(kc) = w(k-1)*x(k)-w(kc-1)*x(kc)
  102 continue
  if (modn == 0) x(ns2+1) = w(ns2)*(x(ns2+1)+x(ns2+1))
  do 103 k=2,ns2
     kc = np2-k
     x(k) = xh(k)+xh(kc)
     x(kc) = xh(k)-xh(kc)
  103 continue
  x(1) = x(1)+x(1)
  return
end
subroutine cosqf (n,x,wsave)
!
!*******************************************************************************
!
!! COSQF
!
  dimension x(*), wsave(*)
  data sqrt2 /1.4142135623731/
  if (n-2) 102,101,103
  101 tsqx = sqrt2*x(2)
  x(2) = x(1)-tsqx
  x(1) = x(1)+tsqx
  102 return
  103 call cosqf1 (n,x,wsave,wsave(n+1))
  return
end
subroutine cosqf1 (n,x,w,xh)
!
!*******************************************************************************
!
!! COSQF1: ???
!
  dimension       x(*)       ,w(*)       ,xh(*)
  ns2 = (n+1)/2
  np2 = n+2
  do 101 k=2,ns2
     kc = np2-k
     xh(k) = x(k)+x(kc)
     xh(kc) = x(k)-x(kc)
  101 continue
  modn = mod(n,2)
  if (modn == 0) xh(ns2+1) = x(ns2+1)+x(ns2+1)
  do 102 k=2,ns2
     kc = np2-k
     x(k) = w(k-1)*xh(kc)+w(kc-1)*xh(k)
     x(kc) = w(k-1)*xh(k)-w(kc-1)*xh(kc)
  102 continue
  if (modn == 0) x(ns2+1) = w(ns2)*xh(ns2+1)
  call rfftf (n,x,xh)
  do 103 i=3,n,2
     xim1 = x(i-1)-x(i)
     x(i) = x(i-1)+x(i)
     x(i-1) = xim1
  103 continue
  return
end
subroutine cosqi (n,wsave)
!
!*******************************************************************************
!
!! COSQI ???
!
  dimension       wsave(*)
  data pih /1.57079632679491/
  dt = pih/real(n)
  fk = 0.
  do 101 k=1,n
     fk = fk+1.
     wsave(k) = cos(fk*dt)
  101 continue
  call rffti (n,wsave(n+1))
  return
end
subroutine covar(n, m1, n1, ipivot, c, d, z, nn)
!
!*******************************************************************************
!
!! COVAR uses results from the orthogonal decomposition
! stored in c, d and ipivot to compute the unscaled covariance matrix
! of the least squares coefficients.
! on entry, the first n rows and the first n columns of c contain the
! upper triangular matrix obtained from the decomposition.  this input
! matrix is destroyed in subsequent calculations.
! on exit, the lower triangular portion of the symmetric unscaled
! covariance matrix is contained in
!     c(1,1)
!     c(2,1) c(2,2)
!     . . .
!     c(n,1) c(n,2) ... c(n,n)
! if n1 is less than n, one or more columns of the matrix
! h = (sqrt(w))*a were rejected as being linearly dependent.  whenever
! the k-th column of h was so rejected, c(i,j) is set equal to zero,
! for i = k or j = k, i >= j.
  integer ipivot(n)
  real c(nn,n), d(*), z(*)
  double precision sum
  l = n1
  if (l > m1) c(l,l) = 1.0/d(l)
  if (l == 1) go to 60
   10 j = l - 1
  if (j > m1) c(j,j) = 1.0/d(j)
  do 20 k=l,n1
    z(k) = c(j,k)
   20 continue
  i = n1
  do 40 ka=j,n1
    sum = 0.0
    if (i == j) sum = dble(c(i,j))
    do 30 k=l,n1
      sum = sum - dble(z(k))*dble(c(k,i))
   30   continue
    c(i,j) = sum
    i = i - 1
   40 continue
  do 50 k=l,n1
    c(j,k) = c(k,j)
   50 continue
  l = l - 1
  if (l > 1) go to 10
   60 if (n1 == n) go to 90
  n1p1 = n1 + 1
  do 80 i=1,n
    do 70 j=n1p1,n
      c(i,j) = 0.0
   70   continue
   80 continue
! permute the columns and rows of matrix c to account for pivoting.
   90 do 120 i=1,n
    do 100 j=1,n
      k = ipivot(j)
      z(k) = c(i,j)
  100   continue
    do 110 j=1,n
      c(i,j) = z(j)
  110   continue
  120 continue
  do 150 i=1,n
    do 130 j=1,n
      k = ipivot(j)
      z(k) = c(j,i)
  130   continue
    do 140 j=i,n
      c(j,i) = z(j)
  140   continue
  150 continue
  return
end
function cpabs(x, y)
!
!*******************************************************************************
!
!! CPABS: evaluation of sqrt(x*x + y*y)
!
  real cpabs
!
  if (abs(x) <= abs(y)) go to 10
     a = y/x
     cpabs = abs(x)*sqrt(1.0 + a*a)
     return
   10 if (y == 0.0) go to 20
     a = x/y
     cpabs = abs(y)*sqrt(1.0 + a*a)
     return
   20 cpabs = 0.0
  return
end
subroutine cpose (a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! CPOSE: transposing a sparse complex matrix
!
  complex a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1
  do 41 j = 1,np1
     ib(j) = 1
   41 continue
  return
end
subroutine cpose1 (p, a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! CPOSE1: transposing a sparse complex matrix
!                 where the rows are interchanged
!
  integer p(m)
  complex a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ii = p(i)
     ipmin = ia(ii)
     ipmax = ia(ii+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1

  ib(1:np1) = 1

  return
end
subroutine cprod0(nd,bd,nm1,bm1,nm2,bm2,na,aa,x,yy,m,a,b,c,d,w,y)
!
!*******************************************************************************
!
!! CPROD0 applies a sequence of matrix operations to the vector x and
! stores the result in yy.   (complex case)
!
! aa         array containing scalar multipliers of the vector x.
! nd,nm1,nm2 the lengths of the arrays bd,bm1,bm2 respectively.
! bd,bm1,bm2 arrays containing roots of certian b polynomials.
! na         the length of the array aa.
! x,yy       matrix operations are applied to x and the result is yy.
! a,b,c      arrays which contain the tridiagonal matrix.
! m          the order of the matrix.
! d,w,y      working arrays.
! isgn       determines whether or not a change in sign is made.
!
  complex         y          ,d          ,w          ,bd         , &
                  crt        ,den        ,y1         ,y2
  dimension       a(*)       ,b(*)       ,c(*)       ,x(*)       , &
                  y(*)       ,d(*)       ,w(*)       ,bd(*)      , &
                  bm1(*)     ,bm2(*)     ,aa(*)      ,yy(*)
!
  do  10 j=1,m
     y(j) = cmplx(x(j),0.)
   10 continue
  mm = m-1
  id = nd
  m1 = nm1
  m2 = nm2
  ia = na
   20 iflg = 0
  if (id)  90, 90, 30
   30 crt = bd(id)
  id = id-1
!
! begin solution to system
!
  d(m) = a(m)/(b(m)-crt)
  w(m) = y(m)/(b(m)-crt)
  do  40 j=2,mm
     k = m-j
     den = b(k+1)-crt-c(k+1)*d(k+2)
     d(k+1) = a(k+1)/den
     w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den
   40 continue
  den = b(1)-crt-c(1)*d(2)
  if (cabs(den))  50, 60, 50
   50 y(1) = (y(1)-c(1)*w(2))/den
  go to  70
   60 y(1) = (1.,0.)
   70 do  80 j=2,m
     y(j) = w(j)-d(j)*y(j-1)
   80 continue
   90 if (m1) 100,100,120
  100 if (m2) 210,210,110
  110 rt = bm2(m2)
  m2 = m2-1
  go to 170
  120 if (m2) 130,130,140
  130 rt = bm1(m1)
  m1 = m1-1
  go to 170
  140 if (abs(bm1(m1))-abs(bm2(m2))) 160,160,150
  150 rt = bm1(m1)
  m1 = m1-1
  go to 170
  160 rt = bm2(m2)
  m2 = m2-1
  170 y1 = (b(1)-rt)*y(1)+c(1)*y(2)
  if (mm-2) 200,180,180
!
! matrix multiplication
!
  180 do 190 j=2,mm
     y2 = a(j)*y(j-1)+(b(j)-rt)*y(j)+c(j)*y(j+1)
     y(j-1) = y1
     y1 = y2
  190 continue
  200 y(m) = a(m)*y(m-1)+(b(m)-rt)*y(m)
  y(m-1) = y1
  iflg = 1
  go to  20
  210 if (ia) 240,240,220
  220 rt = aa(ia)
  ia = ia-1
  iflg = 1
!
! scalar multiplication
!
  do 230 j=1,m
     y(j) = rt*y(j)
  230 continue
  240 if (iflg) 250,250, 20
  250 do 260 j=1,m
     yy(j) = real(y(j))
  260 continue
  return
end
subroutine cprodp (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,yy,m,a,b,c,d,u,y)
!
!*******************************************************************************
!
!! CPRODP applies a sequence of matrix operations to the vector x and
! stores the result in yy.  (periodic boundary conditions and
! complex case)
!
! bd,bm1,bm2 arrays containing roots of certian b polynomials.
! nd,nm1,nm2 the lengths of the arrays bd,bm1,bm2 respectively.
! aa         array containing scalar multipliers of the vector x.
! na         the length of the array aa.
! x,yy       matrix operations are applied to x and the result is yy.
! a,b,c      arrays which contain the tridiagonal matrix.
! m          the order of the matrix.
! d,u,y      working arrays.
! isgn       determines whether or not a change in sign is made.
!
  complex         y          ,d          ,u          ,v          , &
                  den        ,bh         ,ym         ,am         , &
                  y1         ,y2         ,yh         ,bd         , &
                  crt
  dimension       a(*)       ,b(*)       ,c(*)       ,x(*)       , &
                  y(*)       ,d(*)       ,u(*)       ,bd(*)      , &
                  bm1(*)     ,bm2(*)     ,aa(*)      ,yy(*)
!
  do  10 j=1,m
     y(j) = cmplx(x(j),0.)
   10 continue
  mm = m-1
  mm2 = m-2
  id = nd
  m1 = nm1
  m2 = nm2
  ia = na
   20 iflg = 0
  if (id) 110,110, 30
   30 crt = bd(id)
  id = id-1
  iflg = 1
!
! begin solution to system
!
  bh = b(m)-crt
  ym = y(m)
  den = b(1)-crt
  d(1) = c(1)/den
  u(1) = a(1)/den
  y(1) = y(1)/den
  v = cmplx(c(m),0.)
  if (mm2-2)  60, 40, 40
   40 do  50 j=2,mm2
     den = b(j)-crt-a(j)*d(j-1)
     d(j) = c(j)/den
     u(j) = -a(j)*u(j-1)/den
     y(j) = (y(j)-a(j)*y(j-1))/den
     bh = bh-v*u(j-1)
     ym = ym-v*y(j-1)
     v = -v*d(j-1)
   50 continue
   60 den = b(m-1)-crt-a(m-1)*d(m-2)
  d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den
  y(m-1) = (y(m-1)-a(m-1)*y(m-2))/den
  am = a(m)-v*d(m-2)
  bh = bh-v*u(m-2)
  ym = ym-v*y(m-2)
  den = bh-am*d(m-1)
  if (cabs(den))  70, 80, 70
   70 y(m) = (ym-am*y(m-1))/den
  go to  90
   80 y(m) = (1.,0.)
   90 y(m-1) = y(m-1)-d(m-1)*y(m)
  do 100 j=2,mm
     k = m-j
     y(k) = y(k)-d(k)*y(k+1)-u(k)*y(m)
  100 continue
  110 if (m1) 120,120,140
  120 if (m2) 230,230,130
  130 rt = bm2(m2)
  m2 = m2-1
  go to 190
  140 if (m2) 150,150,160
  150 rt = bm1(m1)
  m1 = m1-1
  go to 190
  160 if (abs(bm1(m1))-abs(bm2(m2))) 180,180,170
  170 rt = bm1(m1)
  m1 = m1-1
  go to 190
  180 rt = bm2(m2)
  m2 = m2-1
!
! matrix multiplication
!
  190 yh = y(1)
  y1 = (b(1)-rt)*y(1)+c(1)*y(2)+a(1)*y(m)
  if (mm-2) 220,200,200
  200 do 210 j=2,mm
     y2 = a(j)*y(j-1)+(b(j)-rt)*y(j)+c(j)*y(j+1)
     y(j-1) = y1
     y1 = y2
  210 continue
  220 y(m) = a(m)*y(m-1)+(b(m)-rt)*y(m)+c(m)*yh
  y(m-1) = y1
  iflg = 1
  go to  20
  230 if (ia) 260,260,240
  240 rt = aa(ia)
  ia = ia-1
  iflg = 1
!
! scalar multiplication
!
  do 250 j=1,m
     y(j) = rt*y(j)
  250 continue
  260 if (iflg) 270,270, 20
  270 do 280 j=1,m
     yy(j) = real(y(j))
  280 continue
  return
end
subroutine cpsc (f, z, n, ic, tol, r, rs, err)
!
!*******************************************************************************
!
!! CPSC: evaluation of complex power series coefficients or derivatives.
!
!  *** input parameters ***
!    f   complex function, of which the coefficients or derivatives
!        are sought. this function must be declared external in the
!        calling program.
!    z   complex point around which f is to be expanded or at which
!        derivatives are to be evaluated.
!    n   integer, number of coefficients or derivatives wanted.
!        n must be ge 1 and le 51.
!    ic  selects between power series coefficients and derivatives.
!        ic == 0   routine returns power series coefficients in rs.
!        ic /= 0   routine returns derivatives in rs.
!    tol estimated relative accuracy of f. it is assumed that tol
!        is nonnegative. if tol = 0 then f is assumed to be correct
!        to machine accuracy.
!
!  *** input and output parameter ***
!    r   initial radius used in search for optimal radius. the resulting
!        radius is left in r. the provided guess may be in error with at
!        most a factor of 3.e4 .
!
!  *** output parameters ***
!    rs  complex array rs(n) containing the n first
!        coefficients (corresponding to the powers 0 to n-1) or deriva-
!        tives (orders 0 to n-1).
!    err real array err(n) containing absolute error estimates for the
!        numbers in rs.
!
  dimension ip(32),a(64),rs(n),err(n),rt(51,3),fv(6), &
    iw(7),sc(4),rv(3),c(4),fc(3)
  complex f,a,v,rs,rt,fv,u,w,t,z,rv,rq,s,xk,mult,co
!
!  list of the variables initialized in the data statement below.
!   iw   2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) .
!   ip   permutation constants for the fft.
!   rv   constants for the laurent series test.
!
  data iw(1),iw(2),iw(3),iw(4),iw(5),iw(6),iw(7)/1,2,4,8,16,32,64/
  data ip( 1),ip( 2),ip( 3),ip( 4),ip( 5),ip( 6),ip( 7),ip( 8), &
       ip( 9),ip(10),ip(11),ip(12),ip(13),ip(14),ip(15),ip(16), &
       ip(17),ip(18),ip(19),ip(20),ip(21),ip(22),ip(23),ip(24), &
       ip(25),ip(26),ip(27),ip(28),ip(29),ip(30),ip(31),ip(32)/ &
       64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14, &
       54,22,38,6,58,26,42,10,50,18,34,2/
  data rv(1)/(-.4,.3)/, rv(2)/(.7,.2)/, rv(3)/(.02,-.06)/
!
!  statement function for multiplication of a complex number
!  by a real number.
!
  mult(re,co) = cmplx(re*real(co),re*aimag(co))
!
                eps0 = epsilon ( eps0 )
!
!  -------------------
!
!  initialization.
!
  eps = max ( eps0,tol)
  sc(1) = .125
  c(1) = eps**(1./28.)
  ep6 = c(1)**6
  pi = 4.0*atan(1.0)
  fv(1) = (-1.,0.)
  fv(2) = (0.,-1.)
  r1 = sqrt(0.5)
  ra = 1.0/r1
  fv(3) = cmplx(r1,-r1)
  do 10 i = 2,4
    sc(i) = .5*sc(i-1)
    c(i) = sqrt(c(i-1))
    ang = pi*sc(i-1)
   10   fv(i+2) = cmplx(cos(ang),-sin(ang))
!
!  start execution.
!
  if (n > 51 .or. n < 1) go to 260
  l2 = 1
  lf = 0
  np = 0
  m = 0
  nr = -1
!
!  find if a fft over 8, 16, 32, or 64 points should be used.
!
  kl = 1
  if (n > 6) kl = 2
  if (n > 12) kl = 3
  if (n > 25) kl = 4
  km = kl + 2
  kn = 7 - km
  ix = iw(km + 1)
  is = iw(kn)
   30 v = cmplx(r,0.0)
!
!  function values of f are stored ready permutated for the fft.
!
  do 40 i = is,32,is
    iq = ip(i)
    v = v*fv(km)
    a(iq) = f(z + v)
   40   a(iq - 1) = f(z - v)
  ln = 2
  jn = 1
!
!  the loop  do 70 ... constitutes the fft.
!
  do 70 l = 1,km
    u = (1.,0.)
    w = fv(l)
    do 60 j = 1,jn
      do 50 i = j,ix,ln
        it = i + jn
        t = a(it)*u
        a(it) = a(i) - t
   50       a(i) = a(i) + t
   60     u = u*w
    ln = ln + ln
   70   jn = jn + jn
  cx = 0.0
  b = 1.0
!
!  test on how fast the coefficients obtained decrease.
!
  do 80 i = 1,ix
    ct = cabs(a(i))/b
    if (ct < cx) go to 80
    cx = ct
    inr = i
   80   b = b*c(kl)
  if (m <= 1) go to 100
!
!  estimate of the rounding error level for the last radius.
!
  err(1) = cx*eps
  do 90 i = 2,n
   90   err(i) = err(i-1)/r
  100 sf = sc(kl)
  do 110 i = 1,ix
    a(i) = mult(sf,a(i))
  110   sf = sf/r
  l1 = l2
  l2 = 1
  if (inr > iw(km)) go to 150
  if (lf == 1) go to 140
!
!  test if the series is a taylor or a laurent series.
!
  sr = 0.0
  sp = 0.0
  do 130 j = 1,3
    rq = mult(r,rv(j))
    s = a(ix)
    do 120 i = 2,ix
      ia = ix + 1 - i
  120     s = s*rq + a(ia)
    cp = cabs(s)
    if (cp > sp) sp = cp
    cm = cabs(s - f(z + rq))
  130   if (cm > sr) sr = cm
  if (sr > 1.e-3*sp) go to 150
  lf = 1
  140 l2 = -1
!
!  determination of the next radius to be used.
!
  150 if (nr >= 0) go to 160
    fact = 2.0
    if (l2 == 1) fact = 0.5
    l1 = l2
    nr = 0
  160 if (l1 /= l2) go to 180
    if (nr > 0) go to 170
      np = np + 1
      if (np-15) 190,190,260
  170   fact = 1.0/fact
  180 fact = 1.0/sqrt(fact)
  nr = nr + 1
  190 r = r*fact
  m = nr - kl - 1
  if (m <= 0) go to 30
!
!  the results for the last three radii are stored.
!
  do 200 i = 1,n
  200   rt(i,m) = a(i)
  if (m == 1) go to 220
!
!  extrapolation.
!
  do 210 i = 1,n
    xk = rt(i,m-1) - rt(i,m)
  210   rt(i,m-1) = rt(i,m) - mult(fc(m-1),xk)
  if (m == 3) go to 230
!
!  calculation of the extrapolation constants.
!
  220 fc(m) = 1.5 + sign(.5,fact-1.)
  if (m == 2) fc(m) = fc(m) + ra
  if (fact > 1.0) fc(m) = -fc(m)
  go to 30
  230 fc(3) = fc(1)*fc(2)/(fc(1) + fc(2) + 1.0)
!
!  final extrapolation and error estimate.
!
  do 240 i = 1,n
    xk = rt(i,1) - rt(i,2)
    err(i) = err(i) + ep6*cabs(xk)
  240   rs(i) = rt(i,2) - mult(fc(3),xk)
!
!  multiply power series coefficients and error estimate by factorials
!  if derivatives wanted.
!
  if (ic == 0) return
  fac = 0.0
  fact = 1.0
  do 250 i = 1,n
    rs(i) = mult(fact,rs(i))
    err(i) = fact*err(i)
    fac = fac + 1.0
  250   fact = fact*fac
  return
!
!  error return.
!
  260 do 270 i = 1,n
    rs(i) = (0.,0.)
  270   err(i) = 1.e10
  return
end
subroutine cpsi (z, w)
!
!*******************************************************************************
!
!! CPSI: evaluation of the complex digamma function
!
  integer imax
  complex z, w
  complex eta, eta2, sum
  real c0(12)
  double precision ds1, ds2
!-------
!     pi2 = 2*pi
!-------
  data pi/3.14159265358979324/
  data pi2/6.28318530717958648/
!-------
  data c0(1) /.833333333333333e-01/, c0(2) /-.833333333333333e-02/, &
       c0(3) /.396825396825397e-02/, c0(4) /-.416666666666667e-02/, &
       c0(5) /.757575757575758e-02/, c0(6) /-.210927960927961e-01/, &
       c0(7) /.833333333333333e-01/, c0(8) /-.443259803921569e+00/, &
       c0(9) /.305395433027012e+01/, c0(10)/-.264562121212121e+02/, &
       c0(11)/.281460144927536e+03/, c0(12)/-.360751054639805e+04/
!
  imax = huge ( imax )
  eps = epsilon ( eps )
  x = real(z)
  y = aimag(z)
  if (x >= 0.0) go to 40
!
!            case when the real part of z is negative
!
  y = abs(y)
  t = -pi2*y
  et = exp(t)
!
!     set  a1 = (1 + et)/2  and  a2 = (1 - et)/2
!
  a1 = 0.5*(1.0 + et)
  if (t < -0.15) go to 10
     a2 = -0.5*rexp(t)
     go to 20
   10 a2 = 0.5*(0.5 + (0.5 - et))
!
!     compute sin(pi*x) and cos(pi*x), or -sin(pi*x) and -cos(pi*x)
!
   20 if (abs(x) >= amin1(real(imax), 1.0/eps)) go to 100
  k = abs(x)
  u = x + k
  if (u <= -0.5) u = 0.5 + (0.5 + u)
  u = pi*u
  sn = sin(u)
  cn = cos(u)
!
!     set h1 + h2*i = pi*cot(pi*z)
!
  s1 = a1*sn
  s2 = a2*cn
  c1 = a1*cn
  c2 = -a2*sn
  s = s1*s1 + s2*s2
  h1 = pi*(s1*c1 + s2*c2)/s
  h2 = pi*(s1*c2 - s2*c1)/s
!
  if (aimag(z) < 0.0) go to 30
     x = 1.0 - x
     y = -y
     go to 40
   30 h2 = -h2
  x = 1.0 - x
!
!           case when the real part of z is nonnegative
!
   40 t = x
  y2 = y*y
  a = x*x + y2
  if (a == 0.0) go to 100
!
!     let s1 + s2*i be the sum of the terms 1/(z+j) for j = 0,1,...,n-1
!
  ds1 = 0.d0
  ds2 = 0.d0
   50    if (a >= 36.0) go to 51
     ds1 = ds1 + dble(t/a)
     ds2 = ds2 - dble(y/a)
     t = t + 1.0
     a = t*t + y2
     go to 50
   51 s1 = ds1
  s2 = ds2
!
!     set w1 + w2*i = log(z+n)
!
  w1 = 0.5*alog(a)
  w2 = atan2(y,t)
!
!     let a1 + a2*i be the asymptotic sum
!
  eta = cmplx(t/a,-y/a)
  eta2 = eta*eta
  m = 12
  l = m
  sum = cmplx(c0(m),0.0)
  do 60 j = 2,m
     l = l - 1
     sum = cmplx(c0(l),0.0) + sum*eta2
   60 continue
  sum = cmplx(0.5,0.0)*eta + eta2*sum
  a1 = real(sum)
  a2 = aimag(sum)
!
!                 gathering together the results
!
  w1 = (w1 - s1) - a1
  w2 = (w2 - a2) - s2
  w  = cmplx(w1,w2)
  if (real(z) >= 0.0) return
  w = cmplx(w1 - h1, w2 - h2)
  return
!
!             the requested value cannot be computed
!
  100 w = (0.0, 0.0)
  return
end
subroutine cqext(n,epstab,result,abserr,res3la,nres)
!
!*******************************************************************************
!
!! CQEXT: epsilon algorithm
!              standard fortran subroutine
!              complex version
!
! 2.        purpose
!              the routine determines the limit of a given sequence of
!              approximations, by means of the epsilon algorithm
!              of p. wynn.
!              an estimate of the absolute error is also given.
!              the condensed epsilon table is computed. only those
!              elements needed for the computation of the next diagonal
!              are preserved.
!
! 3.        calling sequence
!              call cqext(n,epstab,result,abserr,res3la,nres)
!
!           parameters
!              n      - integer
!                       epstab(n) contains the new element in the
!                       first column of the epsilon table.
!
!              epstab - complex
!                       vector of dimension 52 containing the elements
!                       of the two lower diagonals of the
!                       triangular epsilon table
!                       the elements are numbered starting at the
!                       right-hand corner of the triangle.
!
!              result - complex
!                       resulting approximation to the integral
!
!              abserr - real
!                       estimate of the absolute error of the real
!                       part of result computed from result and
!                       the 3 previous results
!
!              res3la - complex
!                       vector of dimension 3 containing the last 3
!                       results
!
!              nres   - integer
!                       number of calls to the routine
!                       (should be zero at first call)
!
  complex delta1,delta2,delta3, &
    epstab,e0,e1,e2,e3, &
    res,result,res3la,ss
  double precision r,s,u1,u2,u3,v1,v2,v3,ss1,ss2,w1,w2
  integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num
  dimension epstab(52),res3la(3)
!
!           list of major variables
!           -----------------------
!
!           e0     - the 4 elements on which the
!           e1       computation of a new element in
!           e2       the epsilon table is based
!           e3                 e0
!                        e3    e1    new
!                              e2
!           newelm - number of elements to be computed in the new
!                    diagonal
!           error  - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
!           result - the element in the new diagonal with least value
!                    of error
!
!           machine dependent constants
!           ---------------------------
!
!           epmach is the largest relative spacing.
!           oflow is the largest positive magnitude.
!           limexp is the maximum number of elements the epsilon
!           table can contain. if this number is reached, the upper
!           diagonal of the epsilon table is deleted.
!
  oflow = huge ( oflow )
  epmach = epsilon ( epmach )
  nres = nres+1
  abserr = oflow
  result = epstab(n)
  if(n < 3) go to 100
  limexp = 50
  epstab(n+2) = epstab(n)
  newelm = (n-1)/2
  epstab(n) = cmplx(oflow,0.0)
  num = n
  k1 = n
  do 40 i = 1,newelm
    k2 = k1-1
    k3 = k1-2
    res = epstab(k1+2)
    e0 = epstab(k3)
    e1 = epstab(k2)
    e2 = res
    e1abs = cabs(e1)
    a1 = real(e0)
    a2 = aimag(e0)
    b1 = real(e1)
    b2 = aimag(e1)
    c1 = real(e2)
    c2 = aimag(e2)
    err2 = abs(c1 - b1)
    err3 = abs(b1 - a1)
    if(abs(a1-b1) > epmach*max ( abs(a1),abs(b1)) .or. &
       abs(a2-b2) > epmach*max ( abs(a2),abs(b2))) go to 10
    if(abs(b1-c1) > epmach*max ( abs(b1),abs(c1)) .or. &
       abs(b2-c2) > epmach*max ( abs(b2),abs(c2))) go to 10
!
!           if e0, e1 and e2 are equal to within machine
!           accuracy, convergence is assumed.
!           result = e2
!           abserr = cabs(e1-e0)+cabs(e2-e1)
!
    result = res
    abserr = err2+err3
!***jump out of do-loop
    go to 100
   10   e3 = epstab(k1)
    epstab(k1) = e1
    d1 = real(e3)
    d2 = aimag(e3)
    err1 = abs(b1 - d1)
!
!           if two elements are very close to each other, omit
!           a part of the table by adjusting the value of n
!
    delta1 = e1 - e3
    delta2 = e2 - e1
    delta3 = e1 - e0
    if(cabs(delta1) <= epmach*max ( e1abs,cabs(e3))) go to 20
    if(cabs(delta2) <= epmach*max ( e1abs,cabs(e2))) go to 20
    if(cabs(delta3) <= epmach*max ( cabs(e0),e1abs)) go to 20
    r = real(delta1)
    s = aimag(delta1)
    call cdivid(1.d0,0.d0,r,s,u1,v1)
    r = real(delta2)
    s = aimag(delta2)
    call cdivid(1.d0,0.d0,r,s,u2,v2)
    r = real(delta3)
    s = aimag(delta3)
    call cdivid(1.d0,0.d0,r,s,u3,v3)
    ss1 = u1 + u2 - u3
    ss2 = v1 + v2 - v3
    ss = cmplx(sngl(ss1), sngl(ss2))
    epsinf = cabs(ss*e1)
!
!           test to detect irregular behaviour in the table, and
!           eventually omit a part of the table adjusting the value
!           of n.
!
    if(epsinf > 1.0e-04) go to 30
   20   n = i+i-1
!***jump out of do-loop
    go to 50
!
!           compute a new element and eventually adjust
!           the value of result.
!
   30   call cdivid(1.d0,0.d0,ss1,ss2,w1,w2)
    res1 = real(e1) + sngl(w1)
    res2 = aimag(e1) + sngl(w2)
    res = cmplx(res1,res2)
    epstab(k1) = res
    k1 = k1-2
    error = err2+abs(c1-real(res))+err3
    if(error > abserr) go to 40
    abserr = error
    result = res
   40 continue
!
!           shift the table.
!
   50 if(n == limexp) n = 2*(limexp/2)-1
  ib = 1
  if((num/2)*2 == num) ib = 2
  ie = newelm+1
  do 60 i=1,ie
    ib2 = ib+2
    epstab(ib) = epstab(ib2)
    ib = ib2
   60 continue
  if(num == n) go to 80
  indx = num-n+1
  do 70 i = 1,n
    epstab(i)= epstab(indx)
    indx = indx+1
   70 continue
   80 if(nres >= 4) go to 90
  res3la(nres) = result
  abserr = oflow
  go to 100
!
!           compute error estimate
!
   90 abserr = abs(real(result-res3la(3)))+abs(real(result-res3la(2))) &
    +abs(real(result-res3la(1)))
  res3la(1) = res3la(2)
  res3la(2) = res3la(3)
  res3la(3) = result
  100 abserr = max ( abserr,5.0e+00*epmach*abs(real(result)))
  return
end
subroutine cqzhes(nm, n, a, b, mats, z, f, g, h)
!
!*******************************************************************************
!
!! CQZHES is a modification of the eispack subroutine
!     qzhes.  all operations are performed in complex arithmetic,
!     and the left transformations may also be applied to auxiliary
!     matrices f, g and h.
!
!
!     on entry,
!
!     nm   is the leading dimension of the matrices a and b in
!          the main program.
!
!     n    is the order of the matrices a and b.
!
!     a    contains the matrix to be reduced to upper hessenberg
!          form.
!
!     b    contains the matrix to be reduced to upper traingular
!          form.
!
!     mats is an integer input variable.
!
!          if mats = 0, the accumulation of the transformations
!             is not desired.
!
!          if mats = any other number but 0, the transformations
!             are accumulated.
!
!          if mats = 1, the auxiliary matrices g and h are updated
!             with the unitary matrix q.
!
!          if mats = 2, matrix b is assumed upper triangular.
!
!          if mats = 3, the auxiliary matrix f is not updated
!             with the unitary matrix q.
!
!     f, g and h are auxiliary matrices.
!
!
!     on return,
!
!     a    is upper hessenberg.
!
!     b    is upper triangular.
!
!     z    contains the history of the transformations, if desired.
!
!     f, g and h are updated, if desired.
!
!
  integer i, j, k, l, n, lb, l1, nm, nk1, nm1, nm2
  complex a(nm,n), b(nm,n), z(nm,n)
  complex rr, t, u1, u2, v1, v2, rho
  complex f(nm,n), tf, g(nm,n), tg, h(nm,n), th
  real r, s
  integer mats
!     real sqrt, cabs
!     complex cmplx, conjg
  if (mats == 0) go to 30
  do 20 i=1,n
    do 10 j=1,n
      z(i,j) = cmplx(0.0,0.0)
   10   continue
    z(i,i) = cmplx(1.0,0.0)
   20 continue
!     ********** reduce b to upper triangular form **********
   30 if (n <= 1) go to 260
  nm1 = n - 1
  if (mats == 2) go to 140
  do 130 l=1,nm1
    l1 = l + 1
    s = 0.0
    do 40 i=l1,n
      s = s + cabs(b(i,l))
   40   continue
    if (s == 0.0) go to 130
    s = s + cabs(b(l,l))
    r = 0.0
    do 50 i=l,n
      b(i,l) = b(i,l)/cmplx(s,0.0)
      r = r + cabs(b(i,l))**2
   50   continue
    r = sqrt(r)
    rr = cmplx(r,0.0)
    if (cabs(b(l,l))/=0.0) rr = (b(l,l)/cabs(b(l,l)))*rr
    b(l,l) = b(l,l) + rr
    rho = conjg(rr)*b(l,l)
    do 80 j=l1,n
      t = cmplx(0.0,0.0)
      do 60 i=l,n
        t = t + conjg(b(i,l))*b(i,j)
   60     continue
      t = -t/rho
      do 70 i=l,n
        b(i,j) = b(i,j) + t*b(i,l)
   70     continue
   80   continue
    do 110 j=1,n
      t = cmplx(0.0,0.0)
      tf = cmplx(0.0,0.0)
      tg = cmplx(0.0,0.0)
      th = cmplx(0.0,0.0)
      do 90 i=l,n
        t = t + conjg(b(i,l))*a(i,j)
        if (mats == 3) go to 90
        tf = tf + conjg(b(i,l))*f(i,j)
        if (mats/=1) go to 90
        tg = tg + conjg(b(i,l))*g(i,j)
        th = th + conjg(b(i,l))*h(i,j)
   90     continue
      t = -t/rho
      tf = -tf/rho
      tg = -tg/rho
      th = -th/rho
      do 100 i=l,n
        a(i,j) = a(i,j) + t*b(i,l)
        if (mats == 3) go to 100
        f(i,j) = f(i,j) + tf*b(i,l)
        if (mats/=1) go to 100
        g(i,j) = g(i,j) + tg*b(i,l)
        h(i,j) = h(i,j) + th*b(i,l)
  100     continue
  110   continue
    b(l,l) = -cmplx(s,0.0)*rr
    do 120 i=l1,n
      b(i,l) = cmplx(0.0,0.0)
  120   continue
  130 continue
!     ********** reduce a to upper hessenberg form, while
!                keeping b triangular **********
  140 if (n == 2) go to 260
  nm2 = n - 2
  do 250 k=1,nm2
    nk1 = nm1 - k
    do 240 lb=1,nk1
      l = n - lb
      l1 = l + 1
!     ********** zero a(l+1,k).
!
      s = cabs(a(l,k)) + cabs(a(l1,k))
      if (s == 0.0) go to 240
      u1 = a(l,k)/cmplx(s,0.0)
      u2 = a(l1,k)/cmplx(s,0.0)
      r = sqrt(cabs(u1)**2+cabs(u2)**2)
      rr = cmplx(r,0.0)
      if (cabs(u1)/=0.0) rr = (u1/cabs(u1))*rr
      v1 = -(u1+rr)/rr
      v2 = -u2/rr
      u2 = v2/v1
      do 150 j=k,n
        t = a(l,j) + conjg(u2)*a(l1,j)
        a(l,j) = a(l,j) + t*v1
        a(l1,j) = a(l1,j) + t*v2
  150     continue
      a(l1,k) = cmplx(0.0,0.0)
      do 160 j=l,n
        t = b(l,j) + conjg(u2)*b(l1,j)
        b(l,j) = b(l,j) + t*v1
        b(l1,j) = b(l1,j) + t*v2
  160     continue
      if (mats == 3) go to 180
      do 170 j=1,n
        tf = f(l,j) + conjg(u2)*f(l1,j)
        f(l,j) = f(l,j) + tf*v1
        f(l1,j) = f(l1,j) + tf*v2
  170     continue
  180     if (mats/=1) go to 200
      do 190 j=1,n
        tg = g(l,j) + conjg(u2) + g(l1,j)
        th = h(l,j) + conjg(u2) + h(l1,j)
        g(l,j) = g(l,j) + tg*v1
        h(l,j) = h(l,j) + th*v1
        g(l1,j) = g(l1,j) + tg*v2
        h(l1,j) = h(l1,j) + th*v2
  190     continue
!     ********** zero b(l+1,l) **********
  200     s = cabs(b(l1,l1)) + cabs(b(l1,l))
      if (s == 0.0) go to 240
      u1 = b(l1,l1)/cmplx(s,0.0)
      u2 = b(l1,l)/cmplx(s,0.0)
      r = sqrt(cabs(u1)**2+cabs(u2)**2)
      rr = cmplx(r,0.0)
      if (cabs(u1)/=0.0) rr = (u1/cabs(u1))*rr
      v1 = -(u1+rr)/rr
      v2 = -u2/rr
      u2 = v2/v1
      do 210 i=1,l1
        t = b(i,l1) + conjg(u2)*b(i,l)
        b(i,l1) = b(i,l1) + t*v1
        b(i,l) = b(i,l) + t*v2
  210     continue
      b(l1,l) = cmplx(0.0,0.0)
      do 220 i=1,n
        t = a(i,l1) + conjg(u2)*a(i,l)
        a(i,l1) = a(i,l1) + t*v1
        a(i,l) = a(i,l) + t*v2
  220     continue
      if (mats == 0) go to 240
      do 230 i=1,n
        t = z(i,l1) + conjg(u2)*z(i,l)
        z(i,l1) = z(i,l1) + t*v1
        z(i,l) = z(i,l) + t*v2
  230     continue
  240   continue
  250 continue
  260 return
end
subroutine cqzit(nm, n, a, b, eps1, mats, z, f, ierr)
!
!*******************************************************************************
!
!! CQZIT is a modification of the eispack subroutine qzit.  
!
!
!  all operations are performed in complex arithmetic,
!     and the left transformations may also be applied to an auxiliary
!     matrix f.
!
!
!     on entry,
!
!     nm   is the leading dimension of the matrices a and b in
!          the main program.
!
!     n    is the order of the matrices a and b.
!
!     a    contains an upper hessenberg matrix from cqzhes.
!
!     b    contains an upper triangular matrix from cqzhes.
!
!     eps1 is a real number defining the tolerance used to determine
!          negligible elements of a and b in the course of the alg-
!          orithm.  an element of either matrix will be considered
!          negligible and reset to zero if it is not larger than the
!          product of eps1 and the norm of the matrix.  if eps1 <= 0,
!          relative machine precision will be computed and
!          used instead.
!
!     mats is an integer input variable.  it is set prior
!          to the call to cqzhes.
!
!     f    contains an auxiliary matrix.
!
!
!     on return,
!
!     a    is upper triangular.
!
!     b    is upper triangular.
!
!     z    contains the history of the transformations, if desired.
!
!     f    contains the auxiliary matrix, updated if desired.
!
!     ierr is an integer error return which indicates failure
!          of the qz algorithm to reduce a subdiagonal element
!          to zero after 50 iterations.
!
  integer i, j, k, l, n, en, jj, k1, k2, ld, ll, l1, na, nm, ish, &
   its, km1, lm1
  integer enm2, ierr, lor1, enorn
  complex a(nm,n), b(nm,n), z(nm,n)
  complex a11, a21, a33, a34, a43, a44, b11, b22, b33, b34, b44
  complex a1, a2, u1, u2, v1, v2, t, rr, sh, ss
  complex f(nm,n), tf
  real eps1, epsa, epsb, anorm, bnorm, ani, bni, srelpr, r, s
  integer mats
!     integer max0, min0
!     real sqrt, cabs
!     complex cmplx, conjg, csqrt
  ierr = 0
!     ********** compute epsa, epsb.
  anorm = 0.0
  bnorm = 0.0
  do 20 i=1,n
    ani = 0.0
    if (i/=1) ani = cabs(a(i,i-1))
    bni = 0.0
    do 10 j=i,n
      ani = ani + cabs(a(i,j))
      bni = bni + cabs(b(i,j))
   10   continue
    if (ani > anorm) anorm = ani
    if (bni > bnorm) bnorm = bni
   20 continue
  if (anorm == 0.0) anorm = 1.0
  if (bnorm == 0.0) bnorm = 1.0
  srelpr = eps1
  if (srelpr > 0.0) go to 40
!
!     ***** when eps1 = 0 then set srelpr to be the smallest
!           number for which 1 + srelpr > 1 *****
!
  srelpr = epsilon ( srelpr )
!
   40 epsa = srelpr*anorm
  epsb = srelpr*bnorm
!     ********** reduce a to triangular form, while
!                keeping b triangular **********
  lor1 = 1
  enorn = n
  en = n
!     ********** begin qz step **********
   50 if (en <= 1) go to 220
  if (mats == 0) enorn = en
  its = 0
  na = en - 1
  enm2 = na - 1
   60 ish = 1
!     ********** check for convergence or reducibility **********
  do 70 ll=1,en
    lm1 = en - ll
    l = lm1 + 1
    if (l == 1) go to 90
    if (cabs(a(l,lm1)) <= epsa) go to 80
   70 continue
   80 a(l,lm1) = cmplx(0.0,0.0)
  if (l < na) go to 90
!     ********** 1-by-1 block isolated **********
  en = lm1
  go to 50
!     ********** check for small top of b **********
   90 ld = l
  l1 = l + 1
  b11 = b(l,l)
  if (cabs(b11) > epsb) go to 120
  b(l,l) = cmplx(0.0,0.0)
  s = cabs(a(l,l)) + cabs(a(l1,l))
  u1 = a(l,l)/cmplx(s,0.0)
  u2 = a(l1,l)/cmplx(s,0.0)
  r = sqrt(cabs(u1)**2+cabs(u2)**2)
  rr = cmplx(r,0.0)
  if (cabs(u1)/=0.0) rr = (u1/cabs(u1))*rr
  v1 = -(u1+rr)/rr
  v2 = -u2/rr
  u2 = v2/v1
  do 110 j=l,enorn
    t = a(l,j) + conjg(u2)*a(l1,j)
    a(l,j) = a(l,j) + t*v1
    a(l1,j) = a(l1,j) + t*v2
    t = b(l,j) + conjg(u2)*b(l1,j)
    b(l,j) = b(l,j) + t*v1
    b(l1,j) = b(l1,j) + t*v2
    if (mats == 3) go to 110
    do 100 jj=1,n
      tf = f(l,jj) + conjg(u2)*f(l1,jj)
      f(l,jj) = f(l,jj) + tf*v1
      f(l1,jj) = f(l1,jj) + tf*v2
  100   continue
  110 continue
  if (l/=1) a(l,lm1) = -a(l,lm1)
  lm1 = l
  l = l1
  go to 80
  120 a11 = a(l,l)/b11
  a21 = a(l1,l)/b11
!     ********** iteration strategy **********
  if (its == 50) go to 210
!     ********** determine shift **********
  b22 = b(l1,l1)
  if (cabs(b22) < epsb) b22 = cmplx(epsb,0.0)
  b33 = b(na,na)
  if (cabs(b33) < epsb) b33 = cmplx(epsb,0.0)
  b44 = b(en,en)
  if (cabs(b44) < epsb) b44 = cmplx(epsb,0.0)
  a33 = a(na,na)/b33
  a34 = a(na,en)/b44
  a43 = a(en,na)/b33
  a44 = a(en,en)/b44
  b34 = b(na,en)/b44
  t = cmplx(0.5,0.0)*(a43*b34-a33-a44)
  rr = t*t + a34*a43 - a33*a44
!     ********** determine single shift zeroth column of a **********
  rr = csqrt(rr)
  sh = -t + rr
  ss = -t - rr
  if (cabs(ss-a44) < cabs(sh-a44)) sh = ss
  a1 = a11 - sh
  a2 = a21
  if (l/=ld) a(l,lm1) = -a(l,lm1)
  if (its/=10) go to 130
  a1 = cmplx(1.0,0.0)
  a2 = cmplx(1.1605,0.0)
  130 its = its + 1
  if (mats == 0) lor1 = ld
!     ********** main loop **********
  do 200 k=l,na
    k1 = k + 1
    k2 = k + 2
    km1 = max (k-1,l)
    ll = min (en,k1+ish)
!     ********** zero a(k+1,k-1) **********
    if (k == l) go to 140
    a1 = a(k,km1)
    a2 = a(k1,km1)
  140   s = cabs(a1) + cabs(a2)
    if (s == 0.0) go to 60
    u1 = a1/cmplx(s,0.0)
    u2 = a2/cmplx(s,0.0)
    r = sqrt(cabs(u1)**2+cabs(u2)**2)
    rr = cmplx(r,0.0)
    if (cabs(u1)/=0.0) rr = (u1/cabs(u1))*rr
    v1 = -(u1+rr)/rr
    v2 = -u2/rr
    u2 = v2/v1
    do 150 j=km1,enorn
      t = a(k,j) + conjg(u2)*a(k1,j)
      a(k,j) = a(k,j) + t*v1
      a(k1,j) = a(k1,j) + t*v2
      t = b(k,j) + conjg(u2)*b(k1,j)
      b(k,j) = b(k,j) + t*v1
      b(k1,j) = b(k1,j) + t*v2
  150   continue
    if (k/=l) a(k1,km1) = cmplx(0.0,0.0)
    if (mats == 3) go to 170
    do 160 j=1,n
      tf = f(k,j) + conjg(u2)*f(k1,j)
      f(k,j) = f(k,j) + tf*v1
      f(k1,j) = f(k1,j) + tf*v2
  160   continue
!     ********** zero b(k+1,k) **********
  170   s = cabs(b(k1,k1)) + cabs(b(k1,k))
    if (s == 0.0) go to 200
    u1 = b(k1,k1)/cmplx(s,0.0)
    u2 = b(k1,k)/cmplx(s,0.0)
    r = sqrt(cabs(u1)**2+cabs(u2)**2)
    rr = cmplx(r,0.0)
    if (cabs(u1)/=0.0) rr = (u1/cabs(u1))*rr
    v1 = -(u1+rr)/rr
    v2 = -u2/rr
    u2 = v2/v1
    do 180 i=lor1,ll
      t = a(i,k1) + conjg(u2)*a(i,k)
      a(i,k1) = a(i,k1) + t*v1
      a(i,k) = a(i,k) + t*v2
      t = b(i,k1) + conjg(u2)*b(i,k)
      b(i,k1) = b(i,k1) + t*v1
      b(i,k) = b(i,k) + t*v2
  180   continue
    b(k1,k) = cmplx(0.0,0.0)
    if (mats == 0) go to 200
    do 190 i=1,n
      t = z(i,k1) + conjg(u2)*z(i,k)
      z(i,k1) = z(i,k1) + t*v1
      z(i,k) = z(i,k) + t*v2
  190   continue
  200 continue
!     ********** end qz step **********
  go to 60
!     ********** set error -- neither bottom subdiagonal element
!                has become negligible after 50 iterations **********
  210 ierr = en
!     ********** save epsb for use by cqzvec **********
  220 if (n > 1) b(n,1) = cmplx(epsb,0.0)
  return
end
subroutine crec (x, y, u, v)
!
!*******************************************************************************
!
!! CREC: complex reciprocal u + i*v = 1/(x + i*y)
!
  if (abs(x) > abs(y)) go to 10
     t = x/y
     d = y + t*x
     u = t/d
     v = -1.0/d
     return
   10 t = y/x
  d = x + t*y
  u = 1.0/d
  v = -t/d
  return
end
subroutine crout(mo,n,m,a,ka,b,kb,d,index,temp)
!
!*******************************************************************************
!
!! CROUT: procedure for inverting matrices and solving equations
!
!     a is a matrix of order n where n is greater than or equal to 1.
!     if mo=0 then the inverse of a is computed and stored in a. if mo
!     is not 0 then the inverse is not computed.
!
!     if m is greater than 0 then b is a matrix having n rows and m
!     columns. in this case ax=b is solved and the solution x is stored
!     in b. if m=0 then there are no equations to be solved.
!
!     ka = the length of the columns of the array a
!     kb = the length of the columns of the array b (if m > 0)
!
!     the determinant d of a is always computed. if d=0 then the
!     routine immediately terminates.
!
!     index is an array of dimension n-1 or larger that is used by the
!     routine for keeping track of the row interchanges that are made.
!     if mo is not 0 then this array is not needed.
!
!     temp is an array of dimension n or larger that is used when a
!     is inverted. if mo is not 0 then this array is not needed.
!
  dimension a(ka,n), b(*), index(*), temp(*)
  integer onej
  double precision dsum
!
  if (n < 2) go to 200
  d = 1.0
  nm1 = n - 1
  do 70 k = 1,nm1
     kp1 = k + 1
!
!               search for the k-th pivot element
!
     p = abs(a(k,k))
     l = k
     do 10 i = kp1,n
        t = abs(a(i,k))
        if (p >= t) go to 10
        p = t
        l = i
   10    continue
!
     p = a(l,k)
     d = p*d
     if (d == 0.0) return
     if (mo == 0) index(k) = l
     if (k == l) go to 40
     d = -d
!
!                  interchanging rows k and l
!
     do 20 j = 1,n
        t = a(k,j)
        a(k,j) = a(l,j)
   20       a(l,j) = t
!
     if (m <= 0) go to 40
     kj = k
     lj = l
     do 30 j = 1,m
        t = b(kj)
        b(kj) = b(lj)
        b(lj) = t
        kj = kj + kb
   30       lj = lj + kb
!
!                  compute the k-th row of u
!
   40    if (k > 1) go to 50
        do 41 j = kp1,n
   41          a(k,j) = a(k,j)/p
        go to 60
!
   50    do 52 j = kp1,n
        dsum = a(k,j)
        do 51 l = 1,km1
   51          dsum = dsum - dble(a(k,l))*dble(a(l,j))
        a(k,j) = sngl(dsum)/p
   52    continue
!
!               compute the (k+1)-st column of l
!
   60    do 62 i = kp1,n
        dsum = a(i,kp1)
        do 61 l = 1,k
   61          dsum = dsum - dble(a(i,l))*dble(a(l,kp1))
        a(i,kp1) = dsum
   62    continue
!
     km1 = k
   70 continue
!
!                 check the n-th pivot element
!
  d = a(n,n)*d
  if (d == 0.0) return
!
!                 solving the equation ly = b
!
  if (m <= 0) go to 120
  maxb = kb*m
  do 102 onej = 1,maxb,kb
     kj = onej
     b(kj) = b(kj)/a(1,1)
     do 101 k = 2,n
        kj = kj + 1
        dsum = b(kj)
        km1 = k - 1
        lj = onej
        do 100 l = 1,km1
           dsum = dsum - dble(a(k,l))*dble(b(lj))
  100          lj = lj + 1
  101       b(kj) = sngl(dsum)/a(k,k)
  102 continue
!
!                 solving the equation ux = y
!
  do 112 nj = n,maxb,kb
     kj = nj
     do 111 nmk = 1,nm1
        k = n - nmk
        lj = kj
        kj = kj - 1
        dsum = b(kj)
        kp1 = k + 1
        do 110 l = kp1,n
           dsum = dsum - dble(a(k,l))*dble(b(lj))
  110          lj = lj + 1
        b(kj) = dsum
  111    continue
  112 continue
!
!               replace l with the inverse of l
!
  120 if (mo /= 0) return
  do 132 j = 1,nm1
     a(j,j) = 1.0/a(j,j)
     jp1 = j + 1
     do 131 i = jp1,n
        dsum = 0.d0
        im1 = i - 1
        do 130 l = j,im1
  130          dsum = dsum + dble(a(i,l))*dble(a(l,j))
  131       a(i,j) = -sngl(dsum)/a(i,i)
  132 continue
  a(n,n) = 1.0/a(n,n)
!
!           solve ux = y where y is the inverse of l
!
  do 152 nmk = 1,nm1
     k = n - nmk
     kp1 = k + 1
     do 140 j = kp1,n
        temp(j) = a(k,j)
  140       a(k,j) = 0.0
!
     do 151 j = 1,n
        dsum = a(k,j)
        do 150 l = kp1,n
  150          dsum = dsum - dble(temp(l))*dble(a(l,j))
        a(k,j) = dsum
  151    continue
  152 continue
!
!                    column interchanges
!
  do 161 nmj = 1,nm1
     j = n - nmj
     k = index(j)
     if (j == k) go to 161
     do 160 i = 1,n
        t = a(i,j)
        a(i,j) = a(i,k)
  160       a(i,k) = t
  161 continue
  return
!
!                      case when n = 1
!
  200 d = a(1,1)
  if (d == 0.0) return
  if (mo == 0) a(1,1) = 1.0/d
!
  if (m <= 0) return
  maxb = kb*m
  do 210 kj = 1,maxb,kb
  210    b(kj) = b(kj)/d
  return
end
subroutine crout1 ( a, ka, n, iend, index, temp, jp, ierr )
!
!*******************************************************************************
!
!! CROUT1: crout procedure for inverting matrices
!
!
!     a is a matrix of order n where n is greater than or equal to 1.
!     the inverse of a is computed and stored in a.
!
!     ka = length of the columns of the array a
!     jp = the number of the column that contains the smallest pivot
!
!     iend may be 0,1,...,n-1.  it is assumed that each of the first
!     iend columns of the matrix a contains only one nonzero element
!     and that the nonzero element is 1 or -1.
!
!     index is an array of dimension n-1 or larger that is used by the
!     routine for keeping track of the row interchanges that are made.
!
!     temp is a temporary storage array.
!
!     ierr reports the status of the results. if a is nonsingular then
!     the inverse of a is computed and ierr=0. otherwise if a is found
!     to be singular then ierr=1 and the routine terminates.
!
  integer n
!
  real a(*)
  double precision dsum
  integer index(*)
  integer max2
  real temp(n)
!
  max2 = ka * n
  mcol = iend * ka

  if (iend == 0) go to 100
!
!  Process the first iend columns of a
!
  kcol = 0

  do k = 1, iend

    kk = kcol + k
    nk = kcol + n
    do 10 lk = kk,nk
      if (a(lk)) 20,10,30
10  continue
    jp = k
    go to 300

20  continue

    l = lk - kcol
    lj0 = mcol + l
    do lj = lj0, max2, ka
      a(lj) = -a(lj)
    end do

30  continue

    l = lk - kcol
    index(k) = l
    if (k == l) go to 32
    lj = lk
    do kj = kk, max2, ka
      c = a(kj)
      a(kj) = a(lj)
      a(lj) = c
      lj = lj + ka
    end do

   32 kcol = kcol + ka

  end do
!
!           process the remaining columns of a
!
  100 nm1 = n - 1
  jp = 1
  ierr = 0
  pmin = 0.0
  ibeg = iend + 1
  if (ibeg == n) go to 190
!
  k = ibeg
  km1 = iend
  kp1 = k + 1
  kcol = mcol
  kk = kcol + k
  do 172 kcount = ibeg,nm1
!
!     search for the k-th pivot element (k=ibeg,...,n-1)
!
  l = k
  s = abs(a(kk))
  do 110 i = kp1,n
  ik = kcol + i
  c = abs(a(ik))
  if (s >= c) go to 110
  l = i
  s = c
  110 continue
!
  if (k > ibeg .and. s >= pmin) go to 120
  jp = k
  pmin = s
  if (s == 0.0) go to 300
!
!              interchanging rows k and l
!
  120 index(k) = l
  if (k == l) go to 130
  kj0 = mcol + k
  lj  = mcol + l
  do 121 kj = kj0, max2, ka
  c = a(kj)
  a(kj) = a(lj)
  a(lj) = c
  121 lj = lj + ka
!
!       compute the k-th row of u (k=ibeg,...,n-1)
!
  130 c = a(kk)
  if (k > ibeg) go to 140
  kj0 = kk + ka
  do 131 kj = kj0, max2, ka
  131 a(kj) = a(kj)/c
  go to 160
!
  140 kl = mcol + k
  do 141 l = ibeg,km1
  temp(l) = a(kl)
  141 kl = kl + ka
!
  kj0 = kk + ka
  do 151 kj = kj0, max2, ka
  jcol = kj - k
  dsum = -a(kj)
    do 150 l = ibeg,km1
    lj = jcol + l
  150   dsum = dsum + dble(temp(l))*dble(a(lj))
  151 a(kj) = sngl(-dsum)/c
!
!      compute the k-th column of l (k=ibeg+1,...,n)
!
  160 km1 = k
  k = kp1
  kp1 = k + 1
  kcol = kcol + ka
  kk = kcol + k
  do 161 l = ibeg,km1
  lk = kcol + l
  161 temp(l) = a(lk)
!
  do 171 i = k,n
  il = mcol + i
  dsum = 0.d0
    do 170 l = ibeg,km1
    dsum = dsum + dble(a(il))*dble(temp(l))
  170   il = il + ka
  171 a(il) = dble(a(il)) - dsum
  172 continue
!
!  Check the n-th pivot element
!
  190 ncol = max2 - ka
  nn = ncol + n
  c = abs(a(nn))
  if (c > pmin) go to 200
  jp = n
  if (c == 0.0) go to 300
!
!          replace l with the inverse of l
!
  200 if (ibeg == n) go to 213
  jj = mcol + ibeg
  i = ka + 1
  do 212 j = ibeg,nm1
  a(jj) = 1.0/a(jj)
  temp(j) = a(jj)
  kj = jj
    do 211 km1 = j,nm1
    k = km1 + 1
    kj = kj + 1
    dsum = 0.d0
    kl = kj
      do 210 l = j,km1
      dsum = dsum + dble(a(kl)*temp(l))
  210     kl = kl + ka
    a(kj) = sngl(-dsum)/a(kl)
  211   temp(k) = a(kj)
  212 jj = jj + i
  213 a(nn) = 1.0/a(nn)
  if (n == 1) return
!
!       solve ux = y where y is the inverse of l
!
  do 242 nmk = 1,nm1
  k = n - nmk
  lmin = max (ibeg, k+1 )
  kl = (lmin-1)*ka + k
    do 230 l = lmin,n
    temp(l) = a(kl)
    a(kl) = 0.0
  230   kl = kl + ka
!
  kj0 = mcol + k
    do 241 kj = kj0, max2, ka
    dsum = -a(kj)
    lj = (kj - k) + lmin
      do 240 l = lmin,n
      dsum = dsum + dble(temp(l)*a(lj))
  240     lj = lj + 1
  241   a(kj) = -dsum
  242 continue
!
!                 column interchanges
!
  jcol = ncol - ka
  do 251 nmj = 1,nm1
  j = n - nmj
  k = index(j)
  if (j == k) go to 251
  ij = jcol
  ik = (k-1)*ka
    do 250 i = 1,n
    ij = ij + 1
    ik = ik + 1
    c = a(ij)
    a(ij) = a(ik)
  250   a(ik) = c
  251 jcol = jcol - ka
  return
!
!                    error return
!
  300 ierr = 1
  return
end
subroutine csadd (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! CSADD: addition of sparse complex matrices
!
  complex a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!----
  do 10 j = 1,n
     wk(j) = (0.0, 0.0)
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) + b(l)
        wk(j) = (0.0, 0.0)
        if (t == (0.0, 0.0)) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == (0.0, 0.0)) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = (0.0, 0.0)
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine cscal(n,ca,cx,incx)
!
!*******************************************************************************
!
!! CSCAL: scales a vector by a constant.
!     jack dongarra, linpack,  3/11/78.
!
  complex ca,cx(*)
  integer i,incx,n,nincx
!
  if(n <= 0)return
  if(incx == 1)go to 20
!
!        code for increment not equal to 1
!
  nincx = n*incx
  do 10 i = 1,nincx,incx
    cx(i) = ca*cx(i)
   10 continue
  return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
    cx(i) = ca*cx(i)
   30 continue
  return
end
subroutine cscopy (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! CSCOPY: copying a sparse complex matrix
!
  complex a(*), b(*), zero
  integer ia(*), ja(*), ib(*), jb(*)
  data zero /(0.0,0.0)/
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        if (a(ip) == zero) go to 10
        b(l) = a(ip)
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
function csevl (x, a, n)
!
!*******************************************************************************
!
!! CSEVL: evaluate the n term chebyshev series a at x.
!          only half of the first coefficient is used.
!
  real a(n)
  real csevl
!
  if (n > 1) go to 10
     csevl = 0.5 * a(1)
     return
!
   10 x2 = x + x
  s0 = a(n)
  s1 = 0.0
  do 20 i = 2,n
     s2 = s1
     s1 = s0
     k = n - i + 1
     s0 = x2*s1 - s2 + a(k)
   20 continue
  csevl = 0.5 * (s0 - s2)
  return
end
subroutine csimag (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! CSIMAG: imaginary part of a sparse complex matrix
!
  complex a(*)
  real b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        t = aimag(a(ip))
        if (t == 0.0) go to 10
        b(l) = t
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
function csint (x, y, a, b, c, n, alpha, beta)
!
!*******************************************************************************
!
!! CSINT: integrating a cubic spline
!
!
!  Parameters:
!
!     x      array of the first n abscissas (in increasing order)
!            that define the spline.
!
!     y      array of the first n ordinates that define the spline.
!
!     a,b,c  arrays that contain the coefficients of the polynomials
!            which form the spline. if i = 1,...,n  then the spline
!            has the value
!                    y(i) + a(i)*dx + b(i)*dx**2 + c(i)*dx**3
!            for x(i) <= xx <= x(i+1). here dx = xx - x(i).
!
!     n      the number of polynomials that define the spline.
!            the arrays x, y, a, b, c  must be dimensioned at
!            least n.  n must be greater than or equal to 1.
!
!     alpha  lower limit of the integral.
!
!     beta   upper limit of the integral. beta may be less than
!            or greater than alpha.
!
!
  real csint
  real x(n), y(n), a(n), b(n), c(n)
!
  csint = 0.0
  h = beta - alpha
  if (h == 0.0) return
  if (h > 0.0) go to 10
     a0 = beta
     b0 = alpha
     go to 20
   10 a0 = alpha
  b0 = beta
!
!     locate the intervals containing a0 and b0
!
   20 if (n == 1) go to 50
  if (a0 >= x(n)) go to 50
  k = intrvl (a0, x, n)
  l = intrvl (b0, x, n)
  if (b0 >= x(n)) l = n
  if (k == l) go to 51
!
!     integrate from a0 to x(k + 1)
!
  kp1 = k + 1
  h = x(kp1) - x(k)
  d = a0 - x(k)
  r = h + d
  h2 = h*h
  d2 = d*d
  s = h2 + d2
  sum = y(k) + 0.5*a(k)*r + b(k)*(s + h*d)/3.0 &
             + 0.25*c(k)*r*s
  sum = (x(kp1) - a0)*sum
!
!     integrate over the interior intervals
!
  if (kp1 == l) go to 40
  lm1 = l - 1
  do 30 i = kp1,lm1
     h = x(i + 1) - x(i)
     s = (((0.25*c(i)*h + b(i)/3.0)*h + 0.5*a(i))*h + y(i))*h
     sum = sum + s
   30 continue
!
!     integrate from x(l) to b0
!
   40 h = b0 - x(l)
  s = (((0.25*c(l)*h + b(l)/3.0)*h + 0.5*a(l))*h + y(l))*h
  csint = sum + s
  if (alpha > beta) csint = -csint
  return
!
!     case when a0 and b0 are in the same interval
!
   50 k = n
   51 h = b0 - x(k)
  d = a0 - x(k)
  r = h + d
  h2 = h*h
  d2 = d*d
  s = h2 + d2
  sum = y(k) + 0.5*a(k)*r + b(k)*(s + h*d)/3.0 &
             + 0.25*c(k)*r*s
  csint = (beta - alpha)*sum
  return
end
function csint1 (x, y, yp, n, a, b)
!
!*******************************************************************************
!
!! CSINT1: integrating a cubic spline
!
!
!  Parameters:
!
!     x    array of the first n abscissas (in increasing order)
!          that define the spline.
!
!     y    array of the first n ordinates that define the spline.
!
!     yp   array of the first derivatives that define the spline.
!
!     n    the number of knots of the spline. the arrays x, y,
!          and yp must have dimension at least n where n >= 2.
!
!     a    lower limit of the integral.
!
!     b    upper limit of the integral. b may be less than
!          or greater than a.
!
  real csint1
  real x(n), y(n), yp(n)
!
  csint1 = 0.0
  h = b - a
  if (h == 0.0) return
  if (h > 0.0) go to 10
     a0 = b
     b0 = a
     go to 20
   10 a0 = a
  b0 = b
!
!     locate the intervals containing a0 and b0
!
   20 k = intrvl (a0, x, n)
  l = intrvl (b0, x, n)
  if (k == l) go to 51
!
!     integrate from a0 to x(k + 1)
!
  kp1 = k + 1
  h = x(kp1) - x(k)
  d = (y(kp1) - y(k))/h
  r = yp(k) + yp(kp1)
  bi = (-r - yp(k) + 3.0*d)/h
  ci = (r - d - d)/(h*h)
!
  d = a0 - x(k)
  r = h + d
  h2 = h*h
  d2 = d*d
  s = h2 + d2
  sum = y(k) + 0.5*yp(k)*r + bi*(s + h*d)/3.0 &
             + 0.25*ci*r*s
  sum = (x(kp1) - a0)*sum
!
!     integrate over the interior intervals
!
  if (kp1 == l) go to 40
  lm1 = l - 1
  do 30 i = kp1,lm1
     ip1 = i + 1
     h = x(ip1) - x(i)
     d = (y(ip1) - y(i))/h
     r = yp(i) + yp(ip1)
     bi = (-r - yp(i) + 3.0*d)/h
     ci = (r - d - d)/(h*h)
     s = (((0.25*ci*h + bi/3.0)*h + 0.5*yp(i))*h + y(i))*h
     sum = sum + s
   30 continue
!
!     integrate from x(l) to b0
!
   40 lp1 = l + 1
  h = x(lp1) - x(l)
  d = (y(lp1) - y(l))/h
  r = yp(l) + yp(lp1)
  bi = (-r - yp(l) + 3.0*d)/h
  ci = (r - d - d)/(h*h)
  h = b0 - x(l)
  s = (((0.25*ci*h + bi/3.0)*h + 0.5*yp(l))*h + y(l))*h
  csint1 = sum + s
  if (a > b) csint1 = -csint1
  return
!
!     case when a0 and b0 are in the same interval
!
   50 k = n
   51 kp1 = k + 1
  h = x(kp1) - x(k)
  d = (y(kp1) - y(k))/h
  r = yp(k) + yp(kp1)
  bi = (-r - yp(k) + 3.0*d)/h
  ci = (r - d - d)/(h*h)
!
  h = b0 - x(k)
  d = a0 - x(k)
  r = h + d
  h2 = h*h
  d2 = d*d
  s = h2 + d2
  sum = y(k) + 0.5*yp(k)*r + bi*(s + h*d)/3.0 &
             + 0.25*ci*r*s
  csint1 = (b - a)*sum
  return
end
function csint2 (x, y, ypp, n, a, b)
!
!*******************************************************************************
!
!! CSINT2: integrating a cubic spline
!
!
!  Parameters:
!
!     x    array of the first n abscissas (in increasing order)
!          that define the spline.
!
!     y    array of the first n ordinates that define the spline.
!
!     ypp  array of the second derivatives that define the spline.
!
!     n    the number of knots of the spline. the arrays x, y,
!          and ypp must have dimension at least n where n >= 2.
!
!     a    lower limit of the integral.
!
!     b    upper limit of the integral. b may be less than
!          or greater than a.
!
!
  real csint2
  real x(n), y(n), ypp(n)
!
  csint2 = 0.0
  h = b - a
  if (h == 0.0) return
  if (h > 0.0) go to 10
     a0 = b
     b0 = a
     go to 20
   10 a0 = a
  b0 = b
!
!     locate the intervals containing a0 and b0
!
   20 k = intrvl (a0, x, n)
  l = intrvl (b0, x, n)
  if (k == l) go to 51
!
!     integrate from a0 to x(k + 1)
!
  kp1 = k + 1
  h = x(kp1) - x(k)
  d = (x(kp1) - a0)/h
  r = y(k)*d + y(kp1)*(2.0 - d)
  s = ypp(k)*(2.0 - d*d) + ypp(kp1)*(2.0 - d)**2
  sum = h*d*(0.5*r - h*h*d*s/24.0)
!
!
!     integrate over the interior intervals
!
  if (kp1 == l) go to 40
  lm1 = l - 1
  do 30 i = kp1,lm1
     ip1 = i + 1
     h = x(ip1) - x(i)
     r = y(i) + y(ip1)
     s = ypp(i) + ypp(ip1)
     sum = sum + h*(0.5*r - h*h*s/24.0)
   30 continue
!
!     integrate from x(l) to b0
!
   40 lp1 = l + 1
  h = x(lp1) - x(l)
  d = (b0 - x(l))/h
  r = y(l)*(2.0 - d) + y(lp1)*d
  s = ypp(l)*(2.0 - d)**2 + ypp(lp1)*(2.0 - d*d)
  csint2 = sum + h*d*(0.5*r - h*h*d*s/24.0)
  if (a > b) csint2 = -csint2
  return
!
!     case when a0 and b0 are in the same interval
!
   50 k = n
   51 kp1 = k + 1
  h = x(kp1) - x(k)
  dma = (a - x(k))/h
  dmb = (b - x(k))/h
  dpa = (x(kp1) - a)/h
  dpb = (x(kp1) - b)/h
  r = (dpa + dpb)*y(k) + (dma + dmb)*y(kp1)
  s = ypp(k) * (dpa + dpb)*(dma*(2.0 - dma) + dmb*(2.0 - dmb)) + &
      ypp(kp1)*(dma + dmb)*(dpa*(2.0 - dpa) + dpb*(2.0 - dpb))
  csint2 = (b - a)*(0.5*r - h*h*s/24.0)
  return
end
subroutine csloop (m, n, x, kx, t, dx, kdx, wk, ierr)
!
!*******************************************************************************
!
!! CSLOOP: closed curve cubic spline fitting in n-dimensional space
!
!
!  Author:
!
!        alfred h. morris
!        naval surface warfare center
!        Dahlgren, Virginia
!
  real x(kx,n), t(m), dx(kdx,n), wk(*)
!-
!     m = the number of n-dimensional points given in x
!     wk is an array of dimension 4*(m-1)
!-
  if (min (m, n) < 2) go to 10
!
  mm1 = m - 1
  ie = 1
  ia = mm1
  ib = ia + mm1
  ic = ib + m
  call cslop1 (m, n, x, kx, t, dx, kdx, wk(ia), wk(ib), &
                      wk(ic), wk(ie), ierr)
  return
!
!     error return
!
   10 ierr = 1
  return
end
subroutine cslop1 (m, n, x, kx, t, dx, kdx, a, b, c, e, ierr)
!
!*******************************************************************************
!
!! CSLOP1: closed curve cubic spline fitting in n-dimensional space
!
  real x(kx,n), t(m), dx(kdx,n), a(*), b(m), c(*), e(*)
!-
!     real a(m-1), c(m-1), e(k)  (k = max (1,m-2))
!     the e array is not used when m = 2.
!-
  mm1 = m - 1
  mm2 = m - 2
!
!     definition of the knots t(i) (i = 1,...,m). also t(m+1) = 1.
!     this last knot is not stored.
!
  t(1) = 0.0
  do 11 i = 2,m
     im1 = i - 1
     do 10 j = 1,n
        dx(i,j) = x(i,j) - x(im1,j)
   10    continue
     t(i) = t(im1) + snrm2(n,dx(i,1),kdx)
     r = t(i) - t(im1)
     if (r == 0.0) go to 200
   11 continue
!
  do 20 j = 1,n
     dx(1,j) = x(1,j) - x(m,j)
   20 continue
  sum = t(m) + snrm2(n,dx(1,1),kdx)
  r = sum - t(m)
  if (r == 0.0) go to 210
!
  do 30 i = 2,m
     t(i) = t(i)/sum
   30 continue
  ierr = 0
!
!     for j = 1,...,n, a diagonally dominant set of equations
!     for the slopes s(i,j) of the j-th periodic spline at t(i)
!     (i = 1,...,m) is generated and solved by gauss elimination.
!     the first equation is obtained from the requirement that
!     the spline be periodic. this equation has the form ...
!
!        a(1)*s(1,j) + b(1)*s(2,j) + c(1)*s(m,j) = dx(1,j)
!
  h = t(2)
  hm = 1.0 - t(m)
  c(1) = h
  b(1) = hm
  a(1) = 2.0*(h + hm)
  b(2) = h
!
  do 40 j = 1,n
     delm = dx(1,j)/hm
     del1 = dx(2,j)/h
     dx(1,j) = 3.0*(h*delm + hm*del1)
     dx(2,j) = del1
   40 continue
  if (m == 2) go to 70
!
!     for the knots t(i) (i = 2,...m-1), generate the correspond-
!     ing equations and carry out the pivot reduction of gauss
!     elimination. then the i-th equation has the form ...
!
!        a(i)*s(i,j) + b(i)*s(i+1,j) + c(i)*s(m,j) = dx(i,j)
!
  do 50 i = 2,mm1
     im1 = i - 1
     b(i) = h
     h = t(i+1) - t(i)
     e(im1) = h/a(im1)
     c(i) = - e(im1)*c(im1)
     a(i) = 2.0*(b(i) + h) - e(im1)*b(im1)
   50 continue
  b(m) = h
!
  do 61 j = 1,n
     deli = dx(2,j)
     do 60 i = 2,mm1
        h = b(i+1)
        del0 = deli
        deli = dx(i+1,j)/h
        dx(i,j) = 3.0*(h*del0 + b(i)*deli) - e(i-1)*dx(i-1,j)
   60    continue
     dx(m,j) = deli
   61 continue
!
!     since it is required that the spline be periodic, the
!     equation for the knot t(m) has the form ...
!
!        alpha*s(1,j) + hm*s(m-1,j) + eta*s(m,j) = dx(m,j)
!
!     applying the pivots to this equation, one obtains after
!     each pivot operation the modified equation ...
!
!        alpha*s(i+1,j) + hm*s(m-1,j) + eta*s(m,j) = dx(m,j)
!
!     thus, when this pivot reduction is complete, the m-th
!     equation to be solved has the form ...
!
!        (alpha + hm)*s(m-1,j) + eta*s(m,j) = dx(m,j)
!
   70 alpha = h
  eta = 2.0*(h + hm)
  do 71 j = 1,n
     del  = dx(m,j)
     delm = (x(1,j) - x(m,j))/hm
     dx(m,j) = 3.0*(hm*del + h*delm)
   71 continue
  if (m == 2) go to 90
!
  do 81 i = 1,mm2
     p = alpha/a(i)
     alpha = - p*b(i)
     eta = eta - p*c(i)
     do 80 j = 1,n
        dx(m,j) = dx(m,j) - p*dx(i,j)
   80    continue
   81 continue
!
!     solve the last two equations for s(m,j) and s(m-1,j),
!     and store these slopes in dx.
!
   90 p = (alpha + hm)/a(mm1)
  tau = b(mm1) + c(mm1)
  do 91 j = 1,n
     sm = (dx(m,j) - p*dx(mm1,j))/(eta - p*tau)
     dx(m,j) = sm
     dx(mm1,j) = (dx(mm1,j) - tau*sm)/a(mm1)
   91 continue
  if (m == 2) return
!
!     back substitution to obtain the remaining slopes s(i,j).
!     these slopes are stored in dx.
!
  do 101 j = 1,n
     sm = dx(m,j)
     si = dx(mm1,j)
     i = mm1
     do 100 l = 3,m
        i = i - 1
        si = (dx(i,j) - b(i)*si - c(i)*sm)/a(i)
        dx(i,j) = si
  100    continue
  101 continue
  return
!
!     error return
!
  200 ierr = 2
  return
  210 ierr = 3
  return
end
subroutine cslv ( m0, n, a, ia, ja, b, r, c, max2, x, iwk, wk, ierr )
!
!*******************************************************************************
!
!! CSLV: solution of complex sparse matrices
!
!
!     cslv employs gaussian elimination with column interchanges to
!     solve the nxn complex system ax = b. the argument m0 specifies
!     if cslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to cslv.
!
!
!     input arguments when m0=0 ---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the complex matrix a stored in sparse form.
!
!     b        complex array of n entries containing the right hand
!              side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2      integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0 ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        complex array of n entries containing the solution.
!              b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas ---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       complex array of dimension 2*n + max2.
!
!
!     after an initial call to cslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to cslv
!     and solves the new equations ax = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  complex a(*)
  complex b(n)
  integer c(n)
  integer ia(*)
  integer iwk(*)
  integer ja(*)
  integer max2
  integer p
  integer r(n)
  integer t
  complex wk(*)
  complex x(n)
  integer y
!
!  Set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if ( m0 /= 0 ) go to 20
!
!  Compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return

  do k = 1,n
    l = c(k)
    iwk(l) = k
  end do
!
!  Obtain the lu decomposition of a
!
  call csplu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
    iwk(iu),wk(y),iwk(p),ierr)

  if ( ierr < 0 ) then
    return
  end if

  ierr = max ( 1, ierr )
!
!  Solve the system of equations
!
   20 call cslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                    b,x,wk(y))
  return
end
subroutine cslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! CSLV1 solves a factored system of complex sparse matrices.
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  complex b(n), d(n), t(*), x(n), y(n), sum
!
!            solve ly = b by forward substitution
!
  do 11 k = 1,n
     lk = r(k)
     sum = b(lk)
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 11
     do 10 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   10    continue
   11 y(k) = sum/d(k)
!
!            solve ux = b by backward substitution
!             and reorder x to correspond with a
!
  k = n
  do 22 i = 1,n
     sum = y(k)
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   20    continue
   21    y(k) = sum
     lk = c(k)
     x(lk) = y(k)
     k = k - 1
   22 continue
  return
end
subroutine cslvmp ( mo, n, a, ka, b, x, wk, iwk, ierr )
!
!*******************************************************************************
!
!! CSLVMP: solution of complex linear equations with iterative improvement
!
  complex a(ka,n), b(n), x(n), wk(*)
  integer iwk(n)
!     -----------------
!     complex wk(n*n + n)
!
  if (mo /= 0) go to 10
!
!             compute the lu decomposition of a
!
  call cmcopy(n, n, a, ka, wk, n)
  call cgefa(wk, n, n, iwk, ierr)
  if (ierr == 0) go to 10
  ierr = -ierr
  return
!
!            solve the system of equations ax = b
!
   10 do 11 i = 1,n
   11 x(i) = b(i)
!
  ir = n*n + 1
  call cgesl(wk, n, n, iwk, x, 0)
  call cluimp(a, ka, n, wk(1), n, iwk, b, x, wk(ir), ierr)
  return
end
subroutine csplu (a,ia,ja,r,c,ic,n,max,d,t,it,jt,iu,w,p,ierr)
!
!*******************************************************************************
!
!! CSPLU employs gaussian elimination with column interchanges
!     to perform the lu decomposition of a complex sparse matrix.
!     u is a unit upper triangular matrix.
!
!
!     input arguments ---
!
!     a,ia,ja  the complex sparse matrix to be decomposed.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     ic       integer array of n entries which is the inverse of c
!              (i.e., ic(c(i)) = i). ic is also an output argument.
!
!     n        order of the matrix a.
!
!     max      integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     ic       integer array of n entries which is the inverse of c.
!
!     d        complex array containing the n diagonal elements of l.
!
!     t,it,iu  t contains the off-diagonal nonzero elements of l and
!              u. for i = 1,...,n the off-diagonal nonzero elements
!              of the i-th row of l are stored in locations
!              it(i),...,iu(i)-1 of t, and the off-diagonal nonzero
!              elements of the i-th row of u are stored in locations
!              iu(i),...,it(i+1)-1 of t. t is a complex array.
!
!     jt       integer array containing the column indices (according
!              to the orginal column ordering) of the elements of t
!              (i.e., for each l(i,j) and u(i,j) in t, c(j) is the
!              corresponding column index in jt).
!
!     ierr     integer specifying the status of the results. if the
!              lu decomposition is obtained then ierr = the number
!              of off-diagonal entries of l and u which were stored
!              in t. otherwise ierr is assigned a negative value.
!
!
!     work spaces ---
!
!     w        complex array of dimension n.
!
!     p        integer array of dimension n+1.
!
  complex a(*), d(n), t(max), w(n)
  integer ia(*), ja(*)
  integer r(n), c(n), ic(n)
  integer it(*), jt(max), iu(n)
  integer p(*), pm
  complex const, zero
  real    wi, wmax
!
  data zero /(0.0, 0.0)/
!
  jptr = 0
  it(1) = 1
  do 10 j = 1,n
     w(j) = zero
   10 continue
!
!     perform the lu factorization of the r(k)-th row of a
!
  do 100 k = 1,n
  lk = r(k)
  jmin = ia(lk)
  jmax = ia(lk+1) - 1
  if (jmin > jmax) go to 200
!
!     set p to the reordered row of a
!
  p(n+1) = n + 1
  jj = jmax
   20 lj = ja(jj)
  j = ic(lj)
  w(j) = a(jj)
  pm = n + 1
   21 m = pm
  pm = p(m)
  if (pm - j) 21,210,22
   22 p(m) = j
  p(j) = pm
  jj = jj - 1
  if (jj >= jmin) go to 20
!
!     process the entries in the lower triangle of a
!
  i = n + 1
   30 i = p(i)
  if (i >= k) go to 50
  if (w(i) == zero) go to 30
!
!     l(k,i) is nonzero. therefore store it in l.
!
  jptr = jptr + 1
  if (jptr > max) go to 230
  const = w(i)
  t(jptr) = const
  jt(jptr) = c(i)
  w(i) = zero
!
!     perform elimination using the i-th row of u
!
  jmin = iu(i)
  jmax = it(i+1) - 1
  if (jmin > jmax) go to 30
  pm = i
  do 43 jj = jmin,jmax
     lj = jt(jj)
     j = ic(lj)
     if (w(j) /= zero) go to 43
     if (j - pm) 40,43,41
   40       pm = i
   41       m = pm
        pm = p(m)
        if (pm - j) 41,43,42
   42       p(m) = j
        p(j) = pm
        pm = j
   43 w(j) = w(j) - const*t(jj)
  go to 30
!
!     search for the k-th pivot element
!
   50 if (i > n) go to 220
  wmax = abs(real(w(i))) + abs(aimag(w(i)))
  maxi = i
  pm = i
   51 m = pm
  pm = p(m)
  if (pm > n) go to 60
  wi = abs(real(w(pm))) + abs(aimag(w(pm)))
  if (wi <= wmax) go to 51
     wmax = wi
     maxi = pm
     maxil = m
     go to 51
!
!     store the pivot in d
!
   60 if (wmax == 0.0) go to 220
  d(k) = w(maxi)
!
!     perform the column interchange
!
  if (i == k) go to 70
  if (i == maxi) go to 70
     p(maxil) = p(maxi)
     go to 80
   70 i = p(i)
!
   80 w(maxi) = w(k)
  w(k) = zero
  lk = c(k)
  ll = c(maxi)
  c(k) = ll
  c(maxi) = lk
  ic(lk) = maxi
  ic(ll) = k
!
!     the remaining elements of p form the k-th row of u
!
  iu(k) = jptr + 1
   90 if (i > n) go to 100
  if (w(i) == zero) go to 91
     jptr = jptr + 1
     if (jptr > max) go to 230
     t(jptr) = w(i)/d(k)
     jt(jptr) = c(i)
     w(i) = zero
   91 i = p(i)
  go to 90
!
!     prepare for the next row
!
  100 it(k+1) = jptr + 1
!
  ierr = jptr
  return
!
!  Error return.
!
!     row r(k) is null
!
  200 ierr = -k
  return
!
!     row r(k) has a duplicate entry
!
  210 ierr = -(n + k)
  return
!
!     zero pivot in row r(k)
!
  220 ierr = -(2*n + k)
  return
!
!     storage for l and u exceeded on row r(k)
!
  230 ierr = -(3*n + k)
  return
end
subroutine csprod (a,ia,ja,b,ib,jb,c,ic,jc,l,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! CSPROD: multiplication of sparse complex matrices
!
  complex a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!----
  do 10 k = 1,n
     wk(k) = (0.0, 0.0)
   10 continue
!
!                     compute the i-th row of c
!
  ip = 1
  do 31 i = 1,l
     ic(i) = ip
     jpmin = ia(i)
     jpmax = ia(i+1) - 1
     if (jpmin > jpmax) go to 31
!
     do 21 jp = jpmin,jpmax
        t = a(jp)
        if (t == (0.0, 0.0)) go to 21
        j = ja(jp)
        kpmin = ib(j)
        kpmax = ib(j+1) - 1
        if (kpmin > kpmax) go to 21
        do 20 kp = kpmin,kpmax
           k = jb(kp)
           wk(k) = wk(k) + t*b(kp)
   20       continue
   21    continue
!
     do 30 k = 1,n
        if (wk(k) == (0.0, 0.0)) go to 30
        if (ip > num) go to 40
        c(ip) = wk(k)
        wk(k) = (0.0, 0.0)
        jc(ip) = k
        ip = ip + 1
   30    continue
   31 continue
  ic(l + 1) = ip
  ierr = 0
  return
!
!                           error return
!
   40 ierr = i
  return
end
subroutine cspslv (n,a,ia,ja,b,r,c,max,x,itemp,rtemp,ierr)
!
!*******************************************************************************
!
!! CSPSLV: solution of complex sparse matrices
!
!  cspslv calls cnspiv which uses sparse gaussian elimination with
!  column interchanges to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!  input arguments---
!
!  n      integer number of equations and unknowns
!
!  a      complex array with one entry per nonzero in a, containing
!         the actual nonzeros.  (see storage description below)
!
!  ia     integer array of n+1 entries containing row pointers to a
!         (see matrix storage description below)
!
!  ja     integer array with one entry per nonzero in a, containing
!         column numbers of the nonzeros of a.  (see matrix storage
!         description below)
!
!  b      complex array of n entries containing right hand side data
!
!  r      integer array of n entries specifying the order of the
!         rows of a (i.e., the elimination order for the equations)
!
!  c      integer array of n entries specifying the order of the
!         columns of a.  c is also an output argument
!
!  max    integer number specifying maximum number of off-diagonal
!         nonzero entries of u which may be stored
!
!  itemp  integer array of 3*n + max + 2 entries, for internal use
!
!  rtemp  complex array of n + max entries for internal use
!
!
!  output arguments---
!
!  c      integer array of n entries specifying the order of the
!         columns of u.  c is also an input argument
!
!  x      complex array of n entries containing the solution vector
!
!  ierr   integer number which indicates error conditions or
!         the actual number of off-diagonal entries in u (for
!         successful completion)
!
!         ierr values are---
!
!         0 lt ierr             successful completion. ierr=max(1,m)
!                               where m is the number of off-diagonal
!                               nonzero entries of u.
!
!         ierr = 0              error.  n is less than or equal to 0
!
!         -n le ierr lt 0       error.  row number iabs(ierr) of a is
!                               is null
!
!         -2*n le ierr lt -n    error.  row number iabs(ierr+n) has a
!                               duplicate entry
!
!         -3*n le ierr lt -2*n  error.  row number iabs(ierr+2*n)
!                               has a zero pivot
!
!         -4*n le ierr lt -3*n  error.  row number iabs(ierr+3*n)
!                               exceeds storage
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzero
!  elements in a.
!
  complex a(*), b(n), x(n), rtemp(*)
  integer ia(*), ja(*), r(n), c(n), itemp(*)
  integer iu, ju, u, y, p
!
  ierr = 0
  if (n <= 0) return
!
!  set indices to divide temporary storage for cnspiv
!
  y = 1
  u = y + n
  p = n + 1
  iu = p + n + 1
  ju = iu + n + 1
!
!  compute the inverse permutation of c
!
  do 10 k = 1,n
     l = c(k)
     itemp(l) = k
   10 continue
!
!  call cnspiv to perform computations
!
  call cnspiv (n,ia,ja,a,b,max,r,c,itemp(1),x,rtemp(y),itemp(p), &
               itemp(iu),itemp(ju),rtemp(u),ierr)
  if (ierr == 0) ierr = 1
  return
end
subroutine csreal (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! CSREAL: real part of a sparse complex matrix
!
  complex a(*)
  real b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        t = real(a(ip))
        if (t == 0.0) go to 10
        b(l) = t
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
subroutine csrot (n,cx,incx,cy,incy,c,s)
!
!*******************************************************************************
!
!! CSROT: applies a plane rotation, where the cos and sin (c and s) are real
!     and the vectors cx and cy are complex.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*),cy(*),ctemp
  real c,s
  integer i,incx,incy,ix,iy,n
!
  if(n <= 0)return
  if(incx == 1.and.incy==1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    ctemp = c*cx(ix) + s*cy(iy)
    cy(iy) = c*cy(iy) - s*cx(ix)
    cx(ix) = ctemp
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!       code for both increments equal to 1
!
   20 do 30 i = 1,n
    ctemp = c*cx(i) + s*cy(i)
    cy(i) = c*cy(i) - s*cx(i)
    cx(i) = ctemp
   30 continue
  return
end
subroutine csscal(n,sa,cx,incx)
!
!*******************************************************************************
!
!! CSSCAL: scales a complex vector by a real constant.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*)
  real sa
  integer i,incx,n,nincx
!
  if(n <= 0)return
  if(incx == 1)go to 20
!
!        code for increment not equal to 1
!
  nincx = n*incx
  do 10 i = 1,nincx,incx
    cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i)))
   10 continue
  return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
    cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i)))
   30 continue
  return
end
subroutine cssubt (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! CSSUBT: subtraction of sparse complex matrices
!
  complex a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!----
  do 10 j = 1,n
     wk(j) = (0.0, 0.0)
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) - b(l)
        wk(j) = (0.0, 0.0)
        if (t == (0.0, 0.0)) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == (0.0, 0.0)) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = (0.0, 0.0)
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine csvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
!
!*******************************************************************************
!
!! CSVDC is a subroutine to reduce a complex nxp matrix x by
!     unitary transformations u and v to diagonal form.  the
!     diagonal elements s(i) are the singular values of x.  the
!     columns of u are the corresponding left singular vectors,
!     and the columns of v the right singular vectors.
!
!     on entry
!
!         x         complex(ldx,p), where ldx >= n.
!                   x contains the matrix whose singular value
!                   decomposition is to be computed.  x is
!                   destroyed by csvdc.
!
!         ldx       integer.
!                   ldx is the leading dimension of the array x.
!
!         n         integer.
!                   n is the number of rows of the matrix x.
!
!         p         integer.
!                   p is the number of columns of the matrix x.
!
!         ldu       integer.
!                   ldu is the leading dimension of the array u
!                   (see below).
!
!         ldv       integer.
!                   ldv is the leading dimension of the array v
!                   (see below).
!
!         work      complex(n).
!                   work is a scratch array.
!
!         job       integer.
!                   job controls the computation of the singular
!                   vectors.  it has the decimal expansion ab
!                   with the following meaning
!
!                        a == 0    do not compute the left singular
!                                  vectors.
!                        a == 1    return the n left singular vectors
!                                  in u.
!                        a >= 2    returns the first min(n,p)
!                                  left singular vectors in u.
!                        b == 0    do not compute the right singular
!                                  vectors.
!                        b == 1    return the right singular vectors
!                                  in v.
!
!     on return
!
!         s         complex(mm), where mm=min(n+1,p).
!                   the first min(n,p) entries of s contain the
!                   singular values of x arranged in descending
!                   order of magnitude.
!
!         e         complex(p).
!                   e ordinarily contains zeros.  however see the
!                   discussion of info for exceptions.
!
!         u         complex(ldu,k), where ldu >= n.  if joba == 1 then
!                                   k == n, if joba >= 2 then
!                                   k == min(n,p).
!                   u contains the matrix of left singular vectors.
!                   u is not referenced if joba == 0.  if n <= p
!                   or if joba > 2, then u may be identified with x
!                   in the subroutine call.
!
!         v         complex(ldv,p), where ldv >= p.
!                   v contains the matrix of right singular vectors.
!                   v is not referenced if jobb == 0.  if p <= n,
!                   then v may be identified whth x in the
!                   subroutine call.
!
!         info      integer.
!                   the singular values (and their corresponding
!                   singular vectors) s(info+1),s(info+2),...,s(m)
!                   are correct (here m=min(n,p)).  thus if
!                   info == 0, all the singular values and their
!                   vectors are correct.  in any event, the matrix
!                   b = ctrans(u)*x*v is the bidiagonal matrix
!                   with the elements of s on its diagonal and the
!                   elements of e on its super-diagonal (ctrans(u)
!                   is the conjugate-transpose of u).  thus the
!                   singular values of x and b are the same.
!
!     linpack. this version dated 03/19/79 .
!     g.w. stewart, university of maryland, argonne national lab.
!
!     csvdc uses the following functions and subprograms.
!
!     external csrot
!     blas caxpy,cdotc,cscal,cswap,scnrm2,srotg
!     fortran abs,aimag,cabs,cmplx
!     fortran conjg,max0,min0,mod,real,sqrt
!
  integer ldx,n,p,ldu,ldv,job,info
  complex x(ldx,*),s(*),e(*),u(ldu,*),v(ldv,*),work(*)
!
!
!     internal variables
!
  integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, &
          mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
  complex cdotc,t,r
  real b,c,cs,el,emm1,f,g,scnrm2,scale,shift,sl,sm,sn,smm1,t1,test, &
       ztest
  logical wantu,wantv
!
  complex csign,zdum,zdum1,zdum2
  real cabs1
  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
  csign(zdum1,zdum2) = cabs(zdum1)*(zdum2/cabs(zdum2))
!
!     set the maximum number of iterations.
!
  maxit = 30
!
!     determine what is to be computed.
!
  wantu = .false.
  wantv = .false.
  jobu = mod(job,100)/10
  ncu = n
  if (jobu > 1) ncu = min (n,p)
  if (jobu /= 0) wantu = .true.
  if (mod(job,10) /= 0) wantv = .true.
!
!     reduce x to bidiagonal form, storing the diagonal elements
!     in s and the super-diagonal elements in e.
!
  info = 0
  nct = min (n-1,p)
  nrt = max (0,min (p-2,n))
  lu = max (nct,nrt)
  if (lu < 1) go to 170
  do 160 l = 1, lu
     lp1 = l + 1
     if (l > nct) go to 20
!
!           compute the transformation for the l-th column and
!           place the l-th diagonal in s(l).
!
        s(l) = cmplx(scnrm2(n-l+1,x(l,l),1),0.0e0)
        if (cabs1(s(l)) == 0.0e0) go to 10
           if (cabs1(x(l,l)) /= 0.0e0) s(l) = csign(s(l),x(l,l))
           call cscal(n-l+1,1.0e0/s(l),x(l,l),1)
           x(l,l) = (1.0e0,0.0e0) + x(l,l)
   10       continue
        s(l) = -s(l)
   20    continue
     if (p < lp1) go to 50
     do 40 j = lp1, p
        if (l > nct) go to 30
        if (cabs1(s(l)) == 0.0e0) go to 30
!
!              apply the transformation.
!
           t = -cdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
           call caxpy(n-l+1,t,x(l,l),1,x(l,j),1)
   30       continue
!
!           place the l-th row of x into  e for the
!           subsequent calculation of the row transformation.
!
        e(j) = conjg(x(l,j))
   40    continue
   50    continue
     if (.not.wantu .or. l > nct) go to 70
!
!           place the transformation in u for subsequent back
!           multiplication.
!
        do 60 i = l, n
           u(i,l) = x(i,l)
   60       continue
   70    continue
     if (l > nrt) go to 150
!
!           compute the l-th row transformation and place the
!           l-th super-diagonal in e(l).
!
        e(l) = cmplx(scnrm2(p-l,e(lp1),1),0.0e0)
        if (cabs1(e(l)) == 0.0e0) go to 80
           if (cabs1(e(lp1)) /= 0.0e0) e(l) = csign(e(l),e(lp1))
           call cscal(p-l,1.0e0/e(l),e(lp1),1)
           e(lp1) = (1.0e0,0.0e0) + e(lp1)
   80       continue
        e(l) = -conjg(e(l))
        if (lp1 > n .or. cabs1(e(l)) == 0.0e0) go to 120
!
!              apply the transformation.
!
           do 90 i = lp1, n
              work(i) = (0.0e0,0.0e0)
   90          continue
           do 100 j = lp1, p
              call caxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
  100          continue
           do 110 j = lp1, p
              call caxpy(n-l,conjg(-e(j)/e(lp1)),work(lp1),1, &
                         x(lp1,j),1)
  110          continue
  120       continue
        if (.not.wantv) go to 140
!
!              place the transformation in v for subsequent
!              back multiplication.
!
           do 130 i = lp1, p
              v(i,l) = e(i)
  130          continue
  140       continue
  150    continue
  160 continue
  170 continue
!
!     set up the final bidiagonal matrix of order m.
!
  m = min (p,n+1)
  nctp1 = nct + 1
  nrtp1 = nrt + 1
  if (nct < p) s(nctp1) = x(nctp1,nctp1)
  if (n < m) s(m) = (0.0e0,0.0e0)
  if (nrtp1 < m) e(nrtp1) = x(nrtp1,m)
  e(m) = (0.0e0,0.0e0)
!
!     if required, generate u.
!
  if (.not.wantu) go to 300
     if (ncu < nctp1) go to 200
     do 190 j = nctp1, ncu
        do 180 i = 1, n
           u(i,j) = (0.0e0,0.0e0)
  180       continue
        u(j,j) = (1.0e0,0.0e0)
  190    continue
  200    continue
     if (nct < 1) go to 290
     do 280 ll = 1, nct
        l = nct - ll + 1
        if (cabs1(s(l)) == 0.0e0) go to 250
           lp1 = l + 1
           if (ncu < lp1) go to 220
           do 210 j = lp1, ncu
              t = -cdotc(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
              call caxpy(n-l+1,t,u(l,l),1,u(l,j),1)
  210          continue
  220          continue
           call cscal(n-l+1,(-1.0e0,0.0e0),u(l,l),1)
           u(l,l) = (1.0e0,0.0e0) + u(l,l)
           lm1 = l - 1
           if (lm1 < 1) go to 240
           do 230 i = 1, lm1
              u(i,l) = (0.0e0,0.0e0)
  230          continue
  240          continue
        go to 270
  250       continue
           do 260 i = 1, n
              u(i,l) = (0.0e0,0.0e0)
  260          continue
           u(l,l) = (1.0e0,0.0e0)
  270       continue
  280    continue
  290    continue
  300 continue
!
!     if it is required, generate v.
!
  if (.not.wantv) go to 350
     do 340 ll = 1, p
        l = p - ll + 1
        lp1 = l + 1
        if (l > nrt) go to 320
        if (cabs1(e(l)) == 0.0e0) go to 320
           do 310 j = lp1, p
              t = -cdotc(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
              call caxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
  310          continue
  320       continue
        do 330 i = 1, p
           v(i,l) = (0.0e0,0.0e0)
  330       continue
        v(l,l) = (1.0e0,0.0e0)
  340    continue
  350 continue
!
!     transform s and e so that they are real.
!
  do 380 i = 1, m
     if (cabs1(s(i)) == 0.0e0) go to 360
        t = cmplx(cabs(s(i)),0.0e0)
        r = s(i)/t
        s(i) = t
        if (i < m) e(i) = e(i)/r
        if (wantu) call cscal(n,r,u(1,i),1)
  360    continue
!     ...exit
     if (i == m) go to 390
     if (cabs1(e(i)) == 0.0e0) go to 370
        t = cmplx(cabs(e(i)),0.0e0)
        r = t/e(i)
        e(i) = t
        s(i+1) = s(i+1)*r
        if (wantv) call cscal(p,r,v(1,i+1),1)
  370    continue
  380 continue
  390 continue
!
!     main iteration loop for the singular values.
!
  mm = m
  iter = 0
  400 continue
!
!        quit if all the singular values have been found.
!
!     ...exit
     if (m == 0) go to 660
!
!        if too many iterations have been performed, set
!        flag and return.
!
     if (iter < maxit) go to 410
        info = m
!     ......exit
        go to 660
  410    continue
!
!        this section of the program inspects for
!        negligible elements in the s and e arrays.  on
!        completion the variables kase and l are set as follows.
!
!           kase = 1     if s(m) and e(l-1) are negligible and l < m
!           kase = 2     if s(l) is negligible and l < m
!           kase = 3     if e(l-1) is negligible, l < m, and
!                        s(l), ..., s(m) are not negligible (qr step).
!           kase = 4     if e(m-1) is negligible (convergence).
!
     do 430 ll = 1, m
        l = m - ll
!        ...exit
        if (l == 0) go to 440
        test = cabs(s(l)) + cabs(s(l+1))
        ztest = test + cabs(e(l))
        if (ztest /= test) go to 420
           e(l) = (0.0e0,0.0e0)
!        ......exit
           go to 440
  420       continue
  430    continue
  440    continue
     if (l /= m - 1) go to 450
        kase = 4
     go to 520
  450    continue
        lp1 = l + 1
        mp1 = m + 1
        do 470 lls = lp1, mp1
           ls = m - lls + lp1
!           ...exit
           if (ls == l) go to 480
           test = 0.0e0
           if (ls /= m) test = test + cabs(e(ls))
           if (ls /= l + 1) test = test + cabs(e(ls-1))
           ztest = test + cabs(s(ls))
           if (ztest /= test) go to 460
              s(ls) = (0.0e0,0.0e0)
!           ......exit
              go to 480
  460          continue
  470       continue
  480       continue
        if (ls /= l) go to 490
           kase = 3
        go to 510
  490       continue
        if (ls /= m) go to 500
           kase = 1
        go to 510
  500       continue
           kase = 2
           l = ls
  510       continue
  520    continue
     l = l + 1
!
!        perform the task indicated by kase.
!
     go to (530, 560, 580, 610), kase
!
!        deflate negligible s(m).
!
  530    continue
        mm1 = m - 1
        f = real(e(m-1))
        e(m-1) = (0.0e0,0.0e0)
        do 550 kk = l, mm1
           k = mm1 - kk + l
           t1 = real(s(k))
           call srotg(t1,f,cs,sn)
           s(k) = cmplx(t1,0.0e0)
           if (k == l) go to 540
              f = -sn*real(e(k-1))
              e(k-1) = cs*e(k-1)
  540          continue
           if (wantv) call csrot(p,v(1,k),1,v(1,m),1,cs,sn)
  550       continue
     go to 650
!
!        split at negligible s(l).
!
  560    continue
        f = real(e(l-1))
        e(l-1) = (0.0e0,0.0e0)
        do 570 k = l, m
           t1 = real(s(k))
           call srotg(t1,f,cs,sn)
           s(k) = cmplx(t1,0.0e0)
           f = -sn*real(e(k))
           e(k) = cs*e(k)
           if (wantu) call csrot(n,u(1,k),1,u(1,l-1),1,cs,sn)
  570       continue
     go to 650
!
!        perform one qr step.
!
  580    continue
!
!           calculate the shift.
!
        scale = max ( cabs(s(m)),cabs(s(m-1)),cabs(e(m-1)), &
                      cabs(s(l)),cabs(e(l)))
        sm = real(s(m))/scale
        smm1 = real(s(m-1))/scale
        emm1 = real(e(m-1))/scale
        sl = real(s(l))/scale
        el = real(e(l))/scale
        b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0
        c = (sm*emm1)**2
        shift = 0.0e0
        if (b == 0.0e0 .and. c == 0.0e0) go to 590
           shift = sqrt(b**2+c)
           if (b < 0.0e0) shift = -shift
           shift = c/(b + shift)
  590       continue
        f = (sl + sm)*(sl - sm) - shift
        g = sl*el
!
!           chase zeros.
!
        mm1 = m - 1
        do 600 k = l, mm1
           call srotg(f,g,cs,sn)
           if (k /= l) e(k-1) = cmplx(f,0.0e0)
           f = cs*real(s(k)) + sn*real(e(k))
           e(k) = cs*e(k) - sn*s(k)
           g = sn*real(s(k+1))
           s(k+1) = cs*s(k+1)
           if (wantv) call csrot(p,v(1,k),1,v(1,k+1),1,cs,sn)
           call srotg(f,g,cs,sn)
           s(k) = cmplx(f,0.0e0)
           f = cs*real(e(k)) + sn*real(s(k+1))
           s(k+1) = -sn*e(k) + cs*s(k+1)
           g = sn*real(e(k+1))
           e(k+1) = cs*e(k+1)
           if (wantu .and. k < n) &
              call csrot(n,u(1,k),1,u(1,k+1),1,cs,sn)
  600       continue
        e(m-1) = cmplx(f,0.0e0)
        iter = iter + 1
     go to 650
!
!        convergence.
!
  610    continue
!
!           make the singular value  positive
!
        if (real(s(l)) >= 0.0e0) go to 620
           s(l) = -s(l)
           if (wantv) call cscal(p,(-1.0e0,0.0e0),v(1,l),1)
  620       continue
!
!           order the singular value.
!
  630       if (l == mm) go to 640
!           ...exit
           if (real(s(l)) >= real(s(l+1))) go to 640
           t = s(l)
           s(l) = s(l+1)
           s(l+1) = t
           if (wantv .and. l < p) &
              call cswap(p,v(1,l),1,v(1,l+1),1)
           if (wantu .and. l < n) &
              call cswap(n,u(1,l),1,u(1,l+1),1)
           l = l + 1
        go to 630
  640       continue
        iter = 0
        m = m - 1
  650    continue
  go to 400
  660 continue
  return
end
subroutine cswap (n,cx,incx,cy,incy)
!
!*******************************************************************************
!
!! CSWAP interchanges two vectors.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*),cy(*),ctemp
  integer i,incx,incy,ix,iy,n
!
  if(n <= 0)return
  if(incx == 1.and.incy==1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    ctemp = cx(ix)
    cx(ix) = cy(iy)
    cy(iy) = ctemp
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!       code for both increments equal to 1
   20 do 30 i = 1,n
    ctemp = cx(i)
    cx(i) = cy(i)
    cy(i) = ctemp
   30 continue
  return
end
subroutine ctip (a, n1, n2, moved, nwork, ndim)
!
!*******************************************************************************
!
!! CTIP transposes a rectangular matrix in situ.
!
!
! by norman brenner, mit, 1/72.  cf. alg. 380, cacm, 5/70.
! transposition of the n1 by n2 matrix a amounts to
! replacing the element at vector position i (0-origin)
! with the element at position n1*i (mod n1*n2-1).
! each subcycle of this permutation is completed in order.
! ----------------------------------------------------------
  complex a(*)
  complex atemp, btemp
  integer moved(nwork)
  integer ifact(8), ipower(8), nexp(8), iexp(8)
  if (n1 < 2 .or. n2 < 2) go to 200
  n12 = n1*n2
  n = n1
  m = n12 - 1
  if (n1/=n2) go to 30
! square matrices are done separately for speed
  i1min = 2
  do 20 i1max=n,m,n
    i2 = i1min + n - 1
    do 10 i1=i1min,i1max
      atemp = a(i1)
      a(i1) = a(i2)
      a(i2) = atemp
      i2 = i2 + n
   10   continue
    i1min = i1min + n + 1
   20 continue
  return
! modulus m is factored into prime powers.  eight factors
! suffice up to m = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 ndim = 0
  call infctr(m, ifact, ipower, nexp, npower)
  do 40 ip=1,npower
    iexp(ip) = 0
   40 continue
! generate every divisor of m less than m/2
  idiv = 1
  mhalf = m/2
   50 if (idiv >= mhalf) return
! the number of elements whose index is divisible by idiv
! and by no other divisor of m is the euler totient
! function, phi(m/idiv).
  ncount = m/idiv
  do 60 ip=1,npower
    if (iexp(ip) == nexp(ip)) go to 60
    ncount = (ncount/ifact(ip))*(ifact(ip)-1)
   60 continue
  if (nwork <= 0) go to 75
  do 70 i=1,nwork
    moved(i) = 0
   70 continue
   75 istart = idiv
! the starting point of a subcycle is divisible only by idiv
! and must not appear in any other subcycle.
   80 mmist = m - istart
  if (istart == idiv) go to 120
  ndim = max (ndim,istart)
  if (istart > nwork) go to 90
  if (moved(istart)/=0) go to 160
   90 isoid = istart/idiv
  do 100 ip=1,npower
    if (iexp(ip) == nexp(ip)) go to 100
    if (mod(isoid,ifact(ip)) == 0) go to 160
  100 continue
  if (istart <= nwork) go to 120
  itest = istart
  110 itest = mod(n*itest,m)
  if (itest < istart .or. itest > mmist) go to 160
  if (itest > istart .and. itest < mmist) go to 110
  120 atemp = a(istart+1)
  btemp = a(mmist+1)
  ia1 = istart
  130 ia2 = mod(n*ia1,m)
  mmia1 = m - ia1
  mmia2 = m - ia2
  if (ia1 <= nwork) moved(ia1) = 1
  if (mmia1 <= nwork) moved(mmia1) = 1
  ncount = ncount - 2
! move two elements, the second from the negative
! subcycle.  check first for subcycle closure.
  if (ia2 == istart) go to 140
  if (mmia2 == istart) go to 150
  a(ia1+1) = a(ia2+1)
  a(mmia1+1) = a(mmia2+1)
  ia1 = ia2
  go to 130
  140 a(ia1+1) = atemp
  a(mmia1+1) = btemp
  go to 160
  150 a(ia1+1) = btemp
  a(mmia1+1) = atemp
  160 istart = istart + idiv
  if (ncount > 0) go to 80
  do 180 ip=1,npower
    if (iexp(ip) == nexp(ip)) go to 170
    iexp(ip) = iexp(ip) + 1
    idiv = idiv*ifact(ip)
    go to 50
  170   iexp(ip) = 0
    idiv = idiv/ipower(ip)
  180 continue
  return
  200 if (n1/=n2) ndim = 0
  return
end
subroutine ctpose(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! CTPOSE makes a transposed copy of a complex matrix.
!
  complex a(ka,n),b(kb,m)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(j,i) = a(i,j)
   20 continue
  return
end
subroutine ctprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! CTPRD: product of a vector and a sparse matrix
!
  complex a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 10 j = 1,n
     y(j) = (0.0, 0.0)
   10 continue
!
  do 21 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 21
     do 20 l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
   20    continue
   21 continue
  return
end
subroutine ctprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! CTPRD1: set y = x*a + y where a is a sparse matrix and x,y are vectors
!
  complex a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
   10    continue
   11 continue
  return
end
subroutine ctrans(nm, n, a)
!
!*******************************************************************************
!
!! CTRANS finds the complex conjugate of an input matrix.
!
!
!     on entry,
!
!     nm is the leading dimension of matrix a in the main program.
!
!     n  is the order of matrix a.
!
!     a  is the input matrix.
!
!
!     on return,
!
!     a  contains its conjugate transpose.
!
!
  integer i, j, n, nm
  complex a(nm,n), temp
!     complex conjg
  do 20 i=1,n
    do 10 j=i,n
      temp = a(i,j)
      a(i,j) = conjg(a(j,i))
      a(j,i) = conjg(temp)
   10   continue
   20 continue
  return
end
subroutine ctslv (m0,n,a,ia,ja,b,r,c,max2,x,iwk,wk,ierr)
!
!*******************************************************************************
!
!! CTSLV: solution of complex sparse matrices
!
!
!     ctslv employs gaussian elimination with column interchanges to
!     solve the nxn complex system xa = b. the argument m0 specifies
!     if ctslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to ctslv.
!
!
!     input arguments when m0=0 ---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the complex matrix a stored in sparse form.
!
!     b        complex array of n entries containing the right hand
!              side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2     integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0 ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        complex array of n entries containing the solution.
!              b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas ---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       complex array of dimension 2*n + max2.
!
!
!     after an initial call to ctslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to ctslv
!     and solves the new equations xa = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  complex a(*), b(n), x(n), wk(*)
  integer ia(*), ja(*), iwk(*)
  integer r(n), c(n), y, t, p
!
!     set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if (m0 /= 0) go to 20
!
!     compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return
  do 10 k = 1,n
     l = c(k)
     iwk(l) = k
   10 continue
!
!     obtain the lu decomposition of a
!
  call csplu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
               iwk(iu),wk(y),iwk(p),ierr)
  if (ierr < 0) return
  ierr = max (1,ierr)
!
!  Solve the system of equations
!
   20 call ctslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                   b,x,wk(y))
  return
end
subroutine ctslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! CTSLV1: ???
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  complex b(n), d(n), t(*), x(n), y(n)
!
!            solve yu = b by forward substitution
!
  do 10 k = 1,n
     lk = c(k)
     y(k) = b(lk)
   10 continue
!
  do 21 k = 1,n
     if (y(k) == (0.0, 0.0)) go to 21
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   20    continue
   21 continue
!
!            solve xl = y by backward substitution
!
  x(n) = y(n)/d(n)
  if (n == 1) return
!
  k = n
  y(n) = x(n)
  do 32 i = 2,n
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 31
     do 30 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   30    continue
   31    k = k - 1
     y(k) = y(k)/d(k)
   32 continue

  do k = 1,n
     lk = r(k)
     x(lk) = y(k)
  end do

  return
end
subroutine cubrul(f, vec, p, idata, rdata)
!
!*******************************************************************************
!
!! CUBRUL: basic cubature rule pair over a triangle
!
!
!  Parameters:
!
!         f  - external function - see comments to cubtri
!         vec- matrix of base vectors and origin (input)
!         p  - triangle description vector of dimension 6
!               p(1) - transformed x coordinate of origin vertex(input)
!               p(2) - transformed y coordinate of origin vertex(input)
!               p(3) - distance of other vertices in the directions
!                     of the base vectors (input)
!               p(4) - less accurate estimated integral (output)
!               p(5) - more accurate estimated integral (output)
!               p(6) - abs(p(5)-p(4))   (output)
!
!       cubrul evaluates a linear combination of basic integration
!       rules having d3 symmetry.  the areal coordinates pertaining to
!       the j-th rule are stored in w(i,j),i=1,2,3.  the corresponding
!       weights are w(4,j) and w(5,j), with w(5,j) belonging to the
!       more accurate formula.  if w(1,j) == w(2,j), the integration
!       point is the centroid, else if w(2,j) == w(3,j), the evaluation
!       points are on the medians.  in both cases advantage is taken of
!       symmetry to avoid repeating function evaluations.
!
!       the following double precision variables are used to avoid
!       unnecessary rounding errors in floating point addition.
!       they may be declared single precision if double precision is
!       not available and full accuracy is not needed.
!
  double precision a1, a2, s, sn, dzero, done, dthree, dsix
  real area, origin(2), p(*), rdata(*), tvec(2,3), vec(2,*), w(5,6)
  integer idata(*)
  external f
!
!       w contains points and weights of the integration formulae
!       nquad - number of basic rules used
!
!       this particular rule is the 19 point extension (degree 8) of
!       the familiar 7 point rule (degree 5).
!
!     sigma=sqrt(7)
!     phi=sqrt(15)
!     w(1,1),w(2,1),w(3,1) = 1/3
!     w(4,1) = 9/40
!     w(5,1) = 7137/62720 - 45*sigma/1568
!     w(1,2) = 3/7 + 2*phi/21
!     w(2,2),w(3,2) = 2/7 - phi/21
!     w(4,2) = 31/80 - phi/400
!     w(5,2) = - 9301697/4695040 - 13517313*phi/23475200
!            + 764885*sigma/939008 + 198763*phi*sigma/939008
!     w(*,3) = w(*,2) with phi replaced by -phi
!     w(1,5) = 4/9 + phi/9 + sigma/9 - sigma*phi/45
!     w(2,5),w(3,5) = 5/18 - phi/18 - sigma/18 + sigma*phi/90
!     w(4,5) = 0
!     w(5,5) = 102791225/59157504 + 23876225*phi/59157504
!            - 34500875*sigma/59157504 - 9914825*phi*sigma/59157504
!     w(*,4) = w(*,5) with phi replaced by -phi
!     w(1,6) = 4/9 + sigma/9
!     w(2,6) = w(2,4)
!     w(3,6) = w(2,5)
!     w(4,6) = 0
!     w(5,6) = 11075/8064 - 125*sigma/288
!
  data nquad /6/

  data w(1,1), w(2,1), w(3,1) /3*.3333333333333333333333333e0/
  data w(4,1), w(5,1) /.225e0,.3786109120031468330830822e-1/, &
   w(1,2), w(2,2), w(3,2) /.7974269853530873223980253e0,2* &
   .1012865073234563388009874e0/, w(4,2), w(5,2) &
   /.3778175416344814577870518e0,.1128612762395489164329420e0/, &
   w(1,3), w(2,3), w(3,3) /.5971587178976982045911758e-1,2* &
   .4701420641051150897704412e0/, w(4,3), w(5,3) &
   /.3971824583655185422129482e0,.2350720567323520126663380e0/
  data w(1,4), w(2,4), w(3,4) /.5357953464498992646629509e0,2* &
   .2321023267750503676685246e0/, w(4,4), w(5,4) &
   /0.e0,.3488144389708976891842461e0/, w(1,5), w(2,5), w(3,5) &
   /.9410382782311208665596304e0,2*.2948086088443956672018481e-1/, &
   w(4,5), w(5,5) /0.e0,.4033280212549620569433320e-1/, w(1,6), &
   w(2,6), w(3,6) /.7384168123405100656112906e0, &
   .2321023267750503676685246e0,.2948086088443956672018481e-1/, &
   w(4,6), w(5,6) /0.e0,.2250583347313904927138324e0/
!
  data dzero /0.d0/, done /1.d0/, dthree /3.d0/, dsix /6.d0/, &
   point5 /.5e0/
!
!       scale base vectors and obtain area.
!
  do i=1,2
    origin(i) = vec(i,3) + p(1)*vec(i,1) + p(2)*vec(i,2)
    do j=1,2
      tvec(i,j) = p(3)*vec(i,j)
    end do
  end do

  area = point5*abs(tvec(1,1)*tvec(2,2)-tvec(1,2)*tvec(2,1))
  a1 = dzero
  a2 = dzero
!
!       compute estimates for integral and error
!
  do 40 k=1,nquad
    x = origin(1) + w(1,k)*tvec(1,1) + w(2,k)*tvec(1,2)
    y = origin(2) + w(1,k)*tvec(2,1) + w(2,k)*tvec(2,2)
    s = dble(f(x,y,idata,rdata))
    sn = done
    if (w(1,k) == w(2,k)) go to 30
    x = origin(1) + w(2,k)*tvec(1,1) + w(1,k)*tvec(1,2)
    y = origin(2) + w(2,k)*tvec(2,1) + w(1,k)*tvec(2,2)
    s = s + dble(f(x,y,idata,rdata))
    x = origin(1) + w(2,k)*tvec(1,1) + w(3,k)*tvec(1,2)
    y = origin(2) + w(2,k)*tvec(2,1) + w(3,k)*tvec(2,2)
    s = s + dble(f(x,y,idata,rdata))
    sn = dthree
    if (w(2,k) == w(3,k)) go to 30
    x = origin(1) + w(1,k)*tvec(1,1) + w(3,k)*tvec(1,2)
    y = origin(2) + w(1,k)*tvec(2,1) + w(3,k)*tvec(2,2)
    s = s + dble(f(x,y,idata,rdata))
    x = origin(1) + w(3,k)*tvec(1,1) + w(1,k)*tvec(1,2)
    y = origin(2) + w(3,k)*tvec(2,1) + w(1,k)*tvec(2,2)
    s = s + dble(f(x,y,idata,rdata))
    x = origin(1) + w(3,k)*tvec(1,1) + w(2,k)*tvec(1,2)
    y = origin(2) + w(3,k)*tvec(2,1) + w(2,k)*tvec(2,2)
    s = s + dble(f(x,y,idata,rdata))
    sn = dsix
   30   s = s/sn
    a1 = a1 + w(4,k)*s
    a2 = a2 + w(5,k)*s
   40 continue
  p(4) = sngl(a1)*area
  p(5) = sngl(a2)*area
  p(6) = abs(p(5)-p(4))
  return
end
subroutine cubtri(f, t, eps, mcalls, ans, err, ncalls, w, nw, &
   idata, rdata, ier)
!
!*******************************************************************************
!
!! CUBTRI: adaptive cubature over a triangle
!
!       parameters
!          f     - user supplied external function of the form
!                  f(x,y,idata,rdata)
!                  where x and y are the cartesian coordinates of a
!                  point in the plane, and idata and rdata are integer
!                  and real vectors in which data may be passed.
!          t     - array of dimension (2,3) where t(1,j) and t(2,j)
!                  are the x and y coordinates of the j-th vertex of
!                  the given triangle (input)
!          eps   - required tolerance (input).  if the computed
!                  integral is between-1 and 1, an absolute error
!                  test is used, else a relative error test is used.
!          mcalls- maximum permitted number of calls to f (input)
!          ans   - estimate for the value of the integral of f over
!                  the given triangle (output)
!          err   - estimated absolute error in ans (output)
!          ncalls- actual number of calls to f (output).  this
!                  parameter must be initialized to 0 on the first
!                  call to cubtri for a given integral (input)
!          w     - work space.  may not be destroyed between calls to
!                  cubtri if restarting is intended
!          nw    - length of work space (input).
!                  if nw >= 3*(19+3*mcalls)/38, termination due to
!                  full work space will not occur.
!          ier   - termination indicator (output)
!                  ier=0   normal termination, tolerance satisfied
!                  ier=1   maximum number of calls reached
!                  ier=2   work space full
!                  ier=3   further subdivision of triangles impossible
!                  ier=4   no further improvement in accuracy is
!                        possible due to rounding errors in function
!                        values
!                  ier=5   no further improvement in accuracy is
!                        possible because subdivision does not
!                        change the estimated integral. machine
!                        accuracy has probably been reached but
!                        the error estimate is not sharp enough.
!
!       cubtri is designed to be called repeatedly without wasting
!       earlier work.  the parameter ncalls is used to indicate to
!       cubtri at what point to restart, and must be re-initialized
!       to 0 when a new integral is to be computed.  at least one of
!       the parameters eps, mcalls and nw must be changed between
!       calls to cubtri, according to the returned value of ier. none
!       of the other parameters may be changed if restarting is done.
!       if ier=3 is encountered, there probably is a singularity
!       somewhere in the region.  the error message indicates that
!       further subdivision is impossible because the vertices of the
!       smaller triangles produced will begin to coalesce to the
!       precision of the computer.  this situation can usually be
!       relieved by specifying the region in such a way that the
!       singularity is located at the third vertex of the triangle.
!       if ier=4 is encountered, the value of the integral cannot be
!       improved any further. the only exception to this occurs when a
!       function with highly irregular behaviour is integrated (e.g.
!       functions with jump discontinuities or very highly oscillatory
!       functions). in such a case the user can disable the rounding
!       error test by removing the if statement immediately preceding
!       statement number 90.
!
  external f
  integer idata(*), ier, mcalls, ncalls, nw
  real alfa, ans, anskp, area, eps, err, errmax, h, q1, q2, r1, r2, &
   rdata(*), d(2,4), s(4), t(2,*), vec(2,3), w(6,nw), x(2)
!       actual dimension of w is (6,nw/6)
!
  double precision tans, terr, dzero
  common /cubsta/ tans, terr
!       this common is required to preserve tans and terr between calls
!       and to save variables in function rnderr
  data nfe /19/, s(1), s(2), s(3), s(4) /3*1e0,-1e0/, d(1,1), &
   d(2,1) /0.0,0.0/, d(1,2), d(2,2) /0.0,1.0/, d(1,3), d(2,3) &
   /1.0,0.0/, d(1,4), d(2,4) /1.0,1.0/
!       nfe is the number of function evaluations per call to cubrul.
  data zero /0.e0/, one /1.e0/, dzero /0.d0/, point5 /.5e0/
!
!      calculate direction vectors, area and maximum number
!      of subdivisions that may be performed
  do 20 i=1,2
    vec(i,3) = t(i,3)
    do 10 j=1,2
      vec(i,j) = t(i,j) - t(i,3)
   10   continue
   20 continue
  maxc = (mcalls/nfe+3)/4
  ier = 1
  maxk = min (maxc,(nw/6+2)/3)
  if (maxc > maxk) ier = 2
  area = abs(vec(1,1)*vec(2,2)-vec(1,2)*vec(2,1))*point5
  k = (ncalls/nfe+3)/4
  mw = 3*(k-1) + 1
  if (ncalls > 0) go to 30
!
!       test for trivial cases
  tans = dzero
  terr = dzero
  if (area == zero) go to 90
  if (mcalls < nfe) go to 100
  if (nw < 6) go to 110
!
!       initialize data list
  k = 1
  mw = 1
  w(1,1) = zero
  w(2,1) = zero
  w(3,1) = one
  call cubrul(f, vec, w(1,1), idata, rdata)
  tans = w(5,1)
  terr = w(6,1)
  ncalls = nfe
!
!       test termination criteria
   30 ans = tans
  err = terr
  if (err < max ( one,abs(ans))*eps) go to 90
  if (k == maxk) go to 120
!
!       find triangle with largest error
  errmax = zero
  do 40 i=1,mw
    if (w(6,i) <= errmax) go to 40
    errmax = w(6,i)
    j = i
   40 continue
!
!       subdivide triangle into four subtriangles and update data list
  do 50 i=1,2
    x(i) = w(i,j)
   50 continue
  h = w(3,j)*point5
  if (rnderr(x(1),h,x(1),h)/=zero) go to 130
  if (rnderr(x(2),h,x(2),h)/=zero) go to 130
  anskp = sngl(tans)
  tans = tans - dble(w(5,j))
  terr = terr - dble(w(6,j))
  r1 = w(4,j)
  r2 = w(5,j)
  jkp = j
  q1 = zero
  q2 = zero
  do 70 i=1,4
    do 60 l=1,2
      w(l,j) = x(l) + h*d(l,i)
   60   continue
    w(3,j) = h*s(i)
    call cubrul(f, vec, w(1,j), idata, rdata)
    q2 = q2 + w(5,j)
    q1 = q1 + w(4,j)
    j = mw + i
   70 continue
  alfa = 1e15
  if (q2/=r2) alfa = abs((q1-r1)/(q2-r2)-one)
  j = jkp
  do 80 i=1,4
    w(6,j) = w(6,j)/alfa
    tans = tans + w(5,j)
    terr = terr + w(6,j)
    j = mw + i
   80 continue
  mw = mw + 3
  ncalls = ncalls + 4*nfe
  k = k + 1
!
!       if answer is unchanged, it cannot be improved
  if (anskp == sngl(tans)) go to 150
!
!       remove this if statement to disable rounding error test
  if (k > 3 .and. abs(q2-r2) > abs(q1-r1)) go to 140
  go to 30
!
!       exits from subroutine
   90 ier = 0
  go to 120
  100 ier = 1
  go to 120
  110 ier = 2
  120 ans = tans
  err = terr
  return
  130 ier = 3
  go to 120
  140 ier = 4
  go to 120
  150 ier = 5
  go to 120
end
subroutine curv1 (n,x,y,slp1,slpn,islpsw,yp,temp, &
                    sigma,ierr)
!
!*******************************************************************************
!
!! CURV1 determines the parameters necessary to
! compute an interpolatory spline under tension through
! a sequence of functional values. the slopes at the two
! ends of the curve may be specified or omitted.  for actual
! computation of points on the curve it is necessary to call
! the function curv2.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   n is the number of values to be interpolated (n >= 2).
!
!   x is an array of the n increasing abscissae of the
!   functional values.
!
!   y is an array of the n ordinates of the values, (i. e.
!   y(k) is the functional value corresponding to x(k) ).
!
!   slp1 and slpn contain the desired values for the first
!   derivative of the curve at x(1) and x(n), respectively.
!   the user may omit values for either or both of these
!   parameters and signal this with islpsw.
!
!   islpsw contains a switch indicating which slope data
!   should be used and which should be estimated by this
!   subroutine,
!          = 0 if slp1 and slpn are to be used,
!          = 1 if slp1 is to be used but not slpn,
!          = 2 if slpn is to be used but not slp1,
!          = 3 if both slp1 and slpn are to be estimated
!              internally.
!
!   yp is an array of length at least n.
!
!   temp is an array of length at least n which is used for
!   scratch storage.
!
! and
!
!   sigma contains the tension factor. this value indicates
!   the curviness desired. if abs(sigma) is nearly zero
!   (e.g. .001) the resulting curve is approximately a
!   cubic spline. if abs(sigma) is large (e.g. 50.) the
!   resulting curve is nearly a polygonal line. if sigma
!   equals zero a cubic spline results.  a standard value
!   for sigma is approximately 1. in absolute value.
!
! on output--
!
!   yp contains the values of the second derivative of the
!   curve at the given nodes.
!
!   ierr contains an error flag,
!        = 0 for normal return,
!        = 1 if n is less than 2,
!        = 2 if x-values are not strictly increasing.
!
! and
!
!   n, x, y, slp1, slpn, islpsw and sigma are unaltered.
!
! this subroutine references package modules ceez, terms,
! and snhcsh.
!
  integer n,islpsw,ierr
  real x(n),y(n),slp1,slpn,yp(n),temp(n),sigma
!
  nm1 = n-1
  np1 = n+1
  ierr = 0
  if (n <= 1) go to 8
  if (x(n) <= x(1)) go to 9
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/(x(n)-x(1))
!
! approximate end slopes
!
  if (islpsw >= 2) go to 1
  slpp1 = slp1
  go to 2
1 delx1 = x(2)-x(1)
  delx2 = delx1+delx1
  if (n > 2) delx2 = x(3)-x(1)
  if (delx1 <= 0. .or. delx2 <= delx1) go to 9
  call ceez (delx1,delx2,sigmap,c1,c2,c3,n)
  slpp1 = c1*y(1)+c2*y(2)
  if (n > 2) slpp1 = slpp1+c3*y(3)
2 if (islpsw == 1 .or. islpsw == 3) go to 3
  slppn = slpn
  go to 4
3 delxn = x(n)-x(nm1)
  delxnm = delxn+delxn
  if (n > 2) delxnm = x(n)-x(n-2)
  if (delxn <= 0. .or. delxnm <= delxn) go to 9
  call ceez (-delxn,-delxnm,sigmap,c1,c2,c3,n)
  slppn = c1*y(n)+c2*y(nm1)
  if (n > 2) slppn = slppn+c3*y(n-2)
!
! set up right hand side and tridiagonal system for yp and
! perform forward elimination
!
4 delx1 = x(2)-x(1)
  if (delx1 <= 0.) go to 9
  dx1 = (y(2)-y(1))/delx1
  call terms (diag1,sdiag1,sigmap,delx1)
  yp(1) = (dx1-slpp1)/diag1
  temp(1) = sdiag1/diag1
  if (n == 2) go to 6
  do 5 i = 2,nm1
    delx2 = x(i+1)-x(i)
    if (delx2 <= 0.) go to 9
    dx2 = (y(i+1)-y(i))/delx2
    call terms (diag2,sdiag2,sigmap,delx2)
    diag = diag1+diag2-sdiag1*temp(i-1)
    yp(i) = (dx2-dx1-sdiag1*yp(i-1))/diag
    temp(i) = sdiag2/diag
    dx1 = dx2
    diag1 = diag2
5   sdiag1 = sdiag2
6 diag = diag1-sdiag1*temp(nm1)
  yp(n) = (slppn-dx1-sdiag1*yp(nm1))/diag
!
! perform back substitution
!
  do 7 i = 2,n
    ibak = np1-i
7   yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
  return
!
! too few points
!
8 ierr = 1
  return
!
! x-values not strictly increasing
!
9 ierr = 2
  return
end
function curv2 (t,n,x,y,yp,sigma)
!
!*******************************************************************************
!
!! CURV2 interpolates a curve at a given point
! using a spline under tension. the subroutine curv1 should
! be called earlier to determine certain necessary
! parameters.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   t contains a real value to be mapped onto the interpo-
!   lating curve.
!
!   n contains the number of points which were specified to
!   determine the curve.
!
!   x and y are arrays containing the abscissae and
!   ordinates, respectively, of the specified points.
!
!   yp is an array of second derivative values of the curve
!   at the nodes.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, yp, and sigma should be input
! unaltered from the output of curv1.
!
! on output--
!
!   curv2 contains the interpolated value.
!
! none of the input parameters are altered.
!
! this function references package modules intrvl and
! snhcsh.
!
  integer n
  real t,x(n),y(n),yp(n),sigma
!
!
! determine interval
!
  im1 = intrvl(t,x,n)
  i = im1+1
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/(x(n)-x(1))
!
! set up and perform interpolation
!
  del1 = t-x(im1)
  del2 = x(i)-t
  dels = x(i)-x(im1)
  sum = (y(i)*del1+y(im1)*del2)/dels
  if (sigmap /= 0.) go to 1
  curv2 = sum-del1*del2*(yp(i)*(del1+dels)+yp(im1)* &
          (del2+dels))/(6.*dels)
  return
1 delp1 = sigmap*(del1+dels)/2.
  delp2 = sigmap*(del2+dels)/2.
  call snhcsh (sinhm1,dummy,sigmap*del1,-1)
  call snhcsh (sinhm2,dummy,sigmap*del2,-1)
  call snhcsh (sinhms,dummy,sigmap*dels,-1)
  call snhcsh (sinhp1,dummy,sigmap*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmap*del2/2.,-1)
  call snhcsh (dummy,coshp1,delp1,1)
  call snhcsh (dummy,coshp2,delp2,1)
  curv2 = sum+(yp(i)*(sinhm1*del2-del1*(2.*(coshp1+1.)* &
          sinhp2+sigmap*coshp1*del2))+yp(im1)*(sinhm2* &
          del1-del2*(2.*(coshp2+1.)*sinhp1+sigmap* &
          coshp2*del1)))/(sigmap*sigmap*dels*(sinhms+ &
          sigmap*dels))
  return
end
function curvd (t,n,x,y,yp,sigma)
!
!*******************************************************************************
!
!! CURVD differentiates a curve at a given point
! using a spline under tension. the subroutine curv1 should
! be called earlier to determine certain necessary
! parameters.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   t contains a real value at which the derivative is to be
!   determined.
!
!   n contains the number of points which were specified to
!   determine the curve.
!
!   x and y are arrays containing the abscissae and
!   ordinates, respectively, of the specified points.
!
!   yp is an array of second derivative values of the curve
!   at the nodes.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, yp, and sigma should be input
! unaltered from the output of curv1.
!
! on output--
!
!   curvd contains the derivative value.
!
! none of the input parameters are altered.
!
! this function references package modules intrvl and
! snhcsh.
!
  integer n
  real t,x(n),y(n),yp(n),sigma
!
!
! determine interval
!
  im1 = intrvl(t,x,n)
  i = im1+1
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/(x(n)-x(1))
!
! set up and perform differentiation
!
  del1 = t-x(im1)
  del2 = x(i)-t
  dels = x(i)-x(im1)
  sum = (y(i)-y(im1))/dels
  if (sigmap /= 0.) go to 1
  curvd = sum+(yp(i)*(2.*del1*del1-del2*(del1+dels))- &
               yp(im1)*(2.*del2*del2-del1*(del2+dels))) &
               /(6.*dels)
  return
1 call snhcsh (dummy,coshm1,sigmap*del1,1)
  call snhcsh (dummy,coshm2,sigmap*del2,1)
  call snhcsh (sinhms,dummy,sigmap*dels,-1)
  curvd = sum+(yp(i)*(dels*sigmap*coshm1-sinhms)- &
          yp(im1)*(dels*sigmap*coshm2-sinhms))/ &
          (sigmap*sigmap*dels*(sinhms+sigmap*dels))
  return
end
function curvi (xl,xu,n,x,y,yp,sigma)
!
!*******************************************************************************
!
!! CURVI integrates a curve specified by a spline
! under tension between two given limits. the subroutine
! curv1 should be called earlier to determine necessary
! parameters.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   xl and xu contain the lower and upper limits of inte-
!   gration, respectively. (xl need not be less than or
!   equal to xu, curvi (xl,xu,...) == -curvi (xu,xl,...) ).
!
!   n contains the number of points which were specified to
!   determine the curve.
!
!   x and y are arrays containing the abscissae and
!   ordinates, respectively, of the specified points.
!
!   yp is an array of second derivative values of the curve
!   at the nodes.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, yp, and sigma should be input
! unaltered from the output of curv1.
!
! on output--
!
!   curvi contains the integral value.
!
! none of the input parameters are altered.
!
! this function references package modules intrvl and
! snhcsh.
!
  integer n
  real xl,xu,x(n),y(n),yp(n),sigma
!--------
!
! statement function for coefficient associated with
! derivative terms
!
  term (cmm1,cmm2,t) = (cmm1-cmm2-sigmap*t*ss)/(sigmap* &
                       sigmap*sigmap*(ss+sigmap*dels))
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/(x(n)-x(1))
!
! determine actual upper and lower bounds
!
  xxl = xl
  xxu = xu
  ssign = 1.
  if (xl < xu) go to 1
  xxl = xu
  xxu = xl
  ssign = -1.
  if (xl > xu) go to 1
!
! return zero if xl == xu
!
  curvi = 0.
  return
!
! search for proper intervals
!
1 ilm1 = intrvl (xxl,x,n)
  il = ilm1+1
  ium1 = intrvl (xxu,x,n)
  iu = ium1+1
  if (il == iu) go to 8
!
! integrate from xxl to x(il)
!
  sum = 0.
  if (xxl == x(il)) go to 3
  del1 = xxl-x(ilm1)
  del2 = x(il)-xxl
  dels = x(il)-x(ilm1)
  t1 = (del1+dels)*del2/(2.*dels)
  t2 = del2*del2/(2.*dels)
  sum = t1*y(il)+t2*y(ilm1)
  if (sigma == 0.) go to 2
  call snhcsh (dummy,c1,sigmap*del1,2)
  call snhcsh (dummy,c2,sigmap*del2,2)
  call snhcsh (ss,cs,sigmap*dels,3)
  sum = sum+term(cs,c1,t1)*yp(il) &
           +term(c2,0.,t2)*yp(ilm1)
  go to 3
2 sum = sum-t1*t1*dels*yp(il)/6. &
           -t2*(del1*(del2+dels)+dels*dels)*yp(ilm1)/12.
!
! integrate over interior intervals
!
3 if (iu-il == 1) go to 6
  ilp1 = il+1
  do 5 i = ilp1,ium1
    dels = x(i)-x(i-1)
    sum = sum+(y(i)+y(i-1))*dels/2.
    if (sigma == 0.) go to 4
    call snhcsh (ss,cs,sigmap*dels,3)
    sum = sum+(yp(i)+yp(i-1))*(cs-ss*sigmap*dels/2.)/ &
              (sigmap*sigmap*sigmap*(ss+sigmap*dels))
    go to 5
4   sum = sum-(yp(i)+yp(i-1))*dels*dels*dels/24.
5   continue
!
! integrate from x(iu-1) to xxu
!
6 if (xxu == x(ium1)) go to 10
  del1 = xxu-x(ium1)
  del2 = x(iu)-xxu
  dels = x(iu)-x(ium1)
  t1 = del1*del1/(2.*dels)
  t2 = (del2+dels)*del1/(2.*dels)
  sum = sum+t1*y(iu)+t2*y(ium1)
  if (sigma == 0.) go to 7
  call snhcsh (dummy,c1,sigmap*del1,2)
  call snhcsh (dummy,c2,sigmap*del2,2)
  call snhcsh (ss,cs,sigmap*dels,3)
  sum = sum+term(c1,0.,t1)*yp(iu) &
           +term(cs,c2,t2)*yp(ium1)
  go to 10
7 sum = sum-t1*(del2*(del1+dels)+dels*dels)*yp(iu)/12. &
           -t2*t2*dels*yp(ium1)/6.
  go to 10
!
! integrate from xxl to xxu
!
8 delu1 = xxu-x(ium1)
  delu2 = x(iu)-xxu
  dell1 = xxl-x(ium1)
  dell2 = x(iu)-xxl
  dels = x(iu)-x(ium1)
  deli = xxu-xxl
  t1 = (delu1+dell1)*deli/(2.*dels)
  t2 = (delu2+dell2)*deli/(2.*dels)
  sum = t1*y(iu)+t2*y(ium1)
  if (sigma == 0.) go to 9
  call snhcsh (dummy,cu1,sigmap*delu1,2)
  call snhcsh (dummy,cu2,sigmap*delu2,2)
  call snhcsh (dummy,cl1,sigmap*dell1,2)
  call snhcsh (dummy,cl2,sigmap*dell2,2)
  call snhcsh (ss,dummy,sigmap*dels,-1)
  sum = sum+term(cu1,cl1,t1)*yp(iu) &
           +term(cl2,cu2,t2)*yp(ium1)
  go to 10
9 sum = sum-t1*(delu2*(dels+delu1)+dell2*(dels+dell1))* &
               yp(iu)/12. &
           -t2*(dell1*(dels+dell2)+delu1*(dels+delu2))* &
               yp(ium1)/12.
!
! correct sign and return
!
   10 curvi = ssign*sum
  return
end
subroutine cvbc(b,kb,m,n,ml,mu,a,ka)
!
!*******************************************************************************
!
!! CVBC: conversion of complex matrices from banded to standard form
!
  complex a(ka,n),b(kb,*)
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 20
  do 11 i = 1,ml
  jmax = min (n,i+mu)
    do 10 j = 1,jmax
    k = j - i + ml + 1
   10   a(i,j) = b(i,k)
   11 continue
!
!     store the remaining nonzero data
!
   20 imin = ml + 1
  imax = min (m,ml+n)
  do 22 i = imin,imax
  jmin = i - ml
  jmax = min (n,i+mu)
  j = jmax
    do 21 jj = jmin,jmax
    k = j - i + ml + 1
    a(i,j) = b(i,k)
   21   j = j - 1
   22 continue
!
!     insert zeros in the upper right corner
!
  jmin = mu + 2
  if (jmin > n) go to 40
  imax0 = 1
  do 31 j = jmin,n
    do 30 i = 1,imax0
   30   a(i,j) = (0.0,0.0)
   31 imax0 = min (imax,imax0+1)
!
!     insert zeros in the lower left corner
!
   40 if (imin == imax) go to 50
  jmax = imax - imin
  do 42 j = 1,jmax
  imin = imin + 1
    do 41 i = imin,imax
   41   a(i,j) = (0.0,0.0)
   42 continue
!
!     store zeros in the final m-imax rows
!
   50 if (imax == m) return
  imin = imax + 1
  do 52 j = 1,n
    do 51 i = imin,m
   51   a(i,j) = (0.0,0.0)
   52 continue
  return
end
subroutine cvbr(b,kb,m,n,ml,mu,a,ka)
!
!*******************************************************************************
!
!! CVBR: conversion of real matrices from banded to standard form
!
  real a(ka,n),b(kb,*)
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 20
  do 11 i = 1,ml
  jmax = min (n,i+mu)
    do 10 j = 1,jmax
    k = j - i + ml + 1
   10   a(i,j) = b(i,k)
   11 continue
!
!     store the remaining nonzero data
!
   20 imin = ml + 1
  imax = min (m,ml+n)
  do 22 i = imin,imax
  jmin = i - ml
  jmax = min (n,i+mu)
  j = jmax
    do 21 jj = jmin,jmax
    k = j - i + ml + 1
    a(i,j) = b(i,k)
   21   j = j - 1
   22 continue
!
!     insert zeros in the upper right corner
!
  jmin = mu + 2
  if (jmin > n) go to 40
  imax0 = 1
  do 31 j = jmin,n
    do 30 i = 1,imax0
   30   a(i,j) = 0.0
   31 imax0 = min (imax,imax0+1)
!
!     insert zeros in the lower left corner
!
   40 if (imin == imax) go to 50
  jmax = imax - imin
  do 42 j = 1,jmax
  imin = imin + 1
    do 41 i = imin,imax
   41   a(i,j) = 0.0
   42 continue
!
!     store zeros in the final m-imax rows
!
   50 if (imax == m) return
  imin = imax + 1
  do 52 j = 1,n
    do 51 i = imin,m
   51   a(i,j) = 0.0
   52 continue
  return
end
subroutine cvcb(a,ka,m,n,ml,mu,b,kb)
!
!*******************************************************************************
!
!! CVCB: conversion of complex matrices from standard to banded form
!     when ml and mu are given
!
  complex a(ka,n),b(kb,*)
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 30
  do 11 i = 1,ml
  jmax = min (n,i+mu)
  j = jmax
    do 10 jj = 1,jmax
    k = j - i + ml + 1
    b(i,k) = a(i,j)
   10   j = j - 1
   11 continue
!
!     insert zeros in the upper left corner
!
  imax = ml
  do 21 j = 1,ml
    do 20 i = 1,imax
   20   b(i,j) = (0.0,0.0)
   21 imax = imax - 1
!
!     store the remaining nonzero data
!
   30 imin = ml + 1
  imax = min (m,ml+n)
  do 32 i = imin,imax
  jmin = i - ml
  jmax = min (n,i+mu)
    do 31 j = jmin,jmax
    k = j - i + ml + 1
   31   b(i,k) = a(i,j)
   32 continue
!
!     insert zeros in the lower right corner
!
  jmax = ml + mu + 1
  if (k == jmax) go to 50
  jmin = k + 1
  imin = imax
  do 41 j = jmin,jmax
    do 40 i = imin,imax
   40   b(i,j) = (0.0,0.0)
   41 imin = imin - 1
!
!     store zeros in the final m-imax rows
!
   50 if (imax == m) return
  imin = imax + 1
  do 52 j = 1,jmax
    do 51 i = imin,m
   51   b(i,j) = (0.0,0.0)
   52 continue
  return
end
subroutine cvcb1(a,ka,m,n,ml,mu,b,kb,nb,ierr)
!
!*******************************************************************************
!
!! CVCB1: conversion of complex matrices from standard to banded form
!
  complex a(ka,n),b(kb,nb)
  complex zero
!     -----------------
  data zero /(0.0,0.0)/
!     -----------------
!
!     computation of ml and mu
!
  n1 = n - 1
  imin = m
  do 11 l = 2,m
  j = 1
  imax = min (m,imin+n1)
     do 10 i = imin,imax
     if (a(i,j) /= zero) go to 20
   10    j = j + 1
   11 imin = imin - 1
!
   20 m1 = m - 1
  jmin = n
  do 22 l = 2,n
  i = 1
  jmax = min (n,jmin+m1)
     do 21 j = jmin,jmax
     if (a(i,j) /= zero) go to 30
   21    i = i + 1
   22 jmin = jmin - 1
!
   30 ml = imin - 1
  mu = jmin - 1
  kmax = ml + mu + 1
  if (kmax > nb) go to 40
!
!     store the matrix in b
!
  ierr = 0
  call cvcb(a,ka,m,n,ml,mu,b,kb)
  return
!
!     error return
!
   40 ierr = kmax
  return
end
subroutine cvcs (a, ka, m, n, b, ib, jb, num, ierr)
!
!*******************************************************************************
!
!! CVCS: ???
!
  complex a(ka,n), b(*), zero
  integer ib(*), jb(*)
  data zero /(0.0,0.0)/
!
!                 store the i-th row
!
  ip = 1
  do 11 i = 1,m
     ib(i) = ip
     do 10 j = 1,n
        if (a(i,j) == zero) go to 10
        if (ip > num) go to 20
        b(ip) = a(i,j)
        jb(ip) = j
        ip = ip + 1
   10    continue
   11 continue
!
!                 complete the setup
!
  ib(m + 1) = ip
  ierr = 0
  return
!
!                   error return
!
   20 ierr = i
  return
end
subroutine cvds (a, ka, m, n, b, ib, jb, num, ierr)
!
!*******************************************************************************
!
!! CVDS: ???
!
  double precision a(ka,n), b(*)
  integer ib(*), jb(*)
!
!                 store the i-th row
!
  ip = 1
  do 11 i = 1,m
     ib(i) = ip
     do 10 j = 1,n
        if (a(i,j) == 0.d0) go to 10
        if (ip > num) go to 20
        b(ip) = a(i,j)
        jb(ip) = j
        ip = ip + 1
   10    continue
   11 continue
!
!                 complete the setup
!
  ib(m + 1) = ip
  ierr = 0
  return
!
!                   error return
!
   20 ierr = i
  return
end
subroutine cvprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! CVPRD: product of a sparse matrix and a vector
!
  complex a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = (0.0, 0.0)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
   10    continue
   11 y(i) = sum
  return
end
subroutine cvprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! CVPRD1: set y = a*x + y where a is a sparse matrix and x,y are vectors
!
  complex a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = y(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
   10    continue
   11 y(i) = sum
  return
end
subroutine cvrb(a,ka,m,n,ml,mu,b,kb)
!
!*******************************************************************************
!
!! CVRB: conversion of real matrices from standard to banded form
!     when ml and mu are given
!
  real a(ka,n)
  real b(kb,*)
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 30
  do 11 i = 1,ml
  jmax = min (n,i+mu)
  j = jmax
    do 10 jj = 1,jmax
    k = j - i + ml + 1
    b(i,k) = a(i,j)
   10   j = j - 1
   11 continue
!
!     insert zeros in the upper left corner
!
  imax = ml
  do 21 j = 1,ml
    do 20 i = 1,imax
   20   b(i,j) = 0.0
   21 imax = imax - 1
!
!     store the remaining nonzero data
!
   30 imin = ml + 1
  imax = min (m,ml+n)
  do 32 i = imin,imax
  jmin = i - ml
  jmax = min (n,i+mu)
    do 31 j = jmin,jmax
    k = j - i + ml + 1
   31   b(i,k) = a(i,j)
   32 continue
!
!     insert zeros in the lower right corner
!
  jmax = ml + mu + 1
  if (k == jmax) go to 50
  jmin = k + 1
  imin = imax
  do 41 j = jmin,jmax
    do 40 i = imin,imax
   40   b(i,j) = 0.0
   41 imin = imin - 1
!
!     store zeros in the final m-imax rows
!
   50 if (imax == m) return
  imin = imax + 1
  do 52 j = 1,jmax
    do 51 i = imin,m
   51   b(i,j) = 0.0
   52 continue
  return
end
subroutine cvrb1(a,ka,m,n,ml,mu,b,kb,nb,ierr)
!
!*******************************************************************************
!
!! CVRB1: conversion of real matrices from standard to banded form
!
  real a(ka,n),b(kb,nb)
!
!     computation of ml and mu
!
  n1 = n - 1
  imin = m
  do 11 l = 2,m
  j = 1
  imax = min (m,imin+n1)
     do 10 i = imin,imax
     if (a(i,j) /= 0.0) go to 20
   10    j = j + 1
   11 imin = imin - 1
!
   20 m1 = m - 1
  jmin = n
  do 22 l = 2,n
  i = 1
  jmax = min (n,jmin+m1)
     do 21 j = jmin,jmax
     if (a(i,j) /= 0.0) go to 30
   21    i = i + 1
   22 jmin = jmin - 1
!
   30 ml = imin - 1
  mu = jmin - 1
  kmax = ml + mu + 1
  if (kmax > nb) go to 40
!
!     store the matrix in b
!
  ierr = 0
  call cvrb(a,ka,m,n,ml,mu,b,kb)
  return
!
!     error return
!
   40 ierr = kmax
  return
end
subroutine cvrs (a, ka, m, n, b, ib, jb, num, ierr)
!
!*******************************************************************************
!
!! CVRS: ???
!
  real a(ka,n), b(*)
  integer ib(*), jb(*)
!
!                 store the i-th row
!
  ip = 1
  do 11 i = 1,m
     ib(i) = ip
     do 10 j = 1,n
        if (a(i,j) == 0.0) go to 10
        if (ip > num) go to 20
        b(ip) = a(i,j)
        jb(ip) = j
        ip = ip + 1
   10    continue
   11 continue
!
!                 complete the setup
!
  ib(m + 1) = ip
  ierr = 0
  return
!
!                   error return
!
   20 ierr = i
  return
end
subroutine cvsc (a, ia, ja, b, kb, m, n)
!
!*******************************************************************************
!
!! CVSC ???
!
  complex a(*), b(kb,n)
  integer ia(*), ja(*)
!
  do 30 i = 1,m
!
!                 clear the i-th row
!
     do 10 j = 1,n
        b(i,j) = (0.0,0.0)
   10    continue
!
!                 store the i-th row
!
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 30
     do 20 ip = ipmin,ipmax
        j = ja(ip)
        b(i,j) = a(ip)
   20    continue
!
   30 continue
  return
end
subroutine cvsd (a, ia, ja, b, kb, m, n)
!
!*******************************************************************************
!
!! CVSD: ???
!
  double precision a(*), b(kb,n)
  integer ia(*), ja(*)
!
  do 30 i = 1,m
!
!                 clear the i-th row
!
     do 10 j = 1,n
        b(i,j) = 0.d0
   10    continue
!
!                 store the i-th row
!
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 30
     do 20 ip = ipmin,ipmax
        j = ja(ip)
        b(i,j) = a(ip)
   20    continue
!
   30 continue
  return
end
subroutine cvsr (a, ia, ja, b, kb, m, n)
!
!*******************************************************************************
!
!! CVSR: ???
!
  real a(*), b(kb,n)
  integer ia(*), ja(*)
!
  do 30 i = 1,m
!
!                 clear the i-th row
!
     do 10 j = 1,n
        b(i,j) = 0.0
   10    continue
!
!                 store the i-th row
!
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 30
     do 20 ip = ipmin,ipmax
        j = ja(ip)
        b(i,j) = a(ip)
   20    continue
!
   30 continue
  return
end
function cxp (n, nu)
!
!*******************************************************************************
!
!! CXP: computation of exp(-r*(pi/2)*i)
!              where r = n + nu for abs(nu) <= 0.5
!
  complex cxp
  real nu
!
  c = cos0(nu)
  s = sin0(nu)
  k = mod(n,4)
  if (k == 0) go to 10
  if (k == 1) go to 20
  if (k == 2) go to 30
  go to 40
!
   10 cxp = cmplx (c, -s)
  return
!
   20 cxp = cmplx (-s, -c)
  return
!
   30 cxp = cmplx (-c, s)
  return
!
   40 cxp = cmplx (s, c)
  return
end
subroutine cychg (x, y, yold)
!
!*******************************************************************************
!
!! CYCHG ???
!
  complex x(*), y(*), yold
  complex zero, one
  data zero/(0.0,0.0)/, one/(1.0,0.0)/
!
  y(1) = zero
  if (yold == zero) y(1) = one
  return
end
subroutine dabslv (mo,m,n,a,na,b,nb,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! DABSLV solves the real matrix equation ax + xb = c.
!
!
!  a is reduced to lower schur form, b is reduced to upper schur form, and the
!     transformed system is solved by back substitution.
!
!        mo is an input argument which specifies if the routine is
!     being called for the first time. on an initial call mo = 0 and
!     we have the following setup.
!
!        a(na,m)
!           a is a matrix of order m. it is assumed that
!           na >= m >= 1.
!
!        b(nb,n)
!           b is a matrix of order n. it is assumed that
!           nb >= n >= 1.
!
!        c(nc,n)
!           c is a matrix having m rows and n columns.
!           it is assumed that nc >= m.
!
!        wk(---)
!           wk is an array of dimension m**2  + n**2 + 2k
!           where k = max(m,n). wk is a general storage
!           area for the routine.
!
!     ierr is a variable that reports the status of the results. when
!     the routine terminates, ierr has one of the following values...
!
!        ierr =  0  the solution was obtained and stored in c.
!        ierr =  1  the equations are inconsistent for a and b.
!                   the problem cannot be solved.
!        ierr = -1  a could not be reduced to lower schur form.
!                   the problem cannot be solved.
!        ierr = -2  b could not be reduced to upper schur form.
!                   the problem cannot be solved.
!
!     when ierr = 0, a contains the lower schur form of the matrix a,
!     b contains the upper schur form of the matrix b, and wk contains
!     the orthonal matrices involved in the schur decompositions of
!     a and b. this information can be reused to solve a new set of
!     equations ax + xb = c without having to redecompose a and b.
!     the following options are available...
!
!        mo = 1      new matrices a and c are given. the data for b
!                    is reused in solving the new set of equations.
!
!        mo = 2      new matrices b and c are given. the data for a
!                    is reused in solving the new set of equations.
!
!     mo /= 0,1,2  a new matrix c is given. the data for a and b
!                    is reused in solving the new set of equations.
!
!     when dabslv is recalled, it is assumed that m, n, and wk have
!     not been modified.
!
!     this subroutine is a modification by
!        Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!     of the subroutine axpxb written by
!        r.h. bartels and g.w.stewart
!        university of texas at austin.
!
!     reference. bartels, r.h. and stewart, g.w., algorithm 432,
!        solution of the matrix equation ax + xb = c, comm. acm
!        15 (1972), pp. 820-826.
!
  double precision a(na,m), b(nb,n), c(nc,n), wk(*)
!
  iu = 1
  iv = m*m + 1
  iw = n*n + iv
  call dabsv1 (mo,m,n,a,na,wk(iu),m,b,nb,wk(iv),n, &
                  c,nc,wk(iw),ierr)
  return
end
subroutine dabsv1 (mo,m,n,a,na,u,nu,b,nb,v,nv,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! DABSV1 solves the real matrix equation ax + xb = c.
!
!
!  a is reduced to lower schur form, b is reduced to upper schur form, and the
!     transformed system is solved by back substitution.
!
  double precision a(na,m), b(nb,n), c(nc,n)
  double precision u(nu,m), v(nv,n), temp, wk(*)
!
!     if required, reduce a to lower real schur form
!
  if (mo /= 0 .and. mo /= 1) go to 35
  do 11 i = 1,m
     do j = i,m
        temp = a(i,j)
        a(i,j) = a(j,i)
        a(j,i) = temp
     end do
   11 continue
  call dorth (na,m,1,m,a,wk)
  call drtrn1 (m,1,m,a,na,u,nu,wk)
!
  if (m == 1) go to 20
  call dschur (m,1,m,a,na,u,nu,wk(1),wk(m+1),ierr)
  if (ierr /= 0) go to 200
!
   20 do 31 i = 1,m
     do 30 j = i,m
        temp = a(i,j)
        a(i,j) = a(j,i)
        a(j,i) = temp
   30    continue
   31 continue
!
!     if required, reduce b to upper real schur form
!
   35 if (mo /= 0 .and. mo /= 2) go to 45
  call dorth (nb,n,1,n,b,wk)
  call drtrn1 (n,1,n,b,nb,v,nv,wk)
!
  if (n == 1) go to 45
  call dschur (n,1,n,b,nb,v,nv,wk(1),wk(n+1),ierr)
  if (ierr /= 0) go to 210
!
!     transform c
!
   45 do 61 j = 1,n
     do 51 i = 1,m
        wk(i) = 0.d0
        do 50 k = 1,m
           wk(i) = wk(i) + u(k,i)*c(k,j)
   50       continue
   51    continue
     do 60 i = 1,m
        c(i,j) = wk(i)
   60    continue
   61 continue
!
  do 81 i = 1,m
     do 71 j = 1,n
        wk(j) = 0.d0
        do 70 k = 1,n
           wk(j) = wk(j) + c(i,k)*v(k,j)
   70       continue
   71    continue
     do 80 j = 1,n
        c(i,j) = wk(j)
   80    continue
   81 continue
!
!     solve the transformed system
!
  call dshslv (a,b,c,m,n,na,nb,nc,ierr)
  if (ierr /= 0) go to 220
!
!     transform c back to the solution
!
  do 101 j = 1,n
     do 91 i = 1,m
        wk(i) = 0.d0
        do 90 k = 1,m
           wk(i) = wk(i) + u(i,k)*c(k,j)
   90       continue
   91    continue
     do 100 i = 1,m
        c(i,j) = wk(i)
  100    continue
  101 continue
!
  do 121 i = 1,m
     do 111 j = 1,n
        wk(j) = 0.d0
        do 110 k = 1,n
           wk(j) = wk(j) + c(i,k)*v(j,k)
  110       continue
  111    continue
     do 120 j = 1,n
        c(i,j) = wk(j)
  120    continue
  121 continue
  return
!
!     error return
!
  200 ierr = -1
  return
  210 ierr = -2
  return
  220 ierr = 1
  return
end
subroutine daord (a, n)
!
!*******************************************************************************
!
!! DAORD is used to reorder the elements of the double precision array a
!  so that dabs(a(i)) <= dabs(a(i+1)) for i = 1,...,n-1.
!     it is assumed that n >= 1.
!
  double precision a(n), s
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that dabs(a(j)) <= dabs(a(j+ki))
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if (dabs(s) >= dabs(a(l))) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31    a(ll) = s
!
   40 i = i - 1
  return
end
double precision function dartnq(y,x)
!
!*******************************************************************************
!
!! DARTNQ ???
!
  double precision x,y
  if (x) 1,2,5
1 dartnq=datan(y/x)+3.14159265358979323846264338328d0
  return
2 if (y) 3,8,4
3 dartnq=4.71238898038468985769396507492d0
  return
4 dartnq=1.57079632679489661923132169164d0
  return
5 if (y) 6,8,7
6 dartnq=datan(y/x)+6.28318530717958647692528676656d0
  return
7 dartnq=datan(y/x)
  return
8 dartnq=0.d0
  return
end
function dasum(n,dx,incx)
!
!*******************************************************************************
!
!! DASUM takes the sum of the absolute values.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dasum
  double precision dx(*),dtemp
  integer i,incx,m,mp1,n,nincx
!
  dasum = 0.0d0
  dtemp = 0.0d0
  if(n <= 0)return
  if(incx==1)go to 20
!
!        code for increment not equal to 1
!
  nincx = n*incx
  do 10 i = 1,nincx,incx
    dtemp = dtemp + dabs(dx(i))
   10 continue
  dasum = dtemp
  return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,6)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dtemp = dtemp + dabs(dx(i))
   30 continue
  if( n < 6 ) go to 60
   40 mp1 = m + 1
  do 50 i = mp1,n,6
    dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) &
    + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
   50 continue
   60 dasum = dtemp
  return
end
function dawson ( x )
!
!*******************************************************************************
!
!! DAWSON computes single precision values of dawsons integral,
!
!        exp(-x*x) * integral (from 0 to x) exp(t*t) dt,
!
!     defined for all real arguments.
!
!     the main computation involves evaluation of rational chebyshev
!     approximations published in math. comp. 24, 171-178(1970) by
!     cody, paciorek and thacher.
!
!
  real dawson
  real p1(9),q1(9),p2(8),q2(7),p3(8),q3(7),p4(7),q4(6), &
       frac,sump,sumq,w2,x,y,xlarge,xsmall
!
  data xlarge/16777216.0/, xsmall/.59604644775391e-07/
!
!
!           coefficients for r(8,8) approximation,
!           used for abs(x)  <  2.5
!
!
  data p1(1)/.100000000000000e+01/, p1(2)/-.135599049815353e+00/, &
       p1(3)/.456738974064825e-01/, p1(4)/-.258323495918050e-02/, &
       p1(5)/.360079463580992e-03/, p1(6)/-.944375029163387e-05/, &
       p1(7)/.634674256878843e-06/, p1(8)/-.711645839183817e-08/, &
       p1(9)/.977985913592343e-10/
  data q1(1)/.100000000000000e+01/, q1(2)/.531067616851310e+00/, &
       q1(3)/.133052308640737e+00/, q1(4)/.206907491644210e-01/, &
       q1(5)/.220437428972266e-02/, q1(6)/.166706801664365e-03/, &
       q1(7)/.887964712053131e-05/, q1(8)/.311750854173480e-06/, &
       q1(9)/.574807177698046e-08/
!
!
!           coefficients for r(7,7) approximation,
!           in j-fraction form, used for
!           2.5 <= abs(x) < 3.5
!
!
  data p2(1)/-.150695651187161e+01/, p2(2)/ .293365747395449e+02/, &
       p2(3)/-.400000893643550e+02/, p2(4)/-.757931918089369e-01/, &
       p2(5)/-.889106479747812e+01/, p2(6)/ .152644099623699e+02/, &
       p2(7)/-.597678086823489e+01/, p2(8)/ .500236896088668e+00/
  data q2(1)/-.673106069744813e+00/, q2(2)/ .124486788262252e+04/, &
       q2(3)/ .721193217600229e+01/, q2(4)/ .112461662024575e+03/, &
       q2(5)/ .729177556415532e+02/, q2(6)/ .115840292551888e+03/, &
       q2(7)/ .226064666074309e+00/
!
!
!           coefficients for r(7,7) approximation,
!           in j-fraction form, used for
!           3.5 <= abs(x) <= 5.0
!
!
  data p3(1)/ .476405645273229e+01/, p3(2)/-.266167674896399e+02/, &
       p3(3)/-.916804879813552e+01/, p3(4)/-.150507703496692e+02/, &
       p3(5)/ .506460153742231e+01/, p3(6)/-.498544802986608e+01/, &
       p3(7)/-.149838042036691e+01/, p3(8)/ .499999902705054e+00/
  data q3(1)/ .287776122973187e+03/, q3(2)/ .256105722342226e+02/, &
       q3(3)/ .751701277744067e+02/, q3(4)/ .146515167783109e+03/, &
       q3(5)/ .330707724676114e+02/, q3(6)/-.148715811787195e+01/, &
       q3(7)/ .250011459611839e+00/
!
!
!           coefficients for r(6,6) approximation,
!           in j-fraction form, used for abs(x) > 5.0
!
!
  data p4(1)/-.315576735766984e+02/, p4(2)/-.100791496592972e+02/, &
       p4(3)/-.710713709224200e+01/, p4(4)/-.596879853243925e+01/, &
       p4(5)/-.449773645376092e+01/, p4(6)/-.249999965398199e+01/, &
       p4(7)/ .499999999999330e+00/
  data q4(1)/ .168874162155616e+03/, q4(2)/ .698280748271071e+01/, &
       q4(3)/-.213029621139181e+02/, q4(4)/-.712157348463305e+01/, &
       q4(5)/-.250005973192356e+01/, q4(6)/ .750000000715687e+00/
!
  if (abs(x) > xlarge) go to 500
  if (abs(x) < xsmall) go to 600
  y = x * x
  if (y >= 6.25e0) go to 200
!
! abs(x) < 2.5
!
  sump = (((((((p1(9) * y + p1(8)) * y + p1(7)) * y + p1(6)) &
          * y + p1(5)) * y + p1(4)) * y + p1(3)) * y + p1(2)) &
          * y + p1(1)
  sumq = (((((((q1(9) * y + q1(8)) * y + q1(7)) * y + q1(6)) &
          * y + q1(5)) * y + q1(4)) * y + q1(3)) * y + q1(2)) &
          * y + q1(1)
  dawson = x * sump / sumq
  return
!
! 2.5 <= abs(x) < 3.5
!
  200 if (y >= 12.25e0) go to 300

  frac = 0.0e0
  do i = 1, 7
    frac = q2(i) / (p2(i) + y + frac)
  end do
  dawson = (p2(8) + frac) / x
  return
!
! 3.5 <= abs(x) < 5.0
!
  300 if (y >= 25.0e0) go to 400
  frac = 0.0e0
!
  do 320 i = 1, 7
  320 frac = q3(i) / (p3(i) + y + frac)
!
  dawson = (p3(8) + frac) / x
  return
!
! 5.0 <= abs(x) <= xlarge
!
  400 w2 = 1.0e0 / x / x
  frac = 0.0e0
!
  do 420 i = 1, 6
  420 frac = q4(i) / (p4(i) + y + frac)
!
  frac = p4(7) + frac
  dawson = (0.5e0 + 0.5e0 * w2 * frac) / x
  return
!
! xlarge < abs(x)
!
  500 dawson = 0.5e0 / x
  return
!
! return for small x
!
  600 dawson = x

 1000 return
end
subroutine dawson_values ( n, x, fx )
!
!*******************************************************************************
!
!! DAWSON_VALUES returns some values of Dawson's integral for testing.
!
!
!  Modified:
!
!    25 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 21
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
  0.0000000000E+00, 0.0993359924E+00, 0.1947510334E+00, 0.2826316650E+00, &
  0.3599434819E+00, 0.4244363835E+00, 0.4747632037E+00, 0.5105040576E+00, &
  0.5321017071E+00, 0.5407243187E+00, 0.5380795069E+00, 0.5262066800E+00, &
  0.5072734964E+00, 0.4833975174E+00, 0.4565072375E+00, 0.4282490711E+00, &
  0.3999398943E+00, 0.3725593490E+00, 0.3467727691E+00, 0.3229743193E+00, &
  0.3013403889E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00, &
    0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00, &
    0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00, &
    1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00, &
    1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00, &
    2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine daxpy(n,da,dx,incx,dy,incy)
!
!*******************************************************************************
!
!! DAXPY: constant times a vector plus a vector.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dx(*),dy(*),da
  integer i,incx,incy,ix,iy,m,mp1,n
!
  if(n <= 0)return
  if (da == 0.0d0) return
  if(incx==1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    dy(iy) = dy(iy) + da*dx(ix)
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,4)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dy(i) = dy(i) + da*dx(i)
   30 continue
  if( n < 4 ) return
   40 mp1 = m + 1
  do 50 i = mp1,n,4
    dy(i) = dy(i) + da*dx(i)
    dy(i + 1) = dy(i + 1) + da*dx(i + 1)
    dy(i + 2) = dy(i + 2) + da*dx(i + 2)
    dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
  return
end
subroutine dbabk(nm,n,low,igh,scale,m,z)
!
!*******************************************************************************
!
!! DBABK forms the eigenvectors of a real general matrix by back transforming
!  those of the corresponding balanced matrix determined by dbal.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by dbal,
!
!        scale contains information determining the permutations
!          and scaling factors used by dbal,
!
!        m is the number of columns of z to be back transformed,
!
!        z contains the real and imaginary parts of the eigen-
!          vectors to be back transformed in its first m columns.
!
!     on output-
!
!        z contains the real and imaginary parts of the
!          transformed eigenvectors in its first m columns.
!
  integer i,j,k,m,n,ii,nm,igh,low
  double precision scale(n),z(nm,m)
  double precision s
!
!
  if (m == 0) go to 200
  if (igh == low) go to 120
!
  do 110 i = low, igh
     s = scale(i)
!    left hand eigenvectors are back transformed
!                if the foregoing statement is replaced by
!                s=1.0/scale(i).
     do 100 j = 1, m
  100    z(i,j) = z(i,j) * s
!
  110 continue
!      for i=low-1 step -1 until 1,
!               igh+1 step 1 until n do
  120 do 140 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 140
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 140
!
     do 130 j = 1, m
        s = z(i,j)
        z(i,j) = z(k,j)
        z(k,j) = s
  130    continue
!
  140 continue
!
  200 return
end
subroutine dbal(nm,n,a,low,igh,scale)
!
!*******************************************************************************
!
!! DBAL balances a double precision real matrix and isolates eigenvalues.
!
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        a contains the input matrix to be balanced.
!
!     on output-
!
!        a contains the balanced matrix,
!
!        low and igh are two integers such that a(i,j)
!          is equal to zero if
!           (1) i is greater than j and
!           (2) j=1,...,low-1 or i=igh+1,...,n,
!
!        scale contains information determining the
!           permutations and scaling factors used.
!
!     suppose that the principal submatrix in rows low through igh
!     has been balanced, that p(j) denotes the index interchanged
!     with j during the permutation step, and that the elements
!     of the diagonal matrix used are denoted by d(i,j).  then
!        scale(j) = p(j),    for j = 1,...,low-1
!                 = d(j,j),      j = low,...,igh
!                 = p(j)         j = igh+1,...,n.
!     the order in which the interchanges are made is n to igh+1,
!     then 1 to low-1.
!
!     note that 1 is returned for igh if igh is zero formally.
!
!     the algol procedure exc contained in balance appears in
!     dbal in line.  (note that the algol roles of identifiers
!     k,l have been reversed.)
!
  integer i,j,k,l,m,n,jj,nm,igh,low,iexc
  double precision a(nm,n),scale(n)
  double precision c,f,g,r,s,b2,radix
  integer ipmpar
!     double precision dabs
  logical noconv
!
!
!
!    radix is a machine dependent parameter specifying
!                the base of the machine floating point representation.
!
             radix = ipmpar(4)
!
!
!
  b2 = radix * radix
  k = 1
  l = n
  go to 100
!    in-line procedure for row and
!                column exchange
   20 scale(m) = j
  if (j == m) go to 50
!
  do 30 i = 1, l
     f = a(i,j)
     a(i,j) = a(i,m)
     a(i,m) = f
   30 continue
!
  do 40 i = k, n
     f = a(j,i)
     a(j,i) = a(m,i)
     a(m,i) = f
   40 continue
!
   50 go to (80,130), iexc
!    search for rows isolating an eigenvalue
!                and push them down
   80 if (l == 1) go to 280
  l = l - 1
!    for j=l step -1 until 1 do
  100 do 120 jj = 1, l
     j = l + 1 - jj
!
     do 110 i = 1, l
        if (i == j) go to 110
        if (a(j,i) /= 0.d0) go to 120
  110    continue
!
     m = l
     iexc = 1
     go to 20
  120 continue
!
  go to 140
!    search for columns isolating an eigenvalue
!                and push them left
  130 k = k + 1
!
  140 do 170 j = k, l
!
     do 150 i = k, l
        if (i == j) go to 150
        if (a(i,j) /= 0.d0) go to 170
  150    continue
!
     m = k
     iexc = 2
     go to 20
  170 continue
!    now balance the submatrix in rows k to l
  do 180 i = k, l
  180 scale(i) = 1.d0
!    iterative loop for norm reduction
  190 noconv = .false.
!
  do 270 i = k, l
     c = 0.d0
     r = 0.d0
!
     do 200 j = k, l
        if (j == i) go to 200
        c = c + dabs(a(j,i))
        r = r + dabs(a(i,j))
  200    continue
!    guard against zero c or r due to underflow
     if (c == 0.d0 .or. r == 0.d0) go to 270
     g = r / radix
     f = 1.d0
     s = c + r
  210    if (c >= g) go to 220
     f = f * radix
     c = c * b2
     go to 210
  220    g = r * radix
  230    if (c < g) go to 240
     f = f / radix
     c = c / b2
     go to 230
!    now balance
  240    if ((c + r) / f >= 0.95d0 * s) go to 270
     g = 1.d0 / f
     scale(i) = scale(i) * f
     noconv = .true.
!
     do 250 j = k, n
  250    a(i,j) = a(i,j) * g
!
     do 260 j = 1, l
  260    a(j,i) = a(j,i) * f
!
  270 continue
!
  if (noconv) go to 190
!
  280 low = k
  igh = l
  return
end
subroutine dbalnv (nz,n,z,low,igh,scale)
!
!*******************************************************************************
!
!! DBALNV ???
!
!
!        given a matrix a of order n. dbal transforms a into
!     the matrix b by the similarity transformation
!             b = d**(-1)*transpose(p)*a*p*d
!     where d is a diagonal matrix and p a permutation matrix.
!     the information concerning d and p is stored in igh, low,
!     and scale. the order in which the interchanges were made
!     is n to igh + 1, and then 1 to low - 1.
!
!        z is a matrix of order n. dbalnv transforms z into the
!     matrix w using the inverse similarity transform
!             w = p*d*z*d**(-1)*transpose(p)
!
!     on input-
!
!        nz is the row dimension of the matrix z in the calling
!          program,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by  dbal,
!
!        scale contains information determining the permutations
!          and scaling factors used by  dbal,
!
!     on output-
!
!        z contains the transformed matrix w
!
  integer i,j,k,n,ii,nz,igh,low
  double precision z(nz,n),scale(n)
  double precision s
!
!
  if (igh == low) go to 30
!
  do 11 i = low, igh
  s = scale(i)
     do 10 j = 1, n
   10    z(i,j) = z(i,j) * s
   11 continue
!
  do 21 j = low, igh
  s = 1.d0/scale(j)
     do 20 i = 1, n
   20    z(i,j) = z(i,j) * s
   21 continue
!
!      for i=low-1 step -1 until 1,
!               igh+1 step 1 until n do
!
   30 do 60 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 60
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 60
!
     do 40 j = 1, n
        s = z(i,j)
        z(i,j) = z(k,j)
   40       z(k,j) = s
!
     do 50 j = 1, n
        s = z(j,i)
        z(j,i) = z(j,k)
   50       z(j,k) = s
   60 continue
  return
end
function dbcorr (a0, b0)
!
!*******************************************************************************
!
!! DBCORR: evaluation of del(a) + del(b0) - del(a) + b0)
!   where
!     ln(gamma(x)) = (x - 0.5)*ln(x) - x + 0.5*ln(2*pi) + del(x).
!     it is assumed that a0 >= 10 and b0 >= 10.
!
!
!     the series for del(x), which applies for x >= 10, was
!     derived by a.h. morris from the chebyshev series in the
!     slatec library obtained by wayne fullerton (los alamos).
!
!
  double precision a0, b0
  double precision a, b, c
  double precision dbcorr 
  double precision e(15), h, s(15), t, w, x, x2, z
!
  data e(1)  / .833333333333333333333333333333d-01/, &
       e(2)  /-.277777777777777777777777752282d-04/, &
       e(3)  / .793650793650793650791732130419d-07/, &
       e(4)  /-.595238095238095232389839236182d-09/, &
       e(5)  / .841750841750832853294451671990d-11/, &
       e(6)  /-.191752691751854612334149171243d-12/, &
       e(7)  / .641025640510325475730918472625d-14/, &
       e(8)  /-.295506514125338232839867823991d-15/, &
       e(9)  / .179643716359402238723287696452d-16/, &
       e(10) /-.139228964661627791231203060395d-17/
  data e(11) / .133802855014020915603275339093d-18/, &
       e(12) /-.154246009867966094273710216533d-19/, &
       e(13) / .197701992980957427278370133333d-20/, &
       e(14) /-.234065664793997056856992426667d-21/, &
       e(15) / .171348014966398575409015466667d-22/
!
  a = dmin1(a0, b0)
  b = dmax1(a0, b0)
!
  h = a/b
  c = h/(1.d0 + h)
  x = 1.d0/(1.d0 + h)
  x2 = x*x
!
!        compute (1 - x**n)/(1 - x) for n = 1,3,5,...
!            store these values in s(1),s(2),...
!
  s(1) = 1.d0
  do 10 j = 1,14
     s(j + 1) = 1.d0 + (x + x2*s(j))
   10 continue
!
!                set w = del(b) - del(a + b)
!
  t = (10.d0/b)**2
  w = e(15)*s(15)
  do 20 j = 1,14
     k = 15 - j
     w = t*w + e(k)*s(k)
   20 continue
  w = w*(c/b)
!
!                    compute  del(a) + w
!
  t = (10.d0/a)**2
  z = e(15)
  do 30 j = 1,14
     k = 15 - j
     z = t*z + e(k)
   30 continue
  dbcorr = z/a + w
  return
end
function dbetln (a0, b0)
!
!*******************************************************************************
!
!! DBETLN: evaluation of the logarithm of the beta function
!
  double precision a0, b0
  double precision dbetln
  double precision a, b, c, e, h, sn, u, v, w, z
  double precision dbcorr, dgamln, dgsmln, dlgdiv, dlnrel
!
!     e = 0.5*ln(2*pi)
!
  data e /.9189385332046727417803297364056d0/
!
  a = dmin1(a0,b0)
  b = dmax1(a0,b0)
  if (a >= 10.d0) go to 60
  if (a >= 1.d0) go to 20
!
!                   procedure when a < 1
!
  if (b >= 10.d0) go to 10
     dbetln = dgamln(a) + (dgamln(b) - dgamln(a + b))
     return
   10 dbetln = dgamln(a) + dlgdiv(a,b)
  return
!
!               procedure when 1 <= a < 10
!
   20 if (a > 2.d0) go to 30
  if (b > 2.d0) go to 21
     dbetln = dgamln(a) + dgamln(b) - dgsmln(a,b)
     return
   21 w = 0.d0
  if (b < 10.d0) go to 40
     dbetln = dgamln(a) + dlgdiv(a,b)
     return
!
!               reduction of a when b <= 1000
!
   30 if (b > 1.d3) go to 50
  n = a - 1.d0
  w = 1.d0
  do 31 i = 1,n
     a = a - 1.d0
     h = a/b
     w = w * (h/(1.d0 + h))
   31 continue
  w = dlog(w)
  if (b < 10.d0) go to 40
  dbetln = w + dgamln(a) + dlgdiv(a,b)
  return
!
!                reduction of b when b < 10
!
   40 n = b - 1.d0
  z = 1.d0
  do 41 i = 1,n
     b = b - 1.d0
     z = z * (b/(a + b))
   41 continue
  dbetln = w + dlog(z) + (dgamln(a) + (dgamln(b) - dgsmln(a,b)))
  return
!
!               reduction of a when b > 1000
!
   50 n = a - 1.d0
  w = 1.d0
  do 51 i = 1,n
     a = a - 1.d0
     w = w*(a/(1.d0 + a/b))
   51 continue
  sn = n
  dbetln = (dlog(w) - sn*dlog(b)) + (dgamln(a) + dlgdiv(a,b))
  return
!
!                  procedure when a >= 10
!
   60 w = dbcorr(a,b)
  h = a/b
  c = h/(1.d0 + h)
  u = -(a - 0.5d0)*dlog(c)
  v = b*dlnrel(h)
  if (u <= v) go to 61
     dbetln = (((-0.5d0*dlog(b) + e) + w) - v) - u
     return
   61 dbetln = (((-0.5d0*dlog(b) + e) + w) - u) - v
  return
end
subroutine dcbabk (nm,n,low,igh,scale,m,zr,zi)
!
!*******************************************************************************
!
!! DCBABK forms the eigenvectors of a double precision complex matrix
!  by back transforming those of the corresponding
!     balanced matrix determined by dcbal.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by dcbal,
!
!        scale contains information determining the permutations
!          and scaling factors used by dcbal,
!
!        m is the number of eigenvectors to be back transformed,
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the eigenvectors to be
!          back transformed in their first m columns.
!
!     on output-
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the transformed eigenvectors
!          in their first m columns.
!
  integer i,j,k,m,n,ii,nm,igh,low
  double precision scale(n),zr(nm,m),zi(nm,m)
  double precision s
!
  if (m == 0) go to 200
  if (igh == low) go to 120
!
  do 110 i = low, igh
     s = scale(i)
!    left hand eigenvectors are back transformed
!                if the foregoing statement is replaced by
!                s=1.0/scale(i).
     do 100 j = 1, m
        zr(i,j) = zr(i,j) * s
        zi(i,j) = zi(i,j) * s
  100    continue
!
  110 continue
!
!    for i=low-1 step -1 until 1,
!                igh+1 step 1 until n do
  120 do 140 ii = 1, n
     i = ii
     if (i >= low .and. i <= igh) go to 140
     if (i < low) i = low - ii
     k = scale(i)
     if (k == i) go to 140
!
     do 130 j = 1, m
        s = zr(i,j)
        zr(i,j) = zr(k,j)
        zr(k,j) = s
        s = zi(i,j)
        zi(i,j) = zi(k,j)
        zi(k,j) = s
  130    continue
!
  140 continue
!
  200 return
end
subroutine dcbal(nm,n,ar,ai,low,igh,scale)
!
!*******************************************************************************
!
!! DCBAL balances a double precision complex matrix and isolates eigenvalues.
!
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the complex matrix to be balanced.
!
!     on output-
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the balanced matrix,
!
!        low and igh are two integers such that ar(i,j) and ai(i,j)
!          are equal to zero if
!           (1) i is greater than j and
!           (2) j=1,...,low-1 or i=igh+1,...,n,
!
!        scale contains information determining the
!           permutations and scaling factors used.
!
!     suppose that the principal submatrix in rows low through igh
!     has been balanced, that p(j) denotes the index interchanged
!     with j during the permutation step, and that the elements
!     of the diagonal matrix used are denoted by d(i,j).  then
!        scale(j) = p(j),    for j = 1,...,low-1
!                 = d(j,j)       j = low,...,igh
!                 = p(j)         j = igh+1,...,n.
!     the order in which the interchanges are made is n to igh+1,
!     then 1 to low-1.
!
!     note that 1 is returned for igh if igh is zero formally.
!
!     the algol procedure exc contained in cbalance appears in
!     dcbal in line.  (note that the algol roles of identifiers
!     k,l have been reversed.)
!
  integer i,j,k,l,m,n,jj,nm,igh,low,iexc
  double precision ar(nm,n),ai(nm,n),scale(n)
  double precision c,f,g,r,s,b2,radix
  logical noconv
!
!
!    radix is a machine dependent parameter specifying
!                the base of the machine floating point representation.
!
             radix = ipmpar(4)
!
!
!
  b2 = radix * radix
  k = 1
  l = n
  go to 100
!    in-line procedure for row and
!                column exchange
   20 scale(m) = j
  if (j == m) go to 50
!
  do 30 i = 1, l
     f = ar(i,j)
     ar(i,j) = ar(i,m)
     ar(i,m) = f
     f = ai(i,j)
     ai(i,j) = ai(i,m)
     ai(i,m) = f
   30 continue
!
  do 40 i = k, n
     f = ar(j,i)
     ar(j,i) = ar(m,i)
     ar(m,i) = f
     f = ai(j,i)
     ai(j,i) = ai(m,i)
     ai(m,i) = f
   40 continue
!
   50 go to (80,130), iexc
!    search for rows isolating an eigenvalue
!                and push them down
   80 if (l == 1) go to 280
  l = l - 1
!    for j=l step -1 until 1 do
  100 do 120 jj = 1, l
     j = l + 1 - jj
!
     do 110 i = 1, l
        if (i == j) go to 110
        if (ar(j,i) /= 0.d0 .or. ai(j,i) /= 0.d0) go to 120
  110    continue
!
     m = l
     iexc = 1
     go to 20
  120 continue
!
  go to 140
!    search for columns isolating an eigenvalue
!                and push them left
  130 k = k + 1
!
  140 do 170 j = k, l
!
     do 150 i = k, l
        if (i == j) go to 150
        if (ar(i,j) /= 0.d0 .or. ai(i,j) /= 0.d0) go to 170
  150    continue
!
     m = k
     iexc = 2
     go to 20
  170 continue
!    now balance the submatrix in rows k to l
  do 180 i = k, l
  180 scale(i) = 1.d0
!    iterative loop for norm reduction
  190 noconv = .false.
!
  do 270 i = k, l
     c = 0.d0
     r = 0.d0
!
     do 200 j = k, l
        if (j == i) go to 200
        c = c + dabs(ar(j,i)) + dabs(ai(j,i))
        r = r + dabs(ar(i,j)) + dabs(ai(i,j))
  200    continue
!    guard against zero c or r due to underflow
     if (c == 0.d0 .or. r == 0.d0) go to 270
     g = r / radix
     f = 1.d0
     s = c + r
  210    if (c >= g) go to 220
     f = f * radix
     c = c * b2
     go to 210
  220    g = r * radix
  230    if (c < g) go to 240
     f = f / radix
     c = c / b2
     go to 230
!    now balance
  240    if ((c + r) / f >= 0.95d0 * s) go to 270
     g = 1.d0 / f
     scale(i) = scale(i) * f
     noconv = .true.
!
     do 250 j = k, n
        ar(i,j) = ar(i,j) * g
        ai(i,j) = ai(i,j) * g
  250    continue
!
     do 260 j = 1, l
        ar(j,i) = ar(j,i) * f
        ai(j,i) = ai(j,i) * f
  260    continue
!
  270 continue
!
  if (noconv) go to 190
!
  280 low = k
  igh = l
  return
end
subroutine dcbcrt (a, zr, zi)
!
!*******************************************************************************
!
!! DCBCRT computes the roots of a real cubic polynomial
!              a(1) + a(2)*z + a(3)*z**2 + a(4)*z**3
!     and stores the results in zr and zi. it is assumed that
!     a(4) is nonzero.
!
!
!     written by alfred h. morris
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  double precision a(4), zr(3), zi(3)
  double precision aq(3), arg, c, cf, d, eps, p, p1, q, q1, &
                   r, ra, rb, rq, rt, rt3, r1, s, sf, sq, sum, &
                   t, tol, t1, w, w1, w2, x, x1, x2, x3, y, &
                   y1, y2, y3
  double precision dpmpar, dcbrt
!
  data rt3 /1.732050807568877293527446341505872366943d0/
!
  eps = epsilon ( eps )
  if (a(1) == 0.d0) go to 100
  p = a(3)/(3.d0*a(4))
  q = a(2)/a(4)
  r = a(1)/a(4)
  tol = 4.d0*eps
!
  c = 0.d0
  t = a(2) - p*a(3)
  if (dabs(t) > tol*dabs(a(2))) c = t/a(4)
!
  t = 2.d0*p*p - q
  if (dabs(t) <= tol*dabs(q)) t = 0.d0
  d = r + p*t
  if (dabs(d) <= tol*dabs(r)) go to 110
!
!           set  sq = (a(4)/s)**2 * (c**3/27 + d**2/4)
!
  s = dmax1(dabs(a(1)),dabs(a(2)),dabs(a(3)))
  p1 = a(3)/(3.d0*s)
  q1 = a(2)/s
  r1 = a(1)/s
!
  t1 = q - 2.25d0*p*p
  if (dabs(t1) <= tol*dabs(q)) t1 = 0.d0
  w = 0.25d0*r1*r1
  w1 = 0.5d0*p1*r1*t
  w2 = q1*q1*t1/27.d0
  if (w1 < 0.d0) go to 10
     w = w + w1
     sq = w + w2
     go to 12
   10 if (w2 < 0.d0) go to 11
     w = w + w2
     sq = w + w1
     go to 12
   11 sq = w + (w1 + w2)
   12 if (dabs(sq) <= tol*w) sq = 0.d0
  rq = dabs(s/a(4))*dsqrt(dabs(sq))
  if (sq >= 0.d0) go to 40
!
!                   all roots are real
!
  arg = datan2(rq, -0.5d0*d)
  cf = dcos(arg/3.d0)
  sf = dsin(arg/3.d0)
  rt = dsqrt(-c/3.d0)
  y1 = 2.d0*rt*cf
  y2 = -rt*(cf + rt3*sf)
  y3 = -(d/y1)/y2
!
  x1 = y1 - p
  x2 = y2 - p
  x3 = y3 - p
  if (dabs(x1) <= dabs(x2)) go to 20
     t = x1
     x1 = x2
     x2 = t
   20 if (dabs(x2) <= dabs(x3)) go to 30
     t = x2
     x2 = x3
     x3 = t
  if (dabs(x1) <= dabs(x2)) go to 30
     t = x1
     x1 = x2
     x2 = t
!
   30 w = x3
  if (dabs(x2) < 0.1d0*dabs(x3)) go to 70
  if (dabs(x1) < 0.1d0*dabs(x2)) x1 = - (r/x3)/x2
  zr(1) = x1
  zr(2) = x2
  zr(3) = x3
  zi(1) = 0.d0
  zi(2) = 0.d0
  zi(3) = 0.d0
  return
!
!                  real and complex roots
!
   40 ra = dcbrt(-0.5d0*d - dsign(rq,d))
  rb = -c/(3.d0*ra)
  t = ra + rb
  w = -p
  x = -p
  if (dabs(t) <= tol*dabs(ra)) go to 41
     w = t - p
     x = -0.5d0*t - p
     if (dabs(x) <= tol*dabs(p)) x = 0.d0
   41 t = dabs(ra - rb)
  y = 0.5d0*rt3*t
!
  if (t <= tol*dabs(ra)) go to 60
  if (dabs(x) < dabs(y)) go to 50
     s = dabs(x)
     t = y/x
     go to 51
   50 s = dabs(y)
  t = x/y
   51 if (s < 0.1d0*dabs(w)) go to 70
  w1 = w/s
  sum = 1.d0 + t*t
  if (w1*w1 < 1.d-2*sum) w = - ((r/sum)/s)/s
  zr(1) = w
  zr(2) = x
  zr(3) = x
  zi(1) = 0.d0
  zi(2) = y
  zi(3) = -y
  return
!
!               at least two roots are equal
!
   60 zi(1) = 0.d0
  zi(2) = 0.d0
  zi(3) = 0.d0
  if (dabs(x) < dabs(w)) go to 61
     if (dabs(w) < 0.1d0*dabs(x)) w = - (r/x)/x
     zr(1) = w
     zr(2) = x
     zr(3) = x
     return
   61 if (dabs(x) < 0.1d0*dabs(w)) go to 70
  zr(1) = x
  zr(2) = x
  zr(3) = w
  return
!
!     here w is much larger in magnitude than the other roots.
!     as a result, the other roots may be exceedingly inaccurate
!     because of roundoff error. to deal with this, a quadratic
!     is formed whose roots are the same as the smaller roots of
!     the cubic. this quadratic is then solved.
!
!     this code was written by william l. davis (nswc).
!
   70    aq(1) = a(1)
     aq(2) = a(2) + a(1)/w
     aq(3) = -a(4)*w
     call dqdcrt (aq, zr, zi)
     zr(3) = w
     zi(3) = 0.d0
!
  if (zi(1) == 0.d0) return
  zr(3) = zr(2)
  zi(3) = zi(2)
  zr(2) = zr(1)
  zi(2) = zi(1)
  zr(1) = w
  zi(1) = 0.d0
  return
!
!
!                  case when a(1) = 0
!
  100 zr(1) = 0.d0
  zi(1) = 0.d0
  call dqdcrt(a(2), zr(2), zi(2))
  return
!
!                   case when d = 0
!
  110 zr(1) = -p
  zi(1) = 0.d0
  w = dsqrt(dabs(c))
  if (c < 0.d0) go to 120
     zr(2) = -p
     zr(3) = zr(2)
     zi(2) =  w
     zi(3) = -w
     return
!
  120 if (p /= 0.d0) go to 130
     zr(2) =  w
     zr(3) = -w
     zi(2) = 0.d0
     zi(3) = 0.d0
     return
!
  130 x = -(p + dsign(w,p))
  zr(3) =  x
  zi(2) = 0.d0
  zi(3) = 0.d0
  t = 3.d0*a(1)/(a(3)*x)
  if (dabs(p) > dabs(t)) go to 131
     zr(2) = t
     return
  131 zr(2) = zr(1)
  zr(1) = t
  return
end
  double precision function dcbrt (x)
!
!*******************************************************************************
!
!! DCBRT: cube root of a number.
!
  double precision x, r
!
  if (x) 30, 10, 20
   10 dcbrt = 0.d0
  return
   20 r = dlog(x)/3.d0
  dcbrt = dexp(r)
  return
   30 r = dlog(-x)/3.d0
  dcbrt = -dexp(r)
  return
end
subroutine dceig(ibal,ar,ai,ka,n,wr,wi,ierr)
!
!*******************************************************************************
!
!! DCEIG: eigenvalues of double precision complex matrices
!
  double precision ar(ka,n), ai(ka,n), wr(n), wi(n)
!
  low = 1
  igh = n
  if (ibal /= 0) call dcbal(ka,n,ar,ai,low,igh,wr)
  call dcorth(ka,n,low,igh,ar,ai,wr,wi)
  call dcomqr(ka,n,low,igh,ar,ai,wr,wi,ierr)
  return
end
subroutine dceigv (ibal,ar,ai,ka,n,wr,wi,zr,zi,ierr,temp)
!
!*******************************************************************************
!
!! DCEIGV: eigenvalues and eigenvectors of double precision complex matrices
!
  double precision ar(ka,n),ai(ka,n),wr(n),wi(n),zr(ka,n),zi(ka,n), &
                   temp(*)
!
!     temp is a temporary storage area
!        dimension(temp) >= 2*n    if ibal == 0
!        dimension(temp) >= 3*n    if ibal /= 0
!
  i2 = 1
  i3 = n + 1
  i1 = n + i3
  low = 1
  igh = n
  if (ibal /= 0) call dcbal(ka,n,ar,ai,low,igh,temp(i1))
  call dcorth(ka,n,low,igh,ar,ai,temp(i2),temp(i3))
  call dcmqr2(ka,n,low,igh,temp(i2),temp(i3),ar,ai,wr,wi, &
                  zr,zi,ierr)
  if (ierr /= 0) return
  if (ibal /= 0) call dcbabk(ka,n,low,igh,temp(i1),n,zr,zi)
  return
end
subroutine dcerf (mo, z, w)
!
!*******************************************************************************
!
!! DCERF: computation of the complex error function
!
!
!                       w = erf(z)    if mo = 0
!                       w = erfc(z)   otherwise
!
!
  double precision z(2), w(2)
  double precision m, n, n2, n4, np1
  double precision c, c2, d, d2, e, eps, r, sn, tol, x, y
  double precision a0(2), an(2), b0(2), bn(2)
  double precision g0(2), gn(2), h0(2), hn(2)
  double precision qf(2), sm(2), sz(2), tm(2), ts(2), w0(2), wn(2)
  double precision anorm, dpmpar
!
  anorm(x,y) = dmax1(dabs(x),dabs(y))
!
!     c = 1/sqrt(pi)
!
  data c /.56418958354775628694807945156077d0/
!
  eps = epsilon ( eps )
  x = z(1)
  y = z(2)
  sn = 1.d0
  if (x >= 0.d0) go to 10
     x = -x
     y = -y
     sn = -1.d0
!
   10 r = x*x + y*y
  sz(1) = x*x - y*y
  sz(2) = 2.d0*x*y
!
  if (r <= 1.d0) go to 20
  if (r >= 144.d0) go to 100
  if (dabs(y) > 31.8d0*x) go to 50
  if (dabs(y) > 7.0d0*x .and. r < 64.d0) go to 50
  if (dabs(y) > 3.2d0*x .and. r < 49.d0) go to 50
  if (dabs(y) > 2.0d0*x .and. r < 36.d0) go to 50
  if (dabs(y) > 1.2d0*x .and. r < 25.d0) go to 50
  if (dabs(y) > 0.9d0*x .and. r < 16.d0) go to 50
  if (r >= 6.25d0) go to 80
  if (dabs(y) > 0.6d0*x) go to 50
  if (r >= 4.0d0) go to 40
!
  d = x - 2.d0
  if (d*d + y*y < 1.d0) go to 40
  go to 50
!
!                          taylor series
!
   20 c2 = c + c
  tm(1) = c2*x
  tm(2) = c2*y
  sm(1) = tm(1)
  sm(2) = tm(2)
  tol = 2.d0*eps
  m = 0.d0
   21    m = m + 1.d0
     d = m + m + 1.d0
     ts(1) = tm(1)*sz(1) - tm(2)*sz(2)
     ts(2) = tm(1)*sz(2) + tm(2)*sz(1)
     tm(1) = -ts(1)/m
     tm(2) = -ts(2)/m
     ts(1) = tm(1)/d
     ts(2) = tm(2)/d
     sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     if (anorm(ts(1),ts(2)) > tol*anorm(sm(1),sm(2))) go to 21
!
  if (mo /= 0) go to 30
     w(1) = sn*sm(1)
     w(2) = sn*sm(2)
     return
   30 if (sn == 1.d0) go to 31
     w(1) = 1.d0 + sm(1)
     w(2) = sm(2)
     return
   31 w(1) = 0.5d0 + (0.5d0 - sm(1))
  w(2) = -sm(2)
  return
!
!                  taylor series around z0 = 2
!
   40 tm(1) = x
  tm(2) = y
  call erfcm2 (0, tm, w)
  if (mo /= 0) go to 41
     w(1) = sn*(0.5d0 + (0.5d0 - w(1)))
     w(2) = - sn*w(2)
     return
   41 if (sn > 0.d0) return
  w(1) = 2.d0 - w(1)
  w(2) = - w(2)
  return
!
!            pade approximation for the taylor series
!                    for  (exp(z*z)/z)*erf(z)
!
   50 d = 4.d0
  if (r > 16.d0) d = 16.d0
  if (r > 64.d0) d = 64.d0
  d2 = d*d
  call dcrec (sz(1), sz(2), w(1), w(2))
  a0(1) = 1.d0
  a0(2) = 0.d0
  an(1) = (w(1) + 4.d0/15.d0)*d
  an(2) = w(2)*d
  b0(1) = 1.d0
  b0(2) = 0.d0
  bn(1) = (w(1) - 0.4d0)*d
  bn(2) = w(2)*d
  call cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
  tol = 10.d0*eps
  n4 = 0.d0
!
   60    n4 = n4 + 4.d0
     e = (n4 + 1.d0)*(n4 + 5.d0)
     tm(1) = d*(w(1) - 2.d0/e)
     tm(2) = d*w(2)
     e = d2*(n4*(n4 + 2.0))/((n4 - 1.0)*(n4 + 3.0)*(n4 + 1.0)**2)
!
     qf(1) = (tm(1)*an(1) - tm(2)*an(2)) + e*a0(1)
     qf(2) = (tm(1)*an(2) + tm(2)*an(1)) + e*a0(2)
     a0(1) = an(1)
     a0(2) = an(2)
     an(1) = qf(1)
     an(2) = qf(2)
     qf(1) = (tm(1)*bn(1) - tm(2)*bn(2)) + e*b0(1)
     qf(2) = (tm(1)*bn(2) + tm(2)*bn(1)) + e*b0(2)
     b0(1) = bn(1)
     b0(2) = bn(2)
     bn(1) = qf(1)
     bn(2) = qf(2)
!
     w0(1) = wn(1)
     w0(2) = wn(2)
     call cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
     if (anorm(wn(1) - w0(1), wn(2) - w0(2)) > &
            tol*anorm(wn(1), wn(2))) go to 60
!
  c2 = c + c
  sm(1) = c2*(x*wn(1) - y*wn(2))
  sm(2) = c2*(x*wn(2) + y*wn(1))
  e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  tm(1) = qf(1)*sm(1) - qf(2)*sm(2)
  tm(2) = qf(1)*sm(2) + qf(2)*sm(1)
!
  w(1) = sn*tm(1)
  w(2) = sn*tm(2)
  if (mo == 0) return
  w(1) = 1.d0 - w(1)
  w(2) = - w(2)
  return
!
!         pade approximation for the asymptotic expansion
!                    for  z*exp(z*z)*erfc(z)
!
   80 d = 4.d0*r
  if (r < 16.d0) d = 16.d0*r
  d2 = d*d
  tm(1) = sz(1) + sz(1)
  tm(2) = sz(2) + sz(2)
  g0(1) = 1.d0
  g0(2) = 0.d0
  gn(1) = (2.d0 + tm(1))/d
  gn(2) = tm(2)/d
  h0(1) = 1.d0
  h0(2) = 0.d0
  tm(1) = 3.d0 + tm(1)
  hn(1) = tm(1)/d
  hn(2) = tm(2)/d
  call cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
  np1 = 1.d0
  tol = 10.d0*eps
!
   90    n = np1
     np1 = n + 1.d0
     n2 = n + n
     e = (n2*(n2 + 1.d0))/d2
     tm(1) = tm(1) + 4.d0
     qf(1) = (tm(1)*gn(1) - tm(2)*gn(2))/d - e*g0(1)
     qf(2) = (tm(1)*gn(2) + tm(2)*gn(1))/d - e*g0(2)
     g0(1) = gn(1)
     g0(2) = gn(2)
     gn(1) = qf(1)
     gn(2) = qf(2)
     qf(1) = (tm(1)*hn(1) - tm(2)*hn(2))/d - e*h0(1)
     qf(2) = (tm(1)*hn(2) + tm(2)*hn(1))/d - e*h0(2)
     h0(1) = hn(1)
     h0(2) = hn(2)
     hn(1) = qf(1)
     hn(2) = qf(2)
!
     w0(1) = wn(1)
     w0(2) = wn(2)
     call cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
     if (anorm(wn(1) - w0(1), wn(2) - w0(2)) > &
            tol*anorm(wn(1), wn(2))) go to 90
!
  tm(1) = x*hn(1) - y*hn(2)
  tm(2) = x*hn(2) + y*hn(1)
  call cdivid (c*gn(1), c*gn(2), tm(1), tm(2), sm(1), sm(2))
  go to 130
!
!                      asymptotic expansion
!
  100 call dcrec (x, y, tm(1), tm(2))
  sm(1) = tm(1)
  sm(2) = tm(2)
  qf(1) = tm(1)*tm(1) - tm(2)*tm(2)
  qf(2) = 2.d0*tm(1)*tm(2)
  tol = 2.d0*eps
  d = -0.5d0
  110    d = d + 1.d0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = -d*ts(1)
     tm(2) = -d*ts(2)
     sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
     if (anorm(tm(1),tm(2)) > tol*anorm(sm(1),sm(2))) go to 110
  sm(1) = c*sm(1)
  sm(2) = c*sm(2)
  if (x < 1.d-2) go to 200
!
!                       termination
!
  130 e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = ts(1)
  sm(2) = ts(2)
!
  if (mo /= 0) go to 140
     w(1) = sn*(0.5d0 + (0.5d0 - sm(1)))
     w(2) = - sn*sm(2)
     return
  140 if (sn == 1.d0) go to 141
     w(1) = 2.d0 - sm(1)
     w(2) = -sm(2)
     return
  141 w(1) = sm(1)
  w(2) = sm(2)
  return
!
!               modified asymptotic expansion
!
  200 e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  w(1) = qf(1)*sm(1) - qf(2)*sm(2)
  w(2) = qf(1)*sm(2) + qf(2)*sm(1)
  if (mo == 0) go to 210
     w(1) = 1.d0 + sn*w(1)
     w(2) = sn*w(2)
     return
  210 if (sn < 0.0) return
  w(1) = - w(1)
  w(2) = - w(2)
  return
end
subroutine dcerfc (mo, z, w)
!
!*******************************************************************************
!
!! DCERFC: computation of the complex coerror function
!
!
!           w = erfc(z)           if mo = 0 or real(z) < 0
!           w = dexp(x*x)*erfc(z)  otherwise
!
!
  double precision z(2), w(2)
  double precision m, n, n2, n4, np1
  double precision c, c2, d, d2, e, eps, r, sn, tol, x, y
  double precision a0(2), an(2), b0(2), bn(2)
  double precision g0(2), gn(2), h0(2), hn(2)
  double precision qf(2), sm(2), sz(2), tm(2), ts(2), w0(2), wn(2)
  double precision anorm, dpmpar, dxparg
!
  anorm(x,y) = dmax1(dabs(x),dabs(y))
!
!     c = 1/sqrt(pi)
!
  data c /.56418958354775628694807945156077d0/
!
  eps = epsilon ( eps )
  x = z(1)
  y = z(2)
  sn = 1.d0
  if (x >= 0.d0) go to 10
     x = -x
     y = -y
     sn = -1.d0
!
   10 if (mo /= 0  .and.  sn == 1.d0  .and. &
     dmax1(x, dabs(y)) >= 144.d0) go to 100
  r = x*x + y*y
  sz(1) = x*x - y*y
  sz(2) = 2.d0*x*y
!
  if (r <= 1.d0) go to 20
  if (r >= 144.d0) go to 100
  if (dabs(y) > 31.8d0*x) go to 50
  if (dabs(y) > 7.0d0*x .and. r < 64.d0) go to 50
  if (dabs(y) > 3.2d0*x .and. r < 49.d0) go to 50
  if (dabs(y) > 2.0d0*x .and. r < 36.d0) go to 50
  if (dabs(y) > 1.2d0*x .and. r < 25.d0) go to 50
  if (dabs(y) > 0.9d0*x .and. r < 16.d0) go to 50
  if (r >= 6.25d0) go to 80
  if (dabs(y) > 0.6d0*x) go to 50
  if (r >= 4.0d0) go to 40
!
  d = x - 2.d0
  if (d*d + y*y < 1.d0) go to 40
  go to 50
!
!                          taylor series
!
   20 c2 = c + c
  tm(1) = c2*x
  tm(2) = c2*y
  sm(1) = tm(1)
  sm(2) = tm(2)
  tol = 2.d0*eps
  m = 0.d0
   21    m = m + 1.d0
     d = m + m + 1.d0
     ts(1) = tm(1)*sz(1) - tm(2)*sz(2)
     ts(2) = tm(1)*sz(2) + tm(2)*sz(1)
     tm(1) = -ts(1)/m
     tm(2) = -ts(2)/m
     ts(1) = tm(1)/d
     ts(2) = tm(2)/d
     sm(1) = sm(1) + ts(1)
     sm(2) = sm(2) + ts(2)
     if (anorm(ts(1),ts(2)) > tol*anorm(sm(1),sm(2))) go to 21
!
  if (sn == 1.d0) go to 30
     w(1) = 1.d0 + sm(1)
     w(2) = sm(2)
     return
   30 sm(1) = 0.5d0 + (0.5d0 - sm(1))
  sm(2) = -sm(2)
  if (mo == 0) go to 140
!
  e = dexp(sz(1))
  qf(1) = e*dcos(sz(2))
  qf(2) = e*dsin(sz(2))
  w(1) = qf(1)*sm(1) - qf(2)*sm(2)
  w(2) = qf(1)*sm(2) + qf(2)*sm(1)
  return
!
!                  taylor series around z0 = 2
!
   40 if (sn < 0.d0) go to 41
     call erfcm2 (mo, z, w)
     return
   41 tm(1) = x
  tm(2) = y
  call erfcm2 (0, tm, w)
  w(1) = 2.d0 - w(1)
  w(2) = - w(2)
  return
!
!            pade approximation for the taylor series
!                    for  (exp(z*z)/z)*erf(z)
!
   50 d = 4.d0
  if (r > 16.d0) d = 16.d0
  if (r > 64.d0) d = 64.d0
  d2 = d*d
  call dcrec (sz(1), sz(2), w(1), w(2))
  a0(1) = 1.d0
  a0(2) = 0.d0
  an(1) = (w(1) + 4.d0/15.d0)*d
  an(2) = w(2)*d
  b0(1) = 1.d0
  b0(2) = 0.d0
  bn(1) = (w(1) - 0.4d0)*d
  bn(2) = w(2)*d
  call cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
  tol = 10.d0*eps
  n4 = 0.d0
!
   60    n4 = n4 + 4.d0
     e = (n4 + 1.d0)*(n4 + 5.d0)
     tm(1) = d*(w(1) - 2.d0/e)
     tm(2) = d*w(2)
     e = d2*(n4*(n4 + 2.0))/((n4 - 1.0)*(n4 + 3.0)*(n4 + 1.0)**2)
!
     qf(1) = (tm(1)*an(1) - tm(2)*an(2)) + e*a0(1)
     qf(2) = (tm(1)*an(2) + tm(2)*an(1)) + e*a0(2)
     a0(1) = an(1)
     a0(2) = an(2)
     an(1) = qf(1)
     an(2) = qf(2)
     qf(1) = (tm(1)*bn(1) - tm(2)*bn(2)) + e*b0(1)
     qf(2) = (tm(1)*bn(2) + tm(2)*bn(1)) + e*b0(2)
     b0(1) = bn(1)
     b0(2) = bn(2)
     bn(1) = qf(1)
     bn(2) = qf(2)
!
     w0(1) = wn(1)
     w0(2) = wn(2)
     call cdivid (an(1), an(2), bn(1), bn(2), wn(1), wn(2))
     if (anorm(wn(1) - w0(1), wn(2) - w0(2)) > &
            tol*anorm(wn(1), wn(2))) go to 60
!
  c2 = c + c
  sm(1) = c2*(x*wn(1) - y*wn(2))
  sm(2) = c2*(x*wn(2) + y*wn(1))
!
  if (mo == 0 .or. sn /= 1.d0) go to 70
     e = dexp(sz(1))
     w(1) = e*dcos(sz(2)) - sm(1)
     w(2) = e*dsin(sz(2)) - sm(2)
     return
   70 e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  tm(1) = qf(1)*sm(1) - qf(2)*sm(2)
  tm(2) = qf(1)*sm(2) + qf(2)*sm(1)
  w(1) = 1.d0 - sn*tm(1)
  w(2) = - sn*tm(2)
  return
!
!         pade approximation for the asymptotic expansion
!                    for  z*exp(z*z)*erfc(z)
!
   80 d = 4.d0*r
  if (r < 16.d0) d = 16.d0*r
  d2 = d*d
  tm(1) = sz(1) + sz(1)
  tm(2) = sz(2) + sz(2)
  g0(1) = 1.d0
  g0(2) = 0.d0
  gn(1) = (2.d0 + tm(1))/d
  gn(2) = tm(2)/d
  h0(1) = 1.d0
  h0(2) = 0.d0
  tm(1) = 3.d0 + tm(1)
  hn(1) = tm(1)/d
  hn(2) = tm(2)/d
  call cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
  np1 = 1.d0
  tol = 10.d0*eps
!
   90    n = np1
     np1 = n + 1.d0
     n2 = n + n
     e = (n2*(n2 + 1.d0))/d2
     tm(1) = tm(1) + 4.d0
     qf(1) = (tm(1)*gn(1) - tm(2)*gn(2))/d - e*g0(1)
     qf(2) = (tm(1)*gn(2) + tm(2)*gn(1))/d - e*g0(2)
     g0(1) = gn(1)
     g0(2) = gn(2)
     gn(1) = qf(1)
     gn(2) = qf(2)
     qf(1) = (tm(1)*hn(1) - tm(2)*hn(2))/d - e*h0(1)
     qf(2) = (tm(1)*hn(2) + tm(2)*hn(1))/d - e*h0(2)
     h0(1) = hn(1)
     h0(2) = hn(2)
     hn(1) = qf(1)
     hn(2) = qf(2)
!
     w0(1) = wn(1)
     w0(2) = wn(2)
     call cdivid (gn(1), gn(2), hn(1), hn(2), wn(1), wn(2))
     if (anorm(wn(1) - w0(1), wn(2) - w0(2)) > &
            tol*anorm(wn(1), wn(2))) go to 90
!
  tm(1) = x*hn(1) - y*hn(2)
  tm(2) = x*hn(2) + y*hn(1)
  call cdivid (c*gn(1), c*gn(2), tm(1), tm(2), sm(1), sm(2))
  go to 130
!
!                      asymptotic expansion
!
  100 call dcrec (x, y, tm(1), tm(2))
  sm(1) = tm(1)
  sm(2) = tm(2)
  qf(1) = tm(1)*tm(1) - tm(2)*tm(2)
  qf(2) = 2.d0*tm(1)*tm(2)
  tol = 2.d0*eps
  d = -0.5d0
  110    d = d + 1.d0
     ts(1) = tm(1)*qf(1) - tm(2)*qf(2)
     ts(2) = tm(1)*qf(2) + tm(2)*qf(1)
     tm(1) = -d*ts(1)
     tm(2) = -d*ts(2)
     sm(1) = sm(1) + tm(1)
     sm(2) = sm(2) + tm(2)
     if (anorm(tm(1),tm(2)) > tol*anorm(sm(1),sm(2))) go to 110
  sm(1) = c*sm(1)
  sm(2) = c*sm(2)
  if (x < 1.d-2) go to 200
!
!                       termination
!
  130 if (mo /= 0 .and. sn == 1.d0) go to 140
  e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  sm(1) = ts(1)
  sm(2) = ts(2)
!
  if (sn == 1.d0) go to 140
     w(1) = 2.d0 - sm(1)
     w(2) = -sm(2)
     return
  140 w(1) = sm(1)
  w(2) = sm(2)
  return
!
!               modified asymptotic expansion
!
  200 if (mo /= 0 .and. sn == 1.d0) go to 210
  e = dexp(-sz(1))
  qf(1) = e*dcos(-sz(2))
  qf(2) = e*dsin(-sz(2))
  ts(1) = qf(1)*sm(1) - qf(2)*sm(2)
  ts(2) = qf(1)*sm(2) + qf(2)*sm(1)
  w(1) = 1.d0 + sn*ts(1)
  w(2) = sn*ts(2)
  return
!
  210 if (dabs(y) >= 100.d0) go to 140
  if (sz(1) <= dxparg(1)) go to 140
  e = dexp(sz(1))
  w(1) = e*dcos(sz(2)) + sm(1)
  w(2) = e*dsin(sz(2)) + sm(2)
  return
end
subroutine dcfact (ar, ai, ka, n, ipvt, ierr)
!
!*******************************************************************************
!
!! DCFACT decomposes a complex matrix by partial pivot gauss elimination
!
!
!     input
!
!        ar and ai are the real and imaginary parts of the matrix a
!        to be decomposed.
!
!        ka = declared row dimension of the arrays ar and ai
!
!        n  = order of the matrix a
!
!     output
!
!        ar and ai contain an upper triangular matrix u and the
!        multipliers needed to construct l so that a = l*u .
!
!        ipvt = the pivot vector.
!            ipvt(i) = the index of the k-th pivot row (i < n)
!            ipvt(n) = (-1)**(number of interchanges)
!
!        ierr is a variable that reports the status of the results.
!        ierr has one of the following values
!            ierr = 0   the decomposition of a was obtained.
!            ierr = k   the k-th pivot element is 0.
!
!     if ierr = 0 then the determinant of a has the value
!        det(a) = ipvt(n) * a(1,1) * a(2,2) * ... * a(n,n)
!
  double precision ar(ka,n), ai(ka,n)
  integer ipvt(n)
  double precision p, pr, pi, t, tr, ti
!
  ierr = 0
  ipvt(n) = 1
  if (n == 1) go to 50
  nm1 = n - 1
!
  do 40 k = 1,nm1
     kp1 = k + 1
!
!               search for the k-th pivot element
!
     p = dabs(ar(k,k)) + dabs(ai(k,k))
     l = k
     do 10 i = kp1,n
        t = dabs(ar(i,k)) + dabs(ai(i,k))
        if (p >= t) go to 10
        p = t
        l = i
   10    continue
     if (p == 0.d0) go to 100
!
     pr = ar(l,k)
     pi = ai(l,k)
     ipvt(k) = l
     if (l == k) go to 20
     ipvt(n) = -ipvt(n)
     ar(l,k) = ar(k,k)
     ar(k,k) = pr
     ai(l,k) = ai(k,k)
     ai(k,k) = pi
!
!                    compute the multipliers
!
   20    call cdivid(1.d0, 0.d0, pr, pi, pr, pi)
     do 21 i = kp1,n
        tr = ar(i,k)
        ti = ai(i,k)
        ar(i,k) = tr*pr - ti*pi
        ai(i,k) = tr*pi + ti*pr
   21    continue
!
!              interchange and eliminate by columns
!
     do 31 j = kp1,n
        tr = ar(l,j)
        ar(l,j) = ar(k,j)
        ar(k,j) = tr
        ti = ai(l,j)
        ai(l,j) = ai(k,j)
        ai(k,j) = ti
        if (dabs(tr) + dabs(ti) == 0.d0) go to 31
        do 30 i = kp1,n
           ar(i,j) = ar(i,j) - ar(i,k)*tr + ai(i,k)*ti
           ai(i,j) = ai(i,j) - ar(i,k)*ti - ai(i,k)*tr
   30       continue
   31    continue
   40 continue
!
!                  check the n-th pivot element
!
   50 if (dabs(ar(n,n)) + dabs(ai(n,n)) == 0.d0) ierr = n
  return
!
!                    k-th pivot element is 0
!
  100 ierr = k
  return
end
subroutine dcgama (mo, z, w)
!
!*******************************************************************************
!
!! DCGAMA evaluates the complex gamma and loggamma functions
!
!
!     mo is an integer. z and w are interpreted as double precision
!     complex numbers. it is assumed that z(1) and z(2) are the real
!     and imaginary parts of the complex number z, and that w(1) and
!     w(2) are the real and imaginary parts of w.
!
!                 w = gamma(z)       if mo = 0
!                 w = ln(gamma(z))   otherwise
!
!
  integer imax
  double precision z(2), w(2)
  double precision c0(30), dlpi, hl2p, pi, pi2
  double precision a, a1, a2, c, cn, cut, d, eps, et, e2t, h1, &
                   h2, q1, q2, s, sn, s1, s2, t, t1, t2, u, u1, &
                   u2, v1, v2, w1, w2, x, y, y2
  double precision dpmpar, drexp
!
!     dlpi = log(pi)
!     hl2p = 0.5 * log(2*pi)
!
  data pi   /3.141592653589793238462643383279502884197d0/
  data pi2  /6.283185307179586476925286766559005768394d0/
  data dlpi /1.144729885849400174143427351353058711647d0/
  data hl2p /.9189385332046727417803297364056176398614d0/
!
  data c0(1)  / .8333333333333333333333333333333333333333d-01/, &
       c0(2)  /-.2777777777777777777777777777777777777778d-02/, &
       c0(3)  / .7936507936507936507936507936507936507937d-03/, &
       c0(4)  /-.5952380952380952380952380952380952380952d-03/, &
       c0(5)  / .8417508417508417508417508417508417508418d-03/, &
       c0(6)  /-.1917526917526917526917526917526917526918d-02/, &
       c0(7)  / .6410256410256410256410256410256410256410d-02/, &
       c0(8)  /-.2955065359477124183006535947712418300654d-01/, &
       c0(9)  / .1796443723688305731649384900158893966944d+00/, &
       c0(10) /-.1392432216905901116427432216905901116427d+01/
  data c0(11) / .1340286404416839199447895100069013112491d+02/, &
       c0(12) /-.1568482846260020173063651324520889738281d+03/, &
       c0(13) / .2193103333333333333333333333333333333333d+04/, &
       c0(14) /-.3610877125372498935717326521924223073648d+05/, &
       c0(15) / .6914722688513130671083952507756734675533d+06/, &
       c0(16) /-.1523822153940741619228336495888678051866d+08/, &
       c0(17) / .3829007513914141414141414141414141414141d+09/, &
       c0(18) /-.1088226603578439108901514916552510537473d+11/, &
       c0(19) / .3473202837650022522522522522522522522523d+12/, &
       c0(20) /-.1236960214226927445425171034927132488108d+14/
  data c0(21) / .4887880647930793350758151625180229021085d+15/, &
       c0(22) /-.2132033396091937389697505898213683855747d+17/, &
       c0(23) / .1021775296525700077565287628053585500394d+19/, &
       c0(24) /-.5357547217330020361082770919196920448485d+20/, &
       c0(25) / .3061578263704883415043151051329622758194d+22/, &
       c0(26) /-.1899991742639920405029371429306942902947d+24/, &
       c0(27) / .1276337403382883414923495137769782597654d+26/, &
       c0(28) /-.9252847176120416307230242348347622779519d+27/, &
       c0(29) / .7218822595185610297836050187301637922490d+29/, &
       c0(30) /-.6045183405995856967743148238754547286066d+31/
!
  imax = huge ( imax )
  eps = epsilon ( eps )
  x = z(1)
  y = z(2)
  if (x >= 0.d0) go to 50
!
!            case when the real part of z is negative
!
  y = dabs(y)
  t = -pi*y
  et = dexp(t)
  e2t = et*et
!
!     set  a1 = (1 + e2t)/2  and  a2 = (1 - e2t)/2
!
  a1 = 0.5d0*(1.d0 + e2t)
  t2 = t + t
  if (t2 < -0.15d0) go to 10
     a2 = -0.5d0*drexp(t2)
     go to 20
   10 a2 = 0.5d0*(0.5d0 + (0.5d0 - e2t))
!
!     compute sin(pi*x) and cos(pi*x)
!
   20 u = imax
  if (dabs(x) >= dmin1(u, 1.d0/eps)) go to 200
  k = dabs(x)
  u = x + k
  k = mod(k,2)
  if (u > -0.5d0) go to 21
     u = 0.5d0 + (0.5d0 + u)
     k = k + 1
   21 u = pi*u
  sn = dsin(u)
  cn = dcos(u)
  if (k /= 1) go to 30
  sn = -sn
  cn = -cn
!
!     set  h1 + h2*i  to  pi/sin(pi*z)  or  log(pi/sin(pi*z))
!
   30 a1 = sn*a1
  a2 = cn*a2
  a = a1*a1 + a2*a2
  if (a == 0.d0) go to 200
  if (mo /= 0) go to 40
!
  h1 = a1/a
  h2 = -a2/a
  c = pi*et
  h1 = c*h1
  h2 = c*h2
  go to 41
!
   40 h1 = (dlpi + t) - 0.5d0*dlog(a)
  h2 = -datan2(a2,a1)
   41 if (z(2) < 0.d0) go to 42
     x = 1.0 - x
     y = -y
     go to 50
   42 h2 = -h2
  x = 1.0 - x
!
!           case when the real part of z is nonnegative
!
   50 w1 = 0.d0
  w2 = 0.d0
  n = 0
  t = x
  y2 = y*y
  a = t*t + y2
  cut = 225.d0
  if (eps > 1.d-30) cut = 144.d0
  if (eps > 1.d-20) cut = 64.d0
  if (a >= cut) go to 80
  if (a == 0.d0) go to 200
   51    n = n + 1
     t = t + 1.d0
     a = t*t + y2
     if (a < cut) go to 51
!
!     let s1 + s2*i be the product of the terms (z+j)/(z+n)
!
  u1 = (x*t + y2)/a
  u2 = y/a
  s1 = u1
  s2 = n*u2
  if (n < 2) go to 70
  u = t/a
  nm1 = n - 1
  do 60 j = 1,nm1
     v1 = u1 + j*u
     v2 = (n - j)*u2
     c = s1*v1 - s2*v2
     d = s1*v2 + s2*v1
     s1 = c
     s2 = d
   60 continue
!
!     set  w1 + w2*i = log(s1 + s2*i)  when mo is nonzero
!
   70 s = s1*s1 + s2*s2
  if (mo == 0) go to 80
  w1 = 0.5d0 * dlog(s)
  w2 = datan2(s2,s1)
!
!     set  v1 + v2*i = (z - 0.5) * log(z + n) - z
!
   80 t1 = 0.5d0 * dlog(a) - 1.d0
  t2 = datan2(y,t)
  u = x - 0.5d0
  v1 = (u*t1 - 0.5d0) - y*t2
  v2 = u*t2 + y*t1
!
!     let a1 + a2*i be the asymptotic sum
!
  u1 = t/a
  u2 = -y/a
  q1 = u1*u1 - u2*u2
  q2 = 2.d0*u1*u2
  a1 = 0.d0
  a2 = 0.d0
  do 91 j = 1,30
     t1 = a1
     t2 = a2
     a1 = a1 + c0(j)*u1
     a2 = a2 + c0(j)*u2
     if (a1 /= t1) go to 90
     if (a2 == t2) go to 100
   90    t1 = u1*q1 - u2*q2
     t2 = u1*q2 + u2*q1
     u1 = t1
     u2 = t2
   91 continue
!
!                 gathering together the results
!
  100 w1 = (((a1 + hl2p) - w1) + v1) - n
  w2 = (a2 - w2) + v2
  if (z(1) < 0.d0) go to 120
  if (mo /= 0) go to 110
!
!     case when the real part of z is nonnegative and mo = 0
!
  a = dexp(w1)
  w1 = a * dcos(w2)
  w2 = a * dsin(w2)
  if (n == 0) go to 140
  c = (s1*w1 + s2*w2)/s
  d = (s1*w2 - s2*w1)/s
  w1 = c
  w2 = d
  go to 140
!
!     case when the real part of z is nonnegative and mo is nonzero.
!     the angle w2 is reduced to the interval -pi < w2 <= pi.
!
  110 if (w2 > pi) go to 111
     k = 0.5d0 - w2/pi2
     w2 = w2 + pi2*k
     go to 140
  111 k = w2/pi2 - 0.5d0
  u = k + 1
  w2 = w2 - pi2*u
  if (w2 <= -pi) w2 = pi
  go to 140
!
!     case when the real part of z is negative and mo is nonzero
!
  120 if (mo == 0) go to 130
  w1 = h1 - w1
  w2 = h2 - w2
  go to 110
!
!     case when the real part of z is negative and mo = 0
!
  130 a = dexp(-w1)
  t1 = a * dcos(-w2)
  t2 = a * dsin(-w2)
  w1 = h1*t1 - h2*t2
  w2 = h1*t2 + h2*t1
  if (n == 0) go to 140
  c = w1*s1 - w2*s2
  d = w1*s2 + w2*s1
  w1 = c
  w2 = d
!
!     termination
!
  140 w(1) = w1
  w(2) = w2
  return
!
!             the requested value cannot be computed
!
  200 w(1) = 0.d0
  w(2) = 0.d0
  return
end
subroutine dcminv (ar, ai, ka, n, ipvt, temp)
!
!*******************************************************************************
!
!! DCMINV inverts a matrix using the lu decomposition obtained by dcfact.
!
!  this routine cannot
!     be used when dcfact terminates with nonzero ierr.
!
!
!     input
!
!        ar and ai contain the lu decomposition of the matrix
!        obtained by dcfact.
!
!        ka = declared row dimension of the arrays ar and ai
!
!        n  = order of the matrix
!
!        ipvt = pivot vector obtained from dcfact
!
!        temp = temporary storage area for the subroutine
!
!     output
!
!        ar and ai contain the inverse of the matrix.
!
!
  double precision ar(ka,n), ai(ka,n), temp(2,n)
  integer ipvt(n)
  double precision sr, si, tr, ti
!
  call cdivid (1.d0, 0.d0, ar(n,n), ai(n,n), ar(n,n), ai(n,n))
  if (n == 1) return
  np1 = n + 1
  nm1 = n - 1
!
!                replace u with the inverse of u
!
  do 20 nmi = 1,nm1
     i = n - nmi
     ip1 = i + 1
     call cdivid (1.d0, 0.d0, ar(i,i), ai(i,i), tr, ti)
     do 11 jb = 1,nmi
        j = np1 - jb
        sr = 0.d0
        si = 0.d0
        do 10 l = ip1,j
           sr = sr + ar(i,l)*ar(l,j) - ai(i,l)*ai(l,j)
           si = si + ar(i,l)*ai(l,j) + ai(i,l)*ar(l,j)
   10       continue
        ar(i,j) = -sr*tr + si*ti
        ai(i,j) = -sr*ti - si*tr
   11    continue
     ar(i,i) = tr
     ai(i,i) = ti
   20 continue
!
!                compute  inverse(u)*inverse(l)
!
  do 60 nmk = 1,nm1
     k = n - nmk
     kp1 = k + 1
     do 30 i = kp1,n
        temp(1,i) = ar(i,k)
        temp(2,i) = ai(i,k)
        ar(i,k) = 0.d0
        ai(i,k) = 0.d0
   30    continue
!
     do 41 j = kp1,n
        tr = temp(1,j)
        ti = temp(2,j)
        do 40 i = 1,n
           ar(i,k) = ar(i,k) - ar(i,j)*tr + ai(i,j)*ti
           ai(i,k) = ai(i,k) - ar(i,j)*ti - ai(i,j)*tr
   40       continue
   41    continue
!
     l = ipvt(k)
     if (k == l) go to 60
     do 50 i = 1,n
        tr = ar(i,k)
        ar(i,k) = ar(i,l)
        ar(i,l) = tr
        ti = ai(i,k)
        ai(i,k) = ai(i,l)
   50       ai(i,l) = ti
   60 continue
  return
end
subroutine dcmqr2 (nm,n,low,igh,ortr,orti,hr,hi,wr,wi,zr,zi,ierr)
!
!*****************************************************************************80
!
!! DCMQR2: eigenvalues/vectors of double complex upper hessenberg matrix
!  by the qr method.  the eigenvectors of a complex general matrix
!     can also be found if dcorth has been used to reduce
!     this general matrix to hessenberg form.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dcbal.  if dcbal has not been used,
!          set low=1, igh=n,
!
!        ortr and orti contain information about the unitary trans-
!          formations used in the reduction by dcorth, if performed.
!          only elements low through igh are used.  if the eigenvectors
!          of the hessenberg matrix are desired, set ortr(j) and
!          orti(j) to 0.0 for these elements,
!
!        hr and hi contain the real and imaginary parts,
!          respectively, of the complex upper hessenberg matrix.
!          their lower triangles below the subdiagonal contain further
!          information about the transformations which were used in the
!          reduction by dcorth, if performed.  if the eigenvectors of
!          the hessenberg matrix are desired, these elements may be
!          arbitrary.
!
!     on output-
!
!        ortr, orti, and the upper hessenberg portions of hr and hi
!          have been destroyed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  if an error
!          exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        zr and zi contain the real and imaginary parts,
!          respectively, of the eigenvectors.  the eigenvectors
!          are unnormalized.  if an error exit is made, none of
!          the eigenvectors has been found,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 50 iterations.
!
  integer i,j,k,l,m,n,en,ii,jj,ll,nm,nn,igh,ip1, &
          its,low,lp1,enm1,iend,ierr
  double precision hr(nm,n),hi(nm,n),wr(n),wi(n),zr(nm,n),zi(nm,n), &
                   ortr(igh),orti(igh)
  double precision si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,machep
  double precision r2,w(2),z(2)
  double precision dpmpar,dcpabs
!
  machep = epsilon ( machep )
  ierr = 0
!
!    initialize eigenvector matrix
  do 100 i = 1, n
!
     do 100 j = 1, n
        zr(i,j) = 0.d0
        zi(i,j) = 0.d0
        if (i == j) zr(i,j) = 1.d0
  100 continue
!    form the matrix of accumulated transformations
!                from the information left by dcorth
  iend = igh - low - 1
  if (iend) 180, 150, 105
!    for i=igh-1 step -1 until low+1 do
  105 do 140 ii = 1, iend
     i = igh - ii
     if (ortr(i) == 0.d0 .and. orti(i) == 0.d0) go to 140
     if (hr(i,i-1) == 0.d0 .and. hi(i,i-1) == 0.d0) go to 140
!    norm below is negative of h formed in dcorth
     norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
     ip1 = i + 1
!
     do 110 k = ip1, igh
        ortr(k) = hr(k,i-1)
        orti(k) = hi(k,i-1)
  110    continue
!
     do 130 j = i, igh
        sr = 0.d0
        si = 0.d0
!
        do 115 k = i, igh
           sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
           si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
  115       continue
!
        sr = sr / norm
        si = si / norm
!
        do 120 k = i, igh
           zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
           zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
  120       continue
!
  130    continue
!
  140 continue
!    create real subdiagonal elements
  150 l = low + 1
!
  do 170 i = l, igh
     ll = min (i+1,igh)
     if (hi(i,i-1) == 0.d0) go to 170
     norm = dcpabs(hr(i,i-1),hi(i,i-1))
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.d0
!
     do 155 j = i, n
        si = yr * hi(i,j) - yi * hr(i,j)
        hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
        hi(i,j) = si
  155    continue
!
     do 160 j = 1, ll
        si = yr * hi(j,i) + yi * hr(j,i)
        hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
        hi(j,i) = si
  160    continue
!
     do 165 j = low, igh
        si = yr * zi(j,i) + yi * zr(j,i)
        zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
        zi(j,i) = si
  165    continue
!
  170 continue
!    store roots isolated by dcbal
  180 do 200 i = 1, n
     if (i >= low .and. i <= igh) go to 200
     wr(i) = hr(i,i)
     wi(i) = hi(i,i)
  200 continue
!
  en = igh
  tr = 0.d0
  ti = 0.d0
!    search for next eigenvalue
  220 if (en < low) go to 680
  its = 0
  enm1 = en - 1
!    look for single small sub-diagonal element
!                for l=en step -1 until low do
  240 do 260 ll = low, en
     l = en + low - ll
     if (l == low) go to 300
     if (dabs(hr(l,l-1)) <= &
        machep * (dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1)) &
               + dabs(hr(l,l)) + dabs(hi(l,l)))) go to 300
  260 continue
!    form shift
  300 if (l == en) go to 660
  if (its == 50) go to 1000
  if (its == 10 .or. its == 20 .or. its == 30) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if (xr == 0.d0 .and. xi == 0.d0) go to 340
  yr = (hr(enm1,enm1) - sr) / 2.d0
  yi = (hi(enm1,enm1) - si) / 2.d0
  z(1) = yr*yr - yi*yi + xr
  z(2) = 2.d0*yr*yi + xi
  call dcsqrt(z,w)
  zzr = w(1)
  zzi = w(2)
  if (yr * zzr + yi * zzi >= 0.d0) go to 310
  zzr = -zzr
  zzi = -zzi
  310 z(1) = yr + zzr
  z(2) = yi + zzi
  r2 = z(1)**2 + z(2)**2
  sr = sr - (xr*z(1) + xi*z(2))/r2
  si = si - (xi*z(1) - xr*z(2))/r2
  go to 340
!    form exceptional shift
  320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
  si = 0.d0
!
  340 do 360 i = low, en
     hr(i,i) = hr(i,i) - sr
     hi(i,i) = hi(i,i) - si
  360 continue
!
  tr = tr + sr
  ti = ti + si
  its = its + 1
!    reduce to triangle (rows)
  lp1 = l + 1
!
  do 500 i = lp1, en
     sr = hr(i,i-1)
     hr(i,i-1) = 0.d0
     norm = dsqrt(hr(i-1,i-1)*hr(i-1,i-1)+hi(i-1,i-1)*hi(i-1,i-1) &
                 + sr*sr)
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.d0
     hi(i,i-1) = sr / norm
!
     do 490 j = i, n
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
  490    continue
!
  500 continue
!
  si = hi(en,en)
  if (si == 0.d0) go to 540
  norm = dcpabs(hr(en,en),si)
  sr = hr(en,en) / norm
  si = si / norm
  hr(en,en) = norm
  hi(en,en) = 0.d0
  if (en == n) go to 540
  ip1 = en + 1
!
  do 520 j = ip1, n
     yr = hr(en,j)
     yi = hi(en,j)
     hr(en,j) = sr * yr + si * yi
     hi(en,j) = sr * yi - si * yr
  520 continue
!    inverse operation (columns)
  540 do 600 j = lp1, en
     xr = wr(j-1)
     xi = wi(j-1)
!
     do 580 i = 1, j
        yr = hr(i,j-1)
        yi = 0.d0
        zzr = hr(i,j)
        zzi = hi(i,j)
        if (i == j) go to 560
        yi = hi(i,j-1)
        hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
  560       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  580    continue
!
     do 590 i = low, igh
        yr = zr(i,j-1)
        yi = zi(i,j-1)
        zzr = zr(i,j)
        zzi = zi(i,j)
        zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
        zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  590    continue
!
  600 continue
!
  if (si == 0.d0) go to 240
!
  do 630 i = 1, en
     yr = hr(i,en)
     yi = hi(i,en)
     hr(i,en) = sr * yr - si * yi
     hi(i,en) = sr * yi + si * yr
  630 continue
!
  do 640 i = low, igh
     yr = zr(i,en)
     yi = zi(i,en)
     zr(i,en) = sr * yr - si * yi
     zi(i,en) = sr * yi + si * yr
  640 continue
!
  go to 240
!    a root found
  660 hr(en,en) = hr(en,en) + tr
  wr(en) = hr(en,en)
  hi(en,en) = hi(en,en) + ti
  wi(en) = hi(en,en)
  en = enm1
  go to 220
!    all roots found.  backsubstitute to find
!                vectors of upper triangular form
  680 norm = 0.d0
!
  do 720 i = 1, n
!
     do 720 j = i, n
        norm = norm + dabs(hr(i,j)) + dabs(hi(i,j))
  720 continue
!
  if (n == 1 .or. norm == 0.d0) go to 1001
!    for en=n step -1 until 2 do
  do 800 nn = 2, n
     en = n + 2 - nn
     xr = wr(en)
     xi = wi(en)
     enm1 = en - 1
!    for i=en-1 step -1 until 1 do
     do 780 ii = 1, enm1
        i = en - ii
        zzr = hr(i,en)
        zzi = hi(i,en)
        if (i == enm1) go to 760
        ip1 = i + 1
!
        do 740 j = ip1, enm1
           zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
           zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
  740       continue
!
  760       yr = xr - wr(i)
        yi = xi - wi(i)
        if (yr == 0.d0 .and. yi == 0.d0) yr = machep * norm
        r2 = yr*yr + yi*yi
        hr(i,en) = (zzr*yr + zzi*yi)/r2
        hi(i,en) = (zzi*yr - zzr*yi)/r2
  780    continue
!
  800 continue
!    end backsubstitution
  enm1 = n - 1
!    vectors of isolated roots
  do  840 i = 1, enm1
     if (i >= low .and. i <= igh) go to 840
     ip1 = i + 1
!
     do 820 j = ip1, n
        zr(i,j) = hr(i,j)
        zi(i,j) = hi(i,j)
  820    continue
!
  840 continue
!    multiply by transformation matrix to give
!                vectors of original full matrix.
!                for j=n step -1 until low+1 do
  do 880 jj = low, enm1
     j = n + low - jj
     m = min (j-1,igh)
!
     do 880 i = low, igh
        zzr = zr(i,j)
        zzi = zi(i,j)
!
        do 860 k = low, m
           zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
           zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
  860       continue
!
        zr(i,j) = zzr
        zi(i,j) = zzi
  880 continue
!
  go to 1001
!    set error -- no convergence to an
!                eigenvalue after 50 iterations
 1000 ierr = en
 1001 return
!    last card of dcmqr2
end
subroutine dcmslv (mo,n,m,ar,ai,ka,br,bi,kb,ierr,ipvt,wk)
!
!*******************************************************************************
!
!! DCMSLV: partial pivot gauss procedure for double precision complex equations.
!
  double precision ar(ka,n), ai(ka,n), br(*), bi(*), wk(*)
  integer ipvt(n)
!
  if (n < 1 .or. ka  <  n) go to 20
!
!                      matrix factorization
!
  call dcfact (ar, ai, ka, n, ipvt, ierr)
  if (ierr /= 0) return
!
!                 solution of the equation ax = b
!
  if (m <= 0) go to 10
  if (kb < n) go to 20
  call dcsol (n, m, ar, ai, ka, br, bi, kb, ipvt)
!
!                 calculation of the inverse of a
!
   10 if (mo == 0) call dcminv (ar, ai, ka, n, ipvt, wk)
  return
!
!                          error return
!
   20 ierr = -1
  return
end
subroutine dcomqr(nm,n,low,igh,hr,hi,wr,wi,ierr)
!
!*******************************************************************************
!
!! DCOMQR: eigenvalues of a double precision complex upper hessenberg matrix
!  by the qr method.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dcbal.  if dcbal has not been used,
!          set low=1, igh=n,
!
!        hr and hi contain the real and imaginary parts,
!          respectively, of the complex upper hessenberg matrix.
!          their lower triangles below the subdiagonal contain
!          information about the unitary transformations used in
!          the reduction by dcorth, if performed.
!
!     on output-
!
!        the upper hessenberg portions of hr and hi have been
!          destroyed.  therefore, they must be saved before
!          calling dcomqr if subsequent calculation of
!          eigenvectors is to be performed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  if an error
!          exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 50 iterations.
!
  integer i,j,l,n,en,ll,nm,igh,its,low,lp1,enm1,ierr
  double precision hr(nm,n),hi(nm,n),wr(n),wi(n)
  double precision si,sr,ti,tr,xi,xr,yi,yr,zzi,zzr,norm,machep
  double precision r2,w(2),z(2)
  double precision dpmpar,dcpabs
!
  machep = epsilon ( machep )
  ierr = 0
  if (low == igh) go to 180
!    create real subdiagonal elements
  l = low + 1
!
  do 170 i = l, igh
     ll = min (i+1,igh)
     if (hi(i,i-1) == 0.d0) go to 170
     norm = dcpabs(hr(i,i-1),hi(i,i-1))
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.d0
!
     do 155 j = i, igh
        si = yr * hi(i,j) - yi * hr(i,j)
        hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
        hi(i,j) = si
  155    continue
!
     do 160 j = low, ll
        si = yr * hi(j,i) + yi * hr(j,i)
        hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
        hi(j,i) = si
  160    continue
!
  170 continue
!    store roots isolated by dcbal
  180 do 200 i = 1, n
     if (i >= low .and. i <= igh) go to 200
     wr(i) = hr(i,i)
     wi(i) = hi(i,i)
  200 continue
!
  en = igh
  tr = 0.d0
  ti = 0.d0
!    search for next eigenvalue
  220 if (en < low) go to 1001
  its = 0
  enm1 = en - 1
!    look for single small sub-diagonal element
!                for l=en step -1 until low  --
  240 do 260 ll = low, en
     l = en + low - ll
     if (l == low) go to 300
     if (dabs(hr(l,l-1)) <= &
        machep * (dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1)) &
               + dabs(hr(l,l)) + dabs(hi(l,l)))) go to 300
  260 continue
!    form shift
  300 if (l == en) go to 660
  if (its == 50) go to 1000
  if (its == 10 .or. its == 20 .or. its == 30) go to 320
  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if (xr == 0.d0 .and. xi == 0.d0) go to 340
  yr = (hr(enm1,enm1) - sr) / 2.d0
  yi = (hi(enm1,enm1) - si) / 2.d0
  z(1) = yr*yr - yi*yi + xr
  z(2) = 2.d0*yr*yi + xi
  call dcsqrt(z,w)
  zzr = w(1)
  zzi = w(2)
  if (yr * zzr + yi * zzi >= 0.d0) go to 310
  zzr = -zzr
  zzi = -zzi
  310 z(1) = yr + zzr
  z(2) = yi + zzi
  r2 = z(1)**2 + z(2)**2
  sr = sr - (xr*z(1) + xi*z(2))/r2
  si = si - (xi*z(1) - xr*z(2))/r2
  go to 340
!    form exceptional shift
  320 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
  si = 0.d0
!
  340 do 360 i = low, en
     hr(i,i) = hr(i,i) - sr
     hi(i,i) = hi(i,i) - si
  360 continue
!
  tr = tr + sr
  ti = ti + si
  its = its + 1
!    reduce to triangle (rows)
  lp1 = l + 1
!
  do 500 i = lp1, en
     sr = hr(i,i-1)
     hr(i,i-1) = 0.d0
     norm = dsqrt(hr(i-1,i-1)*hr(i-1,i-1)+hi(i-1,i-1)*hi(i-1,i-1) &
                 + sr*sr)
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.d0
     hi(i,i-1) = sr / norm
!
     do 490 j = i, en
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
  490    continue
!
  500 continue
!
  si = hi(en,en)
  if (si == 0.d0) go to 540
  norm = dcpabs(hr(en,en),si)
  sr = hr(en,en) / norm
  si = si / norm
  hr(en,en) = norm
  hi(en,en) = 0.d0
!    inverse operation (columns)
  540 do 600 j = lp1, en
     xr = wr(j-1)
     xi = wi(j-1)
!
     do 580 i = l, j
        yr = hr(i,j-1)
        yi = 0.d0
        zzr = hr(i,j)
        zzi = hi(i,j)
        if (i == j) go to 560
        yi = hi(i,j-1)
        hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
  560       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
  580    continue
!
  600 continue
!
  if (si == 0.d0) go to 240
!
  do 630 i = l, en
     yr = hr(i,en)
     yi = hi(i,en)
     hr(i,en) = sr * yr - si * yi
     hi(i,en) = sr * yi + si * yr
  630 continue
!
  go to 240
!    a root found
  660 wr(en) = hr(en,en) + tr
  wi(en) = hi(en,en) + ti
  en = enm1
  go to 220
!    set error -- no convergence to an
!                eigenvalue after 50 iterations
 1000 ierr = en
 1001 return
end
subroutine dcopy(n,dx,incx,dy,incy)
!
!*******************************************************************************
!
!! DCOPY copies a vector, x, to a vector, y.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dx(*),dy(*)
  integer i,incx,incy,ix,iy,m,mp1,n
!
  if(n <= 0)return
  if(incx==1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    dy(iy) = dx(ix)
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,7)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dy(i) = dx(i)
   30 continue
  if( n < 7 ) return
   40 mp1 = m + 1
  do 50 i = mp1,n,7
    dy(i) = dx(i)
    dy(i + 1) = dx(i + 1)
    dy(i + 2) = dx(i + 2)
    dy(i + 3) = dx(i + 3)
    dy(i + 4) = dx(i + 4)
    dy(i + 5) = dx(i + 5)
    dy(i + 6) = dx(i + 6)
   50 continue
  return
end
subroutine dcorth(nm,n,low,igh,ar,ai,ortr,orti)
!
!*******************************************************************************
!
!! DCORTH reduces a double precision complex matrix to upper hessenberg form.
!
!
!     given a double precision complex matrix, dcorth
!     reduces a submatrix situated in rows and columns
!     low through igh to upper hessenberg form by
!     unitary similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dcbal.  if dcbal has not been used,
!          set low=1, igh=n,
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the complex input matrix.
!
!     on output-
!
!        ar and ai contain the real and imaginary parts,
!          respectively, of the hessenberg matrix.  information
!          about the unitary transformations used in the reduction
!          is stored in the remaining triangles under the
!          hessenberg matrix,
!
!        ortr and orti contain further information about the
!          transformations.  only elements low through igh are used.
!
  integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
  double precision ar(nm,n),ai(nm,n),ortr(igh),orti(igh)
  double precision f,g,h,fi,fr,scale
  double precision dcpabs
!
  la = igh - 1
  kp1 = low + 1
  if (la < kp1) go to 200
!
  do 180 m = kp1, la
     h = 0.d0
     ortr(m) = 0.d0
     orti(m) = 0.d0
     scale = 0.d0
!    scale column (algol tol then not needed)
     do 90 i = m, igh
   90    scale = scale + dabs(ar(i,m-1)) + dabs(ai(i,m-1))
!
     if (scale == 0.d0) go to 180
     mp = m + igh
!    for i=igh step -1 until m do --
     do 100 ii = m, igh
        i = mp - ii
        ortr(i) = ar(i,m-1) / scale
        orti(i) = ai(i,m-1) / scale
        h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
  100    continue
!
     g = dsqrt(h)
     f = dcpabs(ortr(m),orti(m))
     if (f == 0.d0) go to 103
     h = h + f * g
     g = g / f
     ortr(m) = (1.d0 + g) * ortr(m)
     orti(m) = (1.d0 + g) * orti(m)
     go to 105
!
  103    ortr(m) = g
     ar(m,m-1) = scale
!    form (i-(u*ut)/h) * a
  105    do 130 j = m, n
        fr = 0.d0
        fi = 0.d0
!    for i=igh step -1 until m do --
        do 110 ii = m, igh
           i = mp - ii
           fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
           fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
  110       continue
!
        fr = fr / h
        fi = fi / h
!
        do 120 i = m, igh
           ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
           ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
  120       continue
!
  130    continue
!    form (i-(u*ut)/h)*a*(i-(u*ut)/h)
     do 160 i = 1, igh
        fr = 0.d0
        fi = 0.d0
!    for j=igh step -1 until m do --
        do 140 jj = m, igh
           j = mp - jj
           fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
           fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
  140       continue
!
        fr = fr / h
        fi = fi / h
!
        do 150 j = m, igh
           ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
           ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
  150       continue
!
  160    continue
!
     ortr(m) = scale * ortr(m)
     orti(m) = scale * orti(m)
     ar(m,m-1) = -g * ar(m,m-1)
     ai(m,m-1) = -g * ai(m,m-1)
  180 continue
!
  200 return

end
function dcpabs(x, y)
!
!*******************************************************************************
!
!! DCPABS: evaluation of sqrt(x*x + y*y)
!
  double precision dcpabs
  double precision a
  double precision x, y
!
  if (dabs(x) <= dabs(y)) go to 10
     a = y/x
     dcpabs = dabs(x)*dsqrt(1.d0 + a*a)
     return
   10 if (y == 0.d0) go to 20
     a = x/y
     dcpabs = dabs(y)*dsqrt(1.d0 + a*a)
     return
   20 dcpabs = 0.d0
  return
end
subroutine dcply1 (opr,opi,ideg,idp1,zeror,zeroi,pr,pi,qpr,qpi, &
                     hr,hi,qhr,qhi,shr,shi,num)
!
!*******************************************************************************
!
!! DCPLY1 is a utility routine used by dcpoly.
!
  double precision opr(idp1),opi(idp1),zeror(ideg),zeroi(ideg), &
                   pr(idp1),pi(idp1),qpr(idp1),qpi(idp1), &
                   hr(idp1),hi(idp1),qhr(idp1),qhi(idp1), &
                   shr(idp1),shi(idp1)
  double precision sr,si,tr,ti,pvr,pvi,are,mre,eta,infin
  double precision xx,yy,cosr,sinr,smalno,base,xxx,zr,zi,bnd, &
                   dcpabs,dpmpar,scalcp
  logical conv
  integer cnt1,cnt2
!
!     the following statements set the machine constants used
!     in the code. the meaning of the constants are
!
!     smalno  the smallest positive floating point number.
!     infin   the largest positive floating point number.
!     base    the base of the floating point arithmetic
!             being used.
!
  eta = epsilon ( eta )
  smalno = dpmpar(2)
  infin = huge ( infin )
  base = ipmpar(4)
!
!
!     initialization
!
     are = eta
     mre = 2.0d0*dsqrt(2.d0)*eta
     xx = 0.70710678
     yy = -xx
     cosr = -.069756474
     sinr = .99756405
     num = 0
     nn = idp1
!
!     the algorithm fails if the leading coefficient is zero
!
     if (opr(1) /= 0.d0 .or. opi(1) /= 0.d0) go to 10
        num = -1
        return
!
!     remove the zeros at the origin if any.
!
   10    if (opr(nn) /= 0.d0 .or. opi(nn) /= 0.d0) go to 20
        num = num + 1
        zeror(num) = 0.d0
        zeroi(num) = 0.d0
        nn = nn - 1
        go to 10
!
!     make a copy of the coefficients.
!
   20    if (nn < 2) return
     do 30 i = 1,nn
        pr(i) = opr(i)
        pi(i) = opi(i)
        shr(i) = dcpabs(pr(i),pi(i))
   30    continue
!
!     scale the polynomial.
!
     bnd = scalcp (nn,shr,eta,infin,smalno,base)
     if (bnd == 1.d0) go to 40
     do 35 i = 1,nn
        pr(i) = bnd*pr(i)
        pi(i) = bnd*pi(i)
   35    continue
!
!     start the algorithm for obtaining a zero.
!
   40    if (nn > 2) go to 50
!
        num = ideg
        call cdivid(-pr(2),-pi(2),pr(1),pi(1),zeror(ideg), &
                     zeroi(ideg))
        return
!
!     calculate bnd, a lower bound on the modulus of the zeros.
!
   50    do 60 i = 1,nn
        shr(i) = dcpabs(pr(i),pi(i))
   60    continue
     call cauchy(nn,bnd,shr,shi)
!
!     outer loop to control two major passes with different
!     sequences of shifts.
!
     do 80 cnt1 = 1,2
!
!     first stage calculation. no shift.
!
        call noshft(5,nn,tr,ti,eta,pr,pi,hr,hi)
!
!     inner loop to select a shift.
!
        do 70 cnt2 = 1,9
!
!     the shift is chosen with modulus bnd and amplitude rotated
!     by 94 degrees from the previous shift.
!
           xxx = cosr*xx - sinr*yy
           yy = sinr*xx + cosr*yy
           xx = xxx
           sr = bnd*xx
           si = bnd*yy
!
!     second stage calculation, fixed shift. the second stage jumps
!     directly to the third stage iteration.
!
           call fxshft(10*cnt2,zr,zi,conv,nn,pr,pi,hr,hi,qpr,qpi, &
                       qhr,qhi,shr,shi,sr,si,tr,ti,pvr,pvi, &
                       are,mre,eta,infin)
           if (conv) go to 100
!
!     if the iteration is unsuccessful another shift is chosen.
!
   70       continue
!
!     if 9 shifts fail, the outer loop is repeated with another
!     sequence of shifts.
!
   80    continue
     return
!
!     a zero has been obtained. store the zero and deflate
!     the polynomial.
!
  100    num = num + 1
     zeror(num) = zr
     zeroi(num) = zi
     nn = nn - 1
     do 110 i = 1,nn
        pr(i) = qpr(i)
        pi(i) = qpi(i)
  110    continue
     go to 40
end
subroutine dcpoly (opr,opi,ideg,zeror,zeroi,num,wk)
!
!*******************************************************************************
!
!! DCPOLY finds the zeros of a complex polynomial.
!
!     opr,opi     - double precision arrays of length ideg + 1.
!                   on input these arrays contain the real and imaginary
!                   parts of the coefficients in order of decreasing
!                   powers.
!
!     ideg        - integer degree of the polynomial.
!
!     zeror,zeroi - double precision arrays of length ideg.
!                   on output these arrays contain the real and
!                   imaginary parts of the zeros.
!
!     num         - variable that reports the status of the results.
!                   if num = -1 then the leading coefficient of the
!                   polynomial is 0 or ideg < 1. otherwise, num
!                   is the number of zeros that were obtained. if
!                   num >= 1 then the real and imaginary parts of
!                   the zeros are stored in zeror(j) and zeroi(j)
!                   for j = 1,...,num.
!
!     wk          - double precision array of length 10*(ideg + 1).
!                   the array is a work space for the routine.
!
!     the code has been written to reduce the chance of overflow
!     occurring. if it does occur, there is still a possibility that
!     the zerofinder will work provided the overflowed quantity is
!     replaced by a large number.
!
  integer ideg
  double precision opr(*),opi(*),zeror(ideg),zeroi(ideg),wk(*)
!
  integer pr,pi,qpr,qpi,hr,hi,qhr,qhi,shr,shi
!
  if (ideg < 1) go to 10
!
!     partition the workspace and obtain the zeros
!
  idp1 = ideg + 1
!
  pr  = 1
  pi  = pr +  idp1
  qpr = pi +  idp1
  qpi = qpr + idp1
  hr  = qpi + idp1
  hi  = hr  + idp1
  qhr = hi  + idp1
  qhi = qhr + idp1
  shr = qhi + idp1
  shi = shr + idp1
!
  call dcply1 (opr,opi,ideg,idp1,zeror,zeroi,wk(pr),wk(pi), &
               wk(qpr),wk(qpi),wk(hr),wk(hi),wk(qhr),wk(qhi), &
               wk(shr),wk(shi),num)
  return
!
!     error return
!
   10 num = -1
  return
end
subroutine dcpsc (fun, x, y, n, ic, tol, r, rs1, rs2, err)
!
!*******************************************************************************
!
!! DCPSC: evaluation of complex power series coefficients or derivatives.
!
!   input parameters
!    fun subroutine which computes the complex function f for which
!        the coefficients or derivatives are sought. we write
!                   call fun(u1,u2,w1,w2)
!        when w = f(u) is to be computed for the complex argument u.
!        here u1 and u2 are the real and imaginary parts of u, and w1
!        and w2 are the real and imaginary parts of w.  u1,u2,w1,w2
!        have double precision values. the subroutine fun must be
!        declared in the calling program to be of type external.
!    x   real part of the complex point around which f is to be
!        expanded or at which its derivatives are to be computed.
!    y   imaginary part of the complex point around which f is to be
!        expanded or at which its derivatives are to be computed.
!    n   integer, number of coefficients or derivatives wanted.
!        n must be ge 1 and le 51.
!    ic  selects between power series coefficients and derivatives.
!        ic == 0   routine returns power series coefficients in
!                    rs1 and rs2.
!        ic /= 0   routine returns derivatives in rs1 and rs2.
!    tol estimated relative accuracy of fun. it is assumed that tol
!        is nonnegative. if tol = 0 then fun is assumed to be correct
!        to machine accuracy.
!
!   input and output parameter
!    r   initial radius used in search for optimal radius. the resulting
!        radius is left in r. the provided guess may be in error with at
!        most a factor of 3.e4 .
!
! output parameters ***
!    rs1 array rs1(n) containing the real parts of the first n complex
!        coefficients (corresponding to the powers 0 to n-1) or deriva-
!        tives (orders 0 to n-1).
!    rs2 array rs2(n) containing the imaginary parts of the first n
!        coefficients (corresponding to the powers 0 to n-1) or deriva-
!        tives (orders 0 to n-1).
!    err real array err(n) containing absolute error estimates for the
!        complex numbers whose real and imaginary parts are in rs1,rs2.
!
  double precision x, y, tol, r, rs1(n), rs2(n), err(n)
!
  integer ip(32), iw(7)
  double precision ang,b,cm,cp,ct,cx,eps,eps0,ep6,fac,fact,pi, &
                   ra,r1,s,sf,sp,sr,t,u,v,w
  double precision c(4),fc(3),sc(4)
  double precision a1(64),a2(64),fv1(6),fv2(6),rt1(51,3),rt2(51,3), &
                   rv1(3),rv2(3)
  double precision dcpabs, dpmpar
!
!  list of the variables initialized in the data statement below.
!   iw   2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) .
!   ip   permutation constants for the fft.
!   rv1  real parts of the constants for the laurent series test.
!   rv2  imaginary parts of the constants for the laurent series test.
!
  data iw(1),iw(2),iw(3),iw(4),iw(5),iw(6),iw(7)/1,2,4,8,16,32,64/
  data ip( 1),ip( 2),ip( 3),ip( 4),ip( 5),ip( 6),ip( 7),ip( 8), &
       ip( 9),ip(10),ip(11),ip(12),ip(13),ip(14),ip(15),ip(16), &
       ip(17),ip(18),ip(19),ip(20),ip(21),ip(22),ip(23),ip(24), &
       ip(25),ip(26),ip(27),ip(28),ip(29),ip(30),ip(31),ip(32)/ &
       64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14, &
       54,22,38,6,58,26,42,10,50,18,34,2/
  data rv1(1)/-.4d0/, rv2(1)/.3d0/, &
       rv1(2)/ .7d0/, rv2(2)/.2d0/, &
       rv1(3)/.02d0/, rv2(3)/-.06d0/
!
  eps0 = epsilon ( eps0 )
!
!  initialization.
!
  eps = dmax1(eps0,tol)
  sc(1) = .125d0
  c(1) = eps**(1.d0/28.d0)
  ep6 = c(1)**6
  pi = 4.d0*datan(1.d0)
  fv1(1) = -1.d0
  fv2(1) =  0.d0
  fv1(2) =  0.d0
  fv2(2) = -1.d0
  r1 = dsqrt(0.5d0)
  ra = 1.d0/r1
  fv1(3) =  r1
  fv2(3) = -r1
  do 10 i = 2,4
     sc(i) = 0.5d0*sc(i-1)
     c(i) = dsqrt(c(i-1))
     ang = pi*sc(i-1)
     fv1(i + 2) =  dcos(ang)
   10    fv2(i + 2) = -dsin(ang)
!
!  start execution.
!
  if (n > 51 .or. n < 1) go to 260
  l2 = 1
  lf = 0
  np = 0
  m = 0
  nr = -1
!
!  find if a fft over 8, 16, 32, or 64 points should be used.
!
  kl = 1
  if (n > 6) kl = 2
  if (n > 12) kl = 3
  if (n > 25) kl = 4
  km = kl + 2
  kn = 7 - km
  ix = iw(km + 1)
  is = iw(kn)
   30 u = r
  v = 0.d0
!
!  function values of f are stored ready permutated for the fft.
!
  do 40 i = is,32,is
     iq = ip(i)
     t = u*fv1(km) - v*fv2(km)
     v = u*fv2(km) + v*fv1(km)
     u = t
     call fun(x + u, y + v, a1(iq), a2(iq))
     call fun(x - u, y - v, a1(iq-1), a2(iq-1))
   40 continue
  ln = 2
  jn = 1
!
!  the loop  do 70 ... constitutes the fft.
!
  do 70 l = 1,km
     u = 1.0
     v = 0.0
     do 60 j = 1,jn
        do 50 i = j,ix,ln
           it = i + jn
           s = u*a1(it) - v*a2(it)
           t = u*a2(it) + v*a1(it)
           a1(it) = a1(i) - s
           a2(it) = a2(i) - t
           a1(i) = a1(i) + s
   50          a2(i) = a2(i) + t
        t = u*fv1(l) - v*fv2(l)
        v = u*fv2(l) + v*fv1(l)
   60       u = t
     ln = ln + ln
   70    jn = jn + jn
  cx = 0.d0
  b = 1.d0
!
!  test on how fast the coefficients obtained decrease.
!
  do 80 i = 1,ix
     ct = dcpabs(a1(i),a2(i))/b
     if (ct < cx) go to 80
     cx = ct
     inr = i
   80    b = b*c(kl)
  if (m <= 1) go to 100
!
!  estimate of the rounding error level for the last radius.
!
  err(1) = cx*eps
  do 90 i = 2,n
   90    err(i) = err(i-1)/r
!
  100 sf = sc(kl)
  do 110 i = 1,ix
     a1(i) = sf*a1(i)
     a2(i) = sf*a2(i)
  110    sf = sf/r
  l1 = l2
  l2 = 1
  if (inr > iw(km)) go to 150
  if (lf == 1) go to 140
!
!  test if the series is a taylor or a laurent series.
!
  sr = 0.d0
  sp = 0.d0
  do 130 j = 1,3
     s = a1(ix)
     t = a2(ix)
     u = r*rv1(j)
     v = r*rv2(j)
     do 120 i = 2,ix
        ia = ix + 1 - i
        w = (s*u - t*v) + a1(ia)
        t = (s*v + t*u) + a2(ia)
  120       s = w
     cp = dcpabs(s,t)
     if (cp > sp) sp = cp
     call fun(x + u, y + v, u, v)
     cm = dcpabs(s - u, t - v)
  130    if (cm > sr) sr = cm
  if (sr > 1.d-3*sp) go to 150
  lf = 1
  140 l2 = -1
!
!  determination of the next radius to be used.
!
  150 if (nr >= 0) go to 160
     fact = 2.d0
     if (l2 == 1) fact = 0.5d0
     l1 = l2
     nr = 0
  160 if (l1 /= l2) go to 180
     if (nr > 0) go to 170
        np = np + 1
        if (np-15) 190,190,260
  170    fact = 1.d0/fact
  180 fact = 1.d0/dsqrt(fact)
  nr = nr + 1
  190 r = r*fact
  m = nr - kl - 1
  if (m <= 0) go to 30
!
!  the results for the last three radii are stored.
!
  do 200 i = 1,n
     rt1(i,m) = a1(i)
  200    rt2(i,m) = a2(i)
  if (m == 1) go to 220
!
!  extrapolation.
!
  mm1 = m - 1
  do 210 i = 1,n
     u = rt1(i,mm1) - rt1(i,m)
     v = rt2(i,mm1) - rt2(i,m)
     rt1(i,mm1) = rt1(i,m) - fc(mm1)*u
  210    rt2(i,mm1) = rt2(i,m) - fc(mm1)*v
  if (m == 3) go to 230
!
!  calculation of the extrapolation constants.
!
  220 fc(m) = 1.5d0 + dsign(0.5d0,fact-1.d0)
  if (m == 2) fc(m) = fc(m) + ra
  if (fact > 1.d0) fc(m) = -fc(m)
  go to 30
  230 fc(3) = fc(1)*fc(2)/(fc(1) + fc(2) + 1.d0)
!
!  final extrapolation and error estimate.
!
  do 240 i = 1,n
     u = rt1(i,1) - rt1(i,2)
     v = rt2(i,1) - rt2(i,2)
     err(i) = err(i) + ep6*dcpabs(u,v)
     rs1(i) = rt1(i,2) - fc(3)*u
  240    rs2(i) = rt2(i,2) - fc(3)*v
!
!  multiply power series coefficients and error estimate by factorials
!  if derivatives wanted.
!
  if (ic == 0) return
  fac = 0.d0
  fact = 1.d0
  do 250 i = 1,n
     rs1(i) = fact*rs1(i)
     rs2(i) = fact*rs2(i)
     err(i) = fact*err(i)
     fac = fac + 1.d0
  250    fact = fact*fac
  return
!
!  error return.
!
  260 do 270 i = 1,n
     rs1(i) = 0.d0
     rs2(i) = 0.d0
  270    err(i) = 1.d10
  return
end
subroutine dcpsi (z, w)
!
!*******************************************************************************
!
!! DCPSI: evaluation of the complex digamma function
!
  integer imax
  double precision z(2), w(2)
  double precision c0(30), pi, pi2
  double precision a, a1, a2, cn, cut, c1, c2, eps, et, h1, h2, &
                   q1, q2, s, sn, s1, s2, t, t1, t2, u, u1, u2, &
                   v1, v2, w1, w2, x, y, y2
  double precision drexp, dpmpar
!
!     pi2 = 2*pi
!
  data pi   /3.141592653589793238462643383279502884197d0/
  data pi2  /6.283185307179586476925286766559005768394d0/
!
  data c0(1)  / .8333333333333333333333333333333333333333d-01/, &
       c0(2)  /-.8333333333333333333333333333333333333333d-02/, &
       c0(3)  / .3968253968253968253968253968253968253968d-02/, &
       c0(4)  /-.4166666666666666666666666666666666666667d-02/, &
       c0(5)  / .7575757575757575757575757575757575757576d-02/, &
       c0(6)  /-.2109279609279609279609279609279609279609d-01/, &
       c0(7)  / .8333333333333333333333333333333333333333d-01/, &
       c0(8)  /-.4432598039215686274509803921568627450980d+00/, &
       c0(9)  / .3053954330270119743803954330270119743804d+01/, &
       c0(10) /-.2645621212121212121212121212121212121212d+02/
  data c0(11) / .2814601449275362318840579710144927536232d+03/, &
       c0(12) /-.3607510546398046398046398046398046398046d+04/, &
       c0(13) / .5482758333333333333333333333333333333333d+05/, &
       c0(14) /-.9749368238505747126436781609195402298851d+06/, &
       c0(15) / .2005269579668807894614346227249453055905d+08/, &
       c0(16) /-.4723848677216299019607843137254901960784d+09/, &
       c0(17) / .1263572479591666666666666666666666666667d+11/, &
       c0(18) /-.3808793112524536881155302207933786881155d+12/, &
       c0(19) / .1285085049930508333333333333333333333333d+14/, &
       c0(20) /-.4824144835485017037158167036215816703622d+15/
  data c0(21) / .2004031065651625273810842166323893898645d+17/, &
       c0(22) /-.9167743603195330775699275362318840579710d+18/, &
       c0(23) / .4597988834365650349043794326241134751773d+20/, &
       c0(24) /-.2518047192145109569708902332022552610788d+22/, &
       c0(25) / .1500173349215392873371144015151515151515d+24/, &
       c0(26) /-.9689957887463594065649794289465408805031d+25/, &
       c0(27) / .6764588237929282099094524230179847767567d+27/, &
       c0(28) /-.5089065946866228968976633291591192528736d+29/, &
       c0(29) / .4114728879255797869766548606761933615819d+31/, &
       c0(30) /-.3566658209537555610968457460865182898779d+33/
!
  imax = huge ( imax )
  eps = epsilon ( eps )
  x = z(1)
  y = z(2)
  if (x >= 0.d0) go to 40
!
!            case when the real part of z is negative
!
  y = dabs(y)
  t = -pi2*y
  et = dexp(t)
!
!     set  a1 = (1 + et)/2  and  a2 = (1 - et)/2
!
  a1 = 0.5d0*(1.d0 + et)
  if (t < -0.15d0) go to 10
     a2 = -0.5d0*drexp(t)
     go to 20
   10 a2 = 0.5d0*(0.5d0 + (0.5d0 - et))
!
!     compute sin(pi*x) and cos(pi*x), or -sin(pi*x) and -cos(pi*x)
!
   20 u = imax
  if (dabs(x) >= dmin1(u, 1.d0/eps)) go to 100
  k = dabs(x)
  u = x + k
  if (u <= -0.5d0) u = 0.5d0 + (0.5d0 + u)
  u = pi*u
  sn = dsin(u)
  cn = dcos(u)
!
!     set h1 + h2*i = pi*cot(pi*z)
!
  s1 = a1*sn
  s2 = a2*cn
  c1 = a1*cn
  c2 = -a2*sn
  s = s1*s1 + s2*s2
  h1 = pi*(s1*c1 + s2*c2)/s
  h2 = pi*(s1*c2 - s2*c1)/s
!
  if (z(2) < 0.d0) go to 30
     x = 1.d0 - x
     y = -y
     go to 40
   30 h2 = -h2
  x = 1.d0 - x
!
!           case when the real part of z is nonnegative
!
   40 t = x
  y2 = y*y
  a = x*x + y2
  if (a == 0.d0) go to 100
  cut = 225.d0
  if (eps > 1.d-30) cut = 144.d0
!
!     let s1 + s2*i be the sum of the terms 1/(z+j) for j = 0,1,...,n-1
!
  s1 = 0.d0
  s2 = 0.d0
   50    if (a >= cut) go to 51
     s1 = s1 + t/a
     s2 = s2 - y/a
     t = t + 1.d0
     a = t*t + y2
     go to 50
   51 continue
!
!     set w1 + w2*i = log(z+n)
!
  w1 = 0.5d0*dlog(a)
  w2 = datan2(y,t)
!
!     let a1 + a2*i be the asymptotic sum
!
  u1 = t/a
  u2 = -y/a
  q1 = u1*u1 - u2*u2
  q2 = 2.d0*u1*u2
  v1 = q1
  v2 = q2
  a1 = 0.d0
  a2 = 0.d0
  m = 30
  if (eps > 1.d-30) m = 25
  do 61 j = 1,m
     t1 = a1
     t2 = a2
     a1 = a1 + c0(j)*v1
     a2 = a2 + c0(j)*v2
     if (a1 /= t1) go to 60
     if (a2 == t2) go to 70
   60    t1 = v1*q1 - v2*q2
     t2 = v1*q2 + v2*q1
     v1 = t1
   61    v2 = t2
!
!                 gathering together the results
!
   70 a1 = a1 + 0.5d0*u1
  a2 = a2 + 0.5d0*u2
  w(1) = (w1 - a1) - s1
  w(2) = (w2 - a2) - s2
  if (z(1) >= 0.d0) return
  w(1) = w(1) - h1
  w(2) = w(2) - h2
  return
!
!             the requested value cannot be computed
!
  100 w(1) = 0.d0
  w(2) = 0.d0
  return
end
subroutine dcrec (x, y, u, v)
!
!*******************************************************************************
!
!! DCREC: complex reciprocal u + i*v = 1/(x + i*y)
!
  double precision x, y, u, v
  double precision d, t
!
  if (dabs(x) > dabs(y)) go to 10
     t = x/y
     d = y + t*x
     u = t/d
     v = -1.d0/d
     return
   10 t = y/x
  d = x + t*y
  u = 1.d0/d
  v = -t/d
  return
end
function dcsevl (x, a, n)
!
!*******************************************************************************
!
!! DCSEVL: evaluate the n term chebyshev series a at x.
!          only half of the first coefficient is used.
!
  double precision dcsevl
  double precision a(n),x,x2,s0,s1,s2
!
  if (n > 1) go to 10
     dcsevl = 0.5d0 * a(1)
     return
!
   10 x2 = x + x
  s0 = a(n)
  s1 = 0.d0
  do 20 i = 2,n
     s2 = s1
     s1 = s0
     k = n - i + 1
     s0 = x2*s1 - s2 + a(k)
   20 continue
  dcsevl = 0.5d0 * (s0 - s2)
  return
end
subroutine dcsol (n, m, ar, ai, ka, br, bi, kb, ipvt)
!
!*******************************************************************************
!
!! DCSOL: solution of system of m equations a*x = b factored by dcfact.
!
!     this routine cannot be
!     used when dcfact terminates with nonzero ierr.
!
!
!     input
!
!        ar and ai contain the lu decomposition of the matrix
!        obtained by dcfact.
!
!        ka = declared row dimension of the arrays ar and ai
!
!        n  = order of the matrix
!
!        br and bi are the real and imaginary parts of the
!        right hand side matrix.
!
!        kb = declared row dimension of the arrays br and bi
!
!        m  = number of columns of b
!
!        ipvt = pivot vector obtained from dcfact
!
!     output ...
!
!        br and bi contain the real and imaginary parts of the
!        solution x.
!
!
  double precision ar(ka,n), ai(ka,n), br(kb,m), bi(kb,m)
  integer ipvt(n)
  double precision pr, pi, tr, ti
!
!                    forward elimination
!
  if (n == 1) go to 50
  nm1 = n - 1
  do 20 k = 1, nm1
     kp1 = k + 1
     l = ipvt(k)
     do 11 j = 1,m
        tr = br(l,j)
        br(l,j) = br(k,j)
        br(k,j) = tr
        ti = bi(l,j)
        bi(l,j) = bi(k,j)
        bi(k,j) = ti
        if (dabs(tr) + dabs(ti) == 0.d0) go to 11
        do 10 i = kp1, n
           br(i,j) = br(i,j) - ar(i,k)*tr + ai(i,k)*ti
           bi(i,j) = bi(i,j) - ar(i,k)*ti - ai(i,k)*tr
   10       continue
   11    continue
   20 continue
!
!                   backward elimination
!               for the last n - 1 variables
!
  do 40 l = 1,nm1
     km1 = n - l
     k = km1 + 1
     call cdivid (1.d0, 0.d0, ar(k,k), ai(k,k), pr, pi)
     do 31 j = 1,m
        tr = br(k,j)
        ti = bi(k,j)
        br(k,j) = tr*pr - ti*pi
        bi(k,j) = tr*pi + ti*pr
        tr = br(k,j)
        ti = bi(k,j)
        do 30 i = 1, km1
           br(i,j) = br(i,j) - ar(i,k)*tr + ai(i,k)*ti
           bi(i,j) = bi(i,j) - ar(i,k)*ti - ai(i,k)*tr
   30       continue
   31    continue
   40 continue
!
   50 call cdivid (1.d0, 0.d0, ar(1,1), ai(1,1), pr, pi)
  do 60 j = 1,m
     tr = br(1,j)
     ti = bi(1,j)
     br(1,j) = tr*pr - ti*pi
     bi(1,j) = tr*pi + ti*pr
   60 continue
  return
end
subroutine dcsqrt (z, w)
!
!*******************************************************************************
!
!! DCSQRT computes the square root of a double precision complex number.
!
!
!  w = sqrt(z) for the double precision complex number z
!
!
!     z and w are interpreted as double precision complex numbers.
!     it is assumed that z(1) and z(2) are the real and imaginary
!     parts of the complex number z, and that w(1) and w(2) are
!     the real and imaginary parts of w.
!
  double precision z(2), w(2)
!
  double precision x, y, r
  double precision dcpabs
!
  x = z(1)
  y = z(2)
  if (x) 30,10,20
!
   10 if (y /= 0.d0) go to 11
     w(1) = 0.d0
     w(2) = 0.d0
     return
   11 w(1) = dsqrt(0.5d0*dabs(y))
  w(2) = dsign(w(1),y)
  return
!
   20 if (y /= 0.d0) go to 21
     w(1) = dsqrt(x)
     w(2) = 0.d0
     return
   21 r = dcpabs(x,y)
  w(1) = dsqrt(0.5d0*(r + x))
  w(2) = 0.5d0*y/w(1)
  return
!
   30 if (y /= 0.d0) go to 31
     w(1) = 0.d0
     w(2) = dsqrt(dabs(x))
     return
   31 r = dcpabs(x,y)
  w(2) = dsqrt(0.5d0*(r - x))
  w(2) = dsign(w(2),y)
  w(1) = 0.5d0*y/w(2)
  return
end
function ddot(n,dx,incx,dy,incy)
!
!*******************************************************************************
!
!! DDOT forms the dot product of two vectors.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!
  double precision ddot
  double precision dx(*),dy(*),dtemp
  integer i,incx,incy,ix,iy,m,mp1,n
!
  ddot = 0.0d0
  dtemp = 0.0d0
  if(n <= 0)return
  if(incx==1.and.incy==1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    dtemp = dtemp + dx(ix)*dy(iy)
    ix = ix + incx
    iy = iy + incy
   10 continue
  ddot = dtemp
  return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dtemp = dtemp + dx(i)*dy(i)
   30 continue
  if( n < 5 ) go to 60
   40 mp1 = m + 1
  do 50 i = mp1,n,5
    dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + &
     dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
  return
end
subroutine ddsort (a, b, n)
!
!*******************************************************************************
!
!! DDSORT uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. the same permutations are
!     performed on b that are performed on a. it is assumed that n >= 1.
!
  double precision a(n), b(n), s, t
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 32 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
        t = b(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           b(ll) = b(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31       a(ll) = s
        b(ll) = t
   32    continue
!
   40 i = i - 1
  return
end
subroutine de1(f,neqn,y,t,tout,relerr,abserr,iflag, &
    yy,wt,p,yp,ypout,phi,alpha,beta,sig,v,w,g,phase1,psi,x,h,hold, &
    start,told,delsgn,ns,nornd,k,kold,isnold)
!
!*******************************************************************************
!
!! DE1 solves an ordinary differential equation set up by ode.
!
!
!   ode  merely allocates storage for  de1 to relieve the user of the
!   inconvenience of a long call list.  consequently  de1 is used as
!   described in the comments for  ode .
!
!   this code is completely explained and documented in the text,
!   computer solution of ordinary differential equations,  the initial
!   value problem  by l. f. shampine and m. k. gordon.
!
  logical stiff,crash,start,phase1,nornd
  dimension y(neqn),yy(neqn),wt(neqn),phi(neqn,16),p(neqn),yp(neqn), &
    ypout(neqn),psi(12),alpha(12),beta(12),sig(13),v(12),w(12),g(13)
  external f
!
!   the constant  maxnum  is the maximum number of steps allowed in one
!   call to  de1.  the user may change this limit by altering the
!   following statement
!
  data maxnum/500/
!
  u = epsilon ( u )
  fouru = 4.0*u
!
!   test for improper parameters
!
  if(neqn < 1) go to 10
  if(t == tout) go to 10
  if(relerr < 0.0  .or.  abserr  <  0.0) go to 10
  eps = max ( relerr,abserr)
  if(eps <= 0.0) go to 10
  if(iflag == 0) go to 10
  isn = isign(1,iflag)
  iflag = iabs(iflag)
  if(iflag == 1) go to 20
  if(t /= told) go to 10
  if(iflag >= 2  .and.  iflag <= 5) go to 20
  if(iflag == 6  .and.  abserr > 0.0) go to 20
 10   iflag = 7
  return
!
!   on each call set interval of integration and counter for number of
!   steps.  adjust input error tolerances to define weight vector for
!   subroutine  step1
!
 20   del = tout - t
  absdel = abs(del)
  tend = t + 10.0*del
  if(isn < 0) tend = tout
  nostep = 0
  kle4 = 0
  stiff = .false.
  releps = relerr/eps
  abseps = abserr/eps
  if(iflag == 1) go to 30
  if(isnold < 0) go to 30
  if(delsgn*del > 0.0) go to 50
!
!   on start and restart also set work variables x and yy(*), store the
!   direction of integration and initialize the step size
!
 30   start = .true.
  x = t
  do 40 l = 1,neqn
 40     yy(l) = y(l)
  delsgn = sign(1.0,del)
  h = sign(max ( fouru*abs(x),abs(tout-x)),tout-x)
!
!   if already past output point, interpolate and return
!
 50   if(abs(x-t) < absdel) go to 60
  call intrp(x,yy,tout,y,ypout,neqn,kold,phi,psi)
  iflag = 2
  t = tout
  told = t
  isnold = isn
  return
!
!   if cannot go past output point and sufficiently close,
!   extrapolate and return
!
 60   if(isn > 0  .or.  abs(tout-x) >= fouru*abs(x)) go to 80
  h = tout - x
  call f(x,yy,yp)
  do 70 l = 1,neqn
 70     y(l) = yy(l) + h*yp(l)
  iflag = 2
  t = tout
  told = t
  isnold = isn
  return
!
!   test for too many steps
!
 80   if(nostep < maxnum) go to 100
  iflag = isn*4
  if(stiff) iflag = isn*5
  do 90 l = 1,neqn
 90     y(l) = yy(l)
  t = x
  told = t
  isnold = 1
  return
!
!   limit step size, set weight vector and take a step
!
 100  h = sign(amin1(abs(h),abs(tend-x)),h)
  do 110 l = 1,neqn
    wt(l) = releps*abs(yy(l)) + abseps
    if(wt(l) <= 0.0) go to 140
 110    continue
  call step1(f,neqn,yy,x,h,eps,wt,start, &
    hold,k,kold,crash,phi,p,yp,psi, &
    alpha,beta,sig,v,w,g,phase1,ns,nornd)
!
!   test for tolerances too small
!
  if(.not.crash) go to 130
  iflag = isn*3
  relerr = eps*releps
  abserr = eps*abseps
  do 120 l = 1,neqn
 120    y(l) = yy(l)
  t = x
  told = t
  isnold = 1
  return
!
!   augment counter on number of steps and test for stiffness
!
 130  nostep = nostep + 1
  kle4 = kle4 + 1
  if(kold > 4) kle4 = 0
  if(kle4 >= 50) stiff = .true.
  go to 50
!
!   relative error criterion inappropriate
!
 140  iflag = isn*6
  do 150 l = 1,neqn
 150    y(l) = yy(l)
  t = x
  told = t
  isnold = 1
  return
end
function de1e(x)
!
!*******************************************************************************
!
!! DE1E evalutes the exponential integral.
!
!
!     let e1(x) denote the exponential integral for positive x and
!     the cauchy principal value for negative x. if x is nonzero
!     then de1e has the value ...
!
!          de1e(x) = e1(x)          if -4 <= x <= 1
!          de1e(x) = exp(x)*e1(x)   otherwise
!
!
!     written by Alfred Morris,
!        naval surface warfare center
!        Dahlgren, Virginia
!
!
!     the following series for e1 were developed by wayne fullerton
!     (los alamos national laboratory).
!
!     series a             on the interval -3.12500e-02 to  0.
!                                        with weighted error   4.62e-32
!                                         log weighted error  31.34
!                               significant figures required  29.70
!                                    decimal places required  32.18
!
!
!     series b             on the interval -1.25000e-01 to -3.12500e-02
!                                        with weighted error   2.22e-32
!                                         log weighted error  31.65
!                               significant figures required  30.75
!                                    decimal places required  32.54
!
!
!     series d             on the interval -2.50000e-01 to -1.25000e-01
!                                        with weighted error   5.19e-32
!                                         log weighted error  31.28
!                               significant figures required  30.82
!                                    decimal places required  32.09
!
!
!     series e             on the interval -4.00000e+00 to -1.00000e+00
!                                        with weighted error   8.49e-34
!                                         log weighted error  33.07
!                               significant figures required  34.13
!                                    decimal places required  33.80
!
!
!     series r             on the interval -1.00000e+00 to  1.00000e+00
!                                        with weighted error   8.08e-33
!                                         log weighted error  32.09
!                        approx significant figures required  30.4
!                                    decimal places required  32.79
!
!
!     series p             on the interval  2.50000e-01 to  1.00000e+00
!                                        with weighted error   6.65e-32
!                                         log weighted error  31.18
!                               significant figures required  30.69
!                                    decimal places required  32.03
!
!
!     series q             on the interval  0.          to  2.50000e-01
!                                        with weighted error   5.07e-32
!                                         log weighted error  31.30
!                               significant figures required  30.40
!                                    decimal places required  32.20
!
!
  double precision de1e
  double precision x, c, eps, t, w
  double precision a(50), b(60), d(41), e(29), r(25), p(50), q(64)
  double precision dei0, dcsevl, dpmpar
!
  data a(1)  / .3284394579616699087873844201881d-01/, &
       a(2)  /-.1669920452031362851476184343387d-01/, &
       a(3)  / .2845284724361346807424899853252d-03/, &
       a(4)  /-.7563944358516206489487866938533d-05/, &
       a(5)  / .2798971289450859157504843180879d-06/, &
       a(6)  /-.1357901828534531069525563926255d-07/, &
       a(7)  / .8343596202040469255856102904906d-09/, &
       a(8)  /-.6370971727640248438275242988532d-10/, &
       a(9)  / .6007247608811861235760831561584d-11/, &
       a(10) /-.7022876174679773590750626150088d-12/
  data a(11) / .1018302673703687693096652346883d-12/, &
       a(12) /-.1761812903430880040406309966422d-13/, &
       a(13) / .3250828614235360694244030353877d-14/, &
       a(14) /-.5071770025505818678824872259044d-15/, &
       a(15) / .1665177387043294298172486084156d-16/, &
       a(16) / .3166753890797514400677003536555d-16/, &
       a(17) /-.1588403763664141515133118343538d-16/, &
       a(18) / .4175513256138018833003034618484d-17/, &
       a(19) /-.2892347749707141906710714478852d-18/, &
       a(20) /-.2800625903396608103506340589669d-18/
  data a(21) / .1322938639539270903707580023781d-18/, &
       a(22) /-.1804447444177301627283887833557d-19/, &
       a(23) /-.7905384086522616076291644817604d-20/, &
       a(24) / .4435711366369570103946235838027d-20/, &
       a(25) /-.4264103994978120868865309206555d-21/, &
       a(26) /-.3920101766937117541553713162048d-21/, &
       a(27) / .1527378051343994266343752326971d-21/, &
       a(28) / .1024849527049372339310308783117d-22/, &
       a(29) /-.2134907874771433576262711405882d-22/, &
       a(30) / .3239139475160028267061694700366d-23/
  data a(31) / .2142183762299889954762643168296d-23/, &
       a(32) /-.8234609419601018414700348082312d-24/, &
       a(33) /-.1524652829645809479613694401140d-24/, &
       a(34) / .1378208282460639134668480364325d-24/, &
       a(35) / .2131311202833947879523224999253d-26/, &
       a(36) /-.2012649651526484121817466763127d-25/, &
       a(37) / .1995535662263358016106311782673d-26/, &
       a(38) / .2798995808984003464948686520319d-26/, &
       a(39) /-.5534511845389626637640819277823d-27/, &
       a(40) /-.3884995396159968861682544026146d-27/
  data a(41) / .1121304434507359382850680354679d-27/, &
       a(42) / .5566568152423740948256563833514d-28/, &
       a(43) /-.2045482929810499700448533938176d-28/, &
       a(44) /-.8453813992712336233411457493674d-29/, &
       a(45) / .3565758433431291562816111116287d-29/, &
       a(46) / .1383653872125634705539949098871d-29/, &
       a(47) /-.6062167864451372436584533764778d-30/, &
       a(48) /-.2447198043989313267437655119189d-30/, &
       a(49) / .1006850640933998348011548180480d-30/, &
       a(50) / .4623685555014869015664341461674d-31/
!
  data b(1)  / .20263150647078889499401236517381d+00/, &
       b(2)  /-.73655140991203130439536898728034d-01/, &
       b(3)  / .63909349118361915862753283840020d-02/, &
       b(4)  /-.60797252705247911780653153363999d-03/, &
       b(5)  /-.73706498620176629330681411493484d-04/, &
       b(6)  / .48732857449450183453464992488076d-04/, &
       b(7)  /-.23837064840448290766588489460235d-05/, &
       b(8)  /-.30518612628561521027027332246121d-05/, &
       b(9)  / .17050331572564559009688032992907d-06/, &
       b(10) / .23834204527487747258601598136403d-06/
  data b(11) / .10781772556163166562596872364020d-07/, &
       b(12) /-.17955692847399102653642691446599d-07/, &
       b(13) /-.41284072341950457727912394640436d-08/, &
       b(14) / .68622148588631968618346844526664d-09/, &
       b(15) / .53130183120506356147602009675961d-09/, &
       b(16) / .78796880261490694831305022893515d-10/, &
       b(17) /-.26261762329356522290341675271232d-10/, &
       b(18) /-.15483687636308261963125756294100d-10/, &
       b(19) /-.25818962377261390492802405122591d-11/, &
       b(20) / .59542879191591072658903529959352d-12/
  data b(21) / .46451400387681525833784919321405d-12/, &
       b(22) / .11557855023255861496288006203731d-12/, &
       b(23) /-.10475236870835799012317547189670d-14/, &
       b(24) /-.11896653502709004368104489260929d-13/, &
       b(25) /-.47749077490261778752643019349950d-14/, &
       b(26) /-.81077649615772777976249734754135d-15/, &
       b(27) / .13435569250031554199376987998178d-15/, &
       b(28) / .14134530022913106260248873881287d-15/, &
       b(29) / .49451592573953173115520663232883d-16/, &
       b(30) / .79884048480080665648858587399367d-17/
  data b(31) /-.14008632188089809829248711935393d-17/, &
       b(32) /-.14814246958417372107722804001680d-17/, &
       b(33) /-.55826173646025601904010693937113d-18/, &
       b(34) /-.11442074542191647264783072544598d-18/, &
       b(35) / .25371823879566853500524018479923d-20/, &
       b(36) / .13205328154805359813278863389097d-19/, &
       b(37) / .62930261081586809166287426789485d-20/, &
       b(38) / .17688270424882713734999261332548d-20/, &
       b(39) / .23266187985146045209674296887432d-21/, &
       b(40) /-.67803060811125233043773831844113d-22/
  data b(41) /-.59440876959676373802874150531891d-22/, &
       b(42) /-.23618214531184415968532592503466d-22/, &
       b(43) /-.60214499724601478214168478744576d-23/, &
       b(44) /-.65517906474348299071370444144639d-24/, &
       b(45) / .29388755297497724587042038699349d-24/, &
       b(46) / .22601606200642115173215728758510d-24/, &
       b(47) / .89534369245958628745091206873087d-25/, &
       b(48) / .24015923471098457555772067457706d-25/, &
       b(49) / .34118376888907172955666423043413d-26/, &
       b(50) /-.71617071694630342052355013345279d-27/
  data b(51) /-.75620390659281725157928651980799d-27/, &
       b(52) /-.33774612157467324637952920780800d-27/, &
       b(53) /-.10479325703300941711526430332245d-27/, &
       b(54) /-.21654550252170342240854880201386d-28/, &
       b(55) /-.75297125745288269994689298432000d-30/, &
       b(56) / .19103179392798935768638084000426d-29/, &
       b(57) / .11492104966530338547790728833706d-29/, &
       b(58) / .43896970582661751514410359193600d-30/, &
       b(59) / .12320883239205686471647157725866d-30/, &
       b(60) / .22220174457553175317538581162666d-31/
!
  data d(1)  / .63629589796747038767129887806803d+00/, &
       d(2)  /-.13081168675067634385812671121135d+00/, &
       d(3)  /-.84367410213053930014487662129752d-02/, &
       d(4)  / .26568491531006685413029428068906d-02/, &
       d(5)  / .32822721781658133778792170142517d-03/, &
       d(6)  /-.23783447771430248269579807851050d-04/, &
       d(7)  /-.11439804308100055514447076797047d-04/, &
       d(8)  /-.14405943433238338455239717699323d-05/, &
       d(9)  / .52415956651148829963772818061664d-08/, &
       d(10) / .38407306407844323480979203059716d-07/
  data d(11) / .85880244860267195879660515759344d-08/, &
       d(12) / .10219226625855003286339969553911d-08/, &
       d(13) / .21749132323289724542821339805992d-10/, &
       d(14) /-.22090238142623144809523503811741d-10/, &
       d(15) /-.63457533544928753294383622208801d-11/, &
       d(16) /-.10837746566857661115340539732919d-11/, &
       d(17) /-.11909822872222586730262200440277d-12/, &
       d(18) /-.28438682389265590299508766008661d-14/, &
       d(19) / .25080327026686769668587195487546d-14/, &
       d(20) / .78729641528559842431597726421265d-15/
  data d(21) / .15475066347785217148484334637329d-15/, &
       d(22) / .22575322831665075055272608197290d-16/, &
       d(23) / .22233352867266608760281380836693d-17/, &
       d(24) / .16967819563544153513464194662399d-19/, &
       d(25) /-.57608316255947682105310087304533d-19/, &
       d(26) /-.17591235774646878055625369408853d-19/, &
       d(27) /-.36286056375103174394755328682666d-20/, &
       d(28) /-.59235569797328991652558143488000d-21/, &
       d(29) /-.76030380926310191114429136895999d-22/, &
       d(30) /-.62547843521711763842641428479999d-23/
  data d(31) / .25483360759307648606037606400000d-24/, &
       d(32) / .25598615731739857020168874666666d-24/, &
       d(33) / .71376239357899318800207052800000d-25/, &
       d(34) / .14703759939567568181578956800000d-25/, &
       d(35) / .25105524765386733555198634666666d-26/, &
       d(36) / .35886666387790890886583637333333d-27/, &
       d(37) / .39886035156771301763317759999999d-28/, &
       d(38) / .21763676947356220478805333333333d-29/, &
       d(39) /-.46146998487618942367607466666666d-30/, &
       d(40) /-.20713517877481987707153066666666d-30/
  data d(41) /-.51890378563534371596970666666666d-31/
!
  data e(1)  /-.16113461655571494025720663927566180d+02/, &
       e(2)  / .77940727787426802769272245891741497d+01/, &
       e(3)  /-.19554058188631419507127283812814491d+01/, &
       e(4)  / .37337293866277945611517190865690209d+00/, &
       e(5)  /-.56925031910929019385263892220051166d-01/, &
       e(6)  / .72110777696600918537847724812635813d-02/, &
       e(7)  /-.78104901449841593997715184089064148d-03/, &
       e(8)  / .73880933562621681878974881366177858d-04/, &
       e(9)  /-.62028618758082045134358133607909712d-05/, &
       e(10) / .46816002303176735524405823868362657d-06/
  data e(11) /-.32092888533298649524072553027228719d-07/, &
       e(12) / .20151997487404533394826262213019548d-08/, &
       e(13) /-.11673686816697793105356271695015419d-09/, &
       e(14) / .62762706672039943397788748379615573d-11/, &
       e(15) /-.31481541672275441045246781802393600d-12/, &
       e(16) / .14799041744493474210894472251733333d-13/, &
       e(17) /-.65457091583979673774263401588053333d-15/, &
       e(18) / .27336872223137291142508012748799999d-16/, &
       e(19) /-.10813524349754406876721727624533333d-17/, &
       e(20) / .40628328040434303295300348586666666d-19/
  data e(21) /-.14535539358960455858914372266666666d-20/, &
       e(22) / .49632746181648636830198442666666666d-22/, &
       e(23) /-.16208612696636044604866560000000000d-23/, &
       e(24) / .50721448038607422226431999999999999d-25/, &
       e(25) /-.15235811133372207813973333333333333d-26/, &
       e(26) / .44001511256103618696533333333333333d-28/, &
       e(27) /-.12236141945416231594666666666666666d-29/, &
       e(28) / .32809216661066001066666666666666666d-31/, &
       e(29) /-.84933452268306432000000000000000000d-33/
!
  data r(1)  /-.3739021479220279511668698204827d-01/, &
       r(2)  / .4272398606220957726049179176528d-01/, &
       r(3)  /-.130318207984970054415392055219726d+00/, &
       r(4)  / .144191240246988907341095893982137d-01/, &
       r(5)  /-.134617078051068022116121527983553d-02/, &
       r(6)  / .107310292530637799976115850970073d-03/, &
       r(7)  /-.742999951611943649610283062223163d-05/, &
       r(8)  / .453773256907537139386383211511827d-06/, &
       r(9)  /-.247641721139060131846547423802912d-07/, &
       r(10) / .122076581374590953700228167846102d-08/
  data r(11) /-.548514148064092393821357398028261d-10/, &
       r(12) / .226362142130078799293688162377002d-11/, &
       r(13) /-.863589727169800979404172916282240d-13/, &
       r(14) / .306291553669332997581032894881279d-14/, &
       r(15) /-.101485718855944147557128906734933d-15/, &
       r(16) / .315482174034069877546855328426666d-17/, &
       r(17) /-.923604240769240954484015923200000d-19/, &
       r(18) / .255504267970814002440435029333333d-20/, &
       r(19) /-.669912805684566847217882453333333d-22/, &
       r(20) / .166925405435387319431987199999999d-23/
  data r(21) /-.396254925184379641856000000000000d-25/, &
       r(22) / .898135896598511332010666666666666d-27/, &
       r(23) /-.194763366993016433322666666666666d-28/, &
       r(24) / .404836019024630033066666666666666d-30/, &
       r(25) /-.807981567699845120000000000000000d-32/
!
  data p(1)  /-.60577324664060345999319382737747d+00/, &
       p(2)  /-.11253524348366090030649768852718d+00/, &
       p(3)  / .13432266247902779492487859329414d-01/, &
       p(4)  /-.19268451873811457249246838991303d-02/, &
       p(5)  / .30911833772060318335586737475368d-03/, &
       p(6)  /-.53564132129618418776393559795147d-04/, &
       p(7)  / .98278128802474923952491882717237d-05/, &
       p(8)  /-.18853689849165182826902891938910d-05/, &
       p(9)  / .37494319356894735406964042190531d-06/, &
       p(10) /-.76823455870552639273733465680556d-07/
  data p(11) / .16143270567198777552956300060868d-07/, &
       p(12) /-.34668022114907354566309060226027d-08/, &
       p(13) / .75875420919036277572889747054114d-09/, &
       p(14) /-.16886433329881412573514526636703d-09/, &
       p(15) / .38145706749552265682804250927272d-10/, &
       p(16) /-.87330266324446292706851718272334d-11/, &
       p(17) / .20236728645867960961794311064330d-11/, &
       p(18) /-.47413283039555834655210340820160d-12/, &
       p(19) / .11221172048389864324731799928920d-12/, &
       p(20) /-.26804225434840309912826809093395d-13/
  data p(21) / .64578514417716530343580369067212d-14/, &
       p(22) /-.15682760501666478830305702849194d-14/, &
       p(23) / .38367865399315404861821516441408d-15/, &
       p(24) /-.94517173027579130478871048932556d-16/, &
       p(25) / .23434812288949573293896666439133d-16/, &
       p(26) /-.58458661580214714576123194419882d-17/, &
       p(27) / .14666229867947778605873617419195d-17/, &
       p(28) /-.36993923476444472706592538274474d-18/, &
       p(29) / .93790159936721242136014291817813d-19/, &
       p(30) /-.23893673221937873136308224087381d-19/
  data p(31) / .61150624629497608051934223837866d-20/, &
       p(32) /-.15718585327554025507719853288106d-20/, &
       p(33) / .40572387285585397769519294491306d-21/, &
       p(34) /-.10514026554738034990566367122773d-21/, &
       p(35) / .27349664930638667785806003131733d-22/, &
       p(36) /-.71401604080205796099355574271999d-23/, &
       p(37) / .18705552432235079986756924211199d-23/, &
       p(38) /-.49167468166870480520478020949333d-24/, &
       p(39) / .12964988119684031730916087125333d-24/, &
       p(40) /-.34292515688362864461623940437333d-25/
  data p(41) / .90972241643887034329104820906666d-26/, &
       p(42) /-.24202112314316856489934847999999d-26/, &
       p(43) / .64563612934639510757670475093333d-27/, &
       p(44) /-.17269132735340541122315987626666d-27/, &
       p(45) / .46308611659151500715194231466666d-28/, &
       p(46) /-.12448703637214131241755170133333d-28/, &
       p(47) / .33544574090520678532907007999999d-29/, &
       p(48) /-.90598868521070774437543935999999d-30/, &
       p(49) / .24524147051474238587273216000000d-30/, &
       p(50) /-.66528178733552062817107967999999d-31/
!
  data q(1)  /-.1892918000753016825495679942820d+00/, &
       q(2)  /-.8648117855259871489968817056824d-01/, &
       q(3)  / .7224101543746594747021514839184d-02/, &
       q(4)  /-.8097559457557386197159655610181d-03/, &
       q(5)  / .1099913443266138867179251157002d-03/, &
       q(6)  /-.1717332998937767371495358814487d-04/, &
       q(7)  / .2985627514479283322825342495003d-05/, &
       q(8)  /-.5659649145771930056560167267155d-06/, &
       q(9)  / .1152680839714140019226583501663d-06/, &
       q(10) /-.2495030440269338228842128765065d-07/
  data q(11) / .5692324201833754367039370368140d-08/, &
       q(12) /-.1359957664805600338490030939176d-08/, &
       q(13) / .3384662888760884590184512925859d-09/, &
       q(14) /-.8737853904474681952350849316580d-10/, &
       q(15) / .2331588663222659718612613400470d-10/, &
       q(16) /-.6411481049213785969753165196326d-11/, &
       q(17) / .1812246980204816433384359484682d-11/, &
       q(18) /-.5253831761558460688819403840466d-12/, &
       q(19) / .1559218272591925698855028609825d-12/, &
       q(20) /-.4729168297080398718476429369466d-13/
  data q(21) / .1463761864393243502076199493808d-13/, &
       q(22) /-.4617388988712924102232173623604d-14/, &
       q(23) / .1482710348289369323789239660371d-14/, &
       q(24) /-.4841672496239229146973165734417d-15/, &
       q(25) / .1606215575700290408116571966188d-15/, &
       q(26) /-.5408917538957170947895023784252d-16/, &
       q(27) / .1847470159346897881370231402310d-16/, &
       q(28) /-.6395830792759094470500610425050d-17/, &
       q(29) / .2242780721699759457250233276170d-17/, &
       q(30) /-.7961369173983947552744555308646d-18/
  data q(31) / .2859308111540197459808619929272d-18/, &
       q(32) /-.1038450244701137145900697137446d-18/, &
       q(33) / .3812040607097975780866841008319d-19/, &
       q(34) /-.1413795417717200768717562723696d-19/, &
       q(35) / .5295367865182740958305442594815d-20/, &
       q(36) /-.2002264245026825902137211131439d-20/, &
       q(37) / .7640262751275196014736848610918d-21/, &
       q(38) /-.2941119006868787883311263523362d-21/, &
       q(39) / .1141823539078927193037691483586d-21/, &
       q(40) /-.4469308475955298425247020718489d-22/
  data q(41) / .1763262410571750770630491408520d-22/, &
       q(42) /-.7009968187925902356351518262340d-23/, &
       q(43) / .2807573556558378922287757507515d-23/, &
       q(44) /-.1132560944981086432141888891562d-23/, &
       q(45) / .4600574684375017946156764233727d-24/, &
       q(46) /-.1881448598976133459864609148108d-24/, &
       q(47) / .7744916111507730845444328478037d-25/, &
       q(48) /-.3208512760585368926702703826261d-25/, &
       q(49) / .1337445542910839760619930421384d-25/, &
       q(50) /-.5608671881802217048894771735210d-26/
  data q(51) / .2365839716528537483710069473279d-26/, &
       q(52) /-.1003656195025305334065834526856d-26/, &
       q(53) / .4281490878094161131286642556927d-27/, &
       q(54) /-.1836345261815318199691326958250d-27/, &
       q(55) / .7917798231349540000097468678144d-28/, &
       q(56) /-.3431542358742220361025015775231d-28/, &
       q(57) / .1494705493897103237475066008917d-28/, &
       q(58) /-.6542620279865705439739042420053d-29/, &
       q(59) / .2877581395199171114340487353685d-29/, &
       q(60) /-.1271557211796024711027981200042d-29/
  data q(61) / .5644615555648722522388044622506d-30/, &
       q(62) /-.2516994994284095106080616830293d-30/, &
       q(63) / .1127259818927510206370368804181d-30/, &
       q(64) /-.5069814875800460855562584719360d-31/
!
  eps = epsilon ( eps )
  if (dabs(x) >= 90.d0) go to 80
  if (x > -1.d0) go to 40
!
!                    -90 < x  <  -4
!
  if (x > -32.d0) go to 10
  m = 50
  if (eps >= 1.d-20) m = 25
  de1e = (1.d0 + dcsevl (64.d0/x+1.d0, a, m))/x
  return
!
   10 if (x > -8.d0) go to 20
  m = 60
  if (eps >= 1.d-20) m = 37
  de1e = (1.d0 + dcsevl ((64.d0/x+5.d0)/3.d0, b, m))/x
  return
!
   20 if (x >= -4.d0) go to 30
  m = 41
  if (eps >= 1.d-20) m = 27
  de1e = (1.d0 + dcsevl (16.d0/x+3.d0, d, m))/x
  return
!
!                     -4 <= x <= 1
!
   30 m = 29
  if (eps >= 1.d-20) m = 20
  de1e = -dlog(-x) + dcsevl ((2.d0*x+5.d0)/3.d0, e, m)
  return
!
   40 if (x > 1.0d0) go to 60
  if (x < -0.4d0 .or. x > -0.35d0) go to 50
     de1e = - dei0(-x, eps)
     return
   50 m = 25
  if (eps >= 1.d-20) m = 18
  de1e = (-dlog(dabs(x)) - 0.6875d0 + x)  + dcsevl (x, r, m)
  return
!
!                     1 < x  <  90
!
   60 if (x > 4.0d0) go to 70
  m = 50
  if (eps >= 1.d-20) m = 31
  de1e = (1.d0 + dcsevl ((8.d0/x-5.d0)/3.d0, p, m))/x
  return
!
   70 m = 64
  if (eps >= 1.d-20) m = 35
  de1e = (1.d0 + dcsevl (8.d0/x-1.d0, q, m))/x
  return
!
!                   asymptotic expansion
!
   80 t = -1.d0/x
  c = t
  w = c
  m = 1
   81    m = m + 1
     c = (m*t)*c
     w = c + w
     if (dabs(c) > eps) go to 81
  de1e = (1.d0 + w)/x
  return
end
subroutine dec (n, ndim, a, ip, ier)
!
!*******************************************************************************
!
!! DEC: matrix triangularization by gaussian elimination.
!
! input..
!    n = order of matrix.
!    ndim = declared dimension of array  a .
!    a = matrix to be triangularized.
! output..
!    a(i,j), i <= j = upper triangular factor, u .
!    a(i,j), i > j = multipliers = lower triangular factor, i - l.
!    ip(k), k < n = index of k-th pivot row.
!    ip(n) = (-1)**(number of interchanges) or o .
!    ier = 0 if a nonsingular, or k if a found to be
!          singular at stage k.
! use  sol  to obtain solution of linear system.
! determ(a) = ip(n)*a(1,1)*a(2,2)*...*a(n,n).
! if ip(n)=0, a is singular, sol will divide by zero.
! interchanges finished in u , only partly in l .
!
! reference..
! c. b. moler, algorithm 423, linear equation solver,
! comm. assoc. comput. mach., 15 (1972), p. 274.
!
  integer ier, ip, n, ndim
  integer i, j, k, kp1, m, nm1
  real a
  real t
  real one, zero
  dimension a(ndim,n),ip(n)
  data one /1.0e0/, zero /0.0e0/
!
  ier = 0
  ip(n) = 1
  if (n == 1) go to 70
  nm1 = n - 1
  do 60 k = 1,nm1
    kp1 = k + 1
!  find the pivot in column k.  search rows k to n.
    m = k
    do 10 i = kp1,n
  10      if (abs(a(i,k)) > abs(a(m,k))) m = i
    ip(k) = m
!  interchange elements in rows k and m.
    t = a(m,k)
    if (m == k) go to 20
    ip(n) = -ip(n)
    a(m,k) = a(k,k)
    a(k,k) = t
 20     if (t == zero) go to 80
!  store multipliers in a(i,k), i = k+1,...,n.--
    t = one/t
    do 30 i = kp1,n
 30       a(i,k) = -a(i,k)*t
!  apply multipliers to other columns of a.---
    do 50 j = kp1,n
      t = a(m,j)
      a(m,j) = a(k,j)
      a(k,j) = t
      if (t == zero) go to 50
      do 40 i = kp1,n
 40         a(i,j) = a(i,j) + a(i,k)*t
 50       continue
 60     continue
 70   k = n
  if (a(n,n) == zero) go to 80
  return
 80   ier = k
  ip(n) = 0
  return
!  end of subroutine dec---
end
subroutine decbt (m, n, a, b, c, ip, ier)
!
!*******************************************************************************
!
!! DECBT: block-tridiagonal matrix decomposition routine.
!
!
! written by a. c. hindmarsh.
! latest revision january 26, 1977  (ag)
! reference.. ucid-30150
!             solution of block-tridiagonal systems of linear
!             algebraic equations
!             a.c. hindmarsh
!             february 1977
! the input matrix contains three blocks of elements in each block-row,
! including blocks in the (1,3) and (n,n-2) block positions.
! decbt uses block gauss elimination and subroutines dec and sol
! for solution of blocks.  partial pivoting is done within
! block-rows only.
! input..
!     m = order of each block.
!     n = number of blocks in each direction of the matrix.
!         n must be 4 or more.  the complete matrix has order m*n.
!     a = m by m by n array containing diagonal blocks.
!         a(i,j,k) contains the (i,j) element of the k-th block.
!     b = m by m by n array containing the super-diagonal blocks
!         (in b(*,*,k) for k = 1,...,n-1) and the block in the (n,n-2)
!         block position (in b(*,*,n)).
!     c = m by m by n array containing the subdiagonal blocks
!         (in c(*,*,k) for k = 2,3,...,n) and the block in the
!         (1,3) block position (in c(*,*,1)).
!    ip = integer array of length m*n for working storage.
! output..
! a,b,c = m by m by n arrays containing the block lu decomposition
!         of the input matrix.
!    ip = m by n array of pivot information.  ip(*,k) contains
!         information for the k-th digonal block.
!   ier = 0  if no trouble occurred, or
!       = -1 if the input value of m or n was illegal, or
!       = k  if a singular matrix was found in the k-th diagonal block.
! use solbt to solve the associated linear system.
! decbt calls subroutines  dec(m,m0,a,ip,ier)  and  sol(m,m0,a,y,ip)
! for solution of m by m linear systems.
!
  integer m, n, ip(m,n), ier
  real a(m,m,n), b(m,m,n), c(m,m,n)
!
  integer nm1, nm2, km1,i,j,k,l
  real dp
  if (m < 1 .or. n  <  4) go to 210
  nm1 = n - 1
  nm2 = n - 2
! process the first block-row.--
  call dec (m, m, a, ip, ier)
  k = 1
  if (ier /= 0) go to 200
  do 10 j = 1,m
    call sol (m, m, a, b(1,j,1), ip)
    call sol (m, m, a, c(1,j,1), ip)
 10     continue
! adjust b(*,*,2).----
  do 40 j = 1,m
    do 30 i = 1,m
      dp = 0.
      do 20 l = 1,m
 20         dp = dp + c(i,l,2)*c(l,j,1)
      b(i,j,2) = b(i,j,2) - dp
 30       continue
 40     continue
! main loop.  process block-rows 2 to n-1.----
  do 100 k = 2,nm1
    km1 = k - 1
    do 70 j = 1,m
      do 60 i = 1,m
        dp = 0.
        do 50 l = 1,m
 50           dp = dp + c(i,l,k)*b(l,j,km1)
        a(i,j,k) = a(i,j,k) - dp
 60         continue
 70       continue
    call dec (m, m, a(1,1,k), ip(1,k), ier)
    if (ier /= 0) go to 200
    do 80 j = 1,m
 80       call sol (m, m, a(1,1,k), b(1,j,k), ip(1,k))
 100    continue
! process last block-row and return.--
  do 130 j = 1,m
    do 120 i = 1,m
      dp = 0.
      do 110 l = 1,m
 110        dp = dp + b(i,l,n)*b(l,j,nm2)
      c(i,j,n) = c(i,j,n) - dp
 120      continue
 130    continue
  do 160 j = 1,m
    do 150 i = 1,m
      dp = 0.
      do 140 l = 1,m
 140        dp = dp + c(i,l,n)*b(l,j,nm1)
      a(i,j,n) = a(i,j,n) - dp
 150      continue
 160    continue
  call dec (m, m, a(1,1,n), ip(1,n), ier)
  k = n
  if (ier /= 0) go to 200
  return
! error returns.
 200  ier = k
  return
 210  ier = -1
  return
end
subroutine decom2(m, n, m1, eta, tol, qr, d, n1, ipivot, sing, mmpnn)
!
!*******************************************************************************
!
!! DECOM2: ???
!
  integer ipivot(n)
  real c, d(*), dm, ds, eta, qr(mmpnn,n), rsj, tol, tol2
  double precision sum
  logical finis, fsum, sing
  n1 = 0
  sing = .true.
  fsum = .true.
  mv = 1
  mh = m1
  ms = m
  mp1 = m + 1
  finis = .false.
  if (tol > 0.0) tol2 = tol
  do 10 j=1,n
    d(j) = 0.0
    ipivot(j) = j
   10 continue
! step number ns of the decomposition.
  do 350 ns=1,n
    k = m + ns
    if (ns==m1+1) go to 20
    go to 30
   20   if (m1==m) go to 200
    mv = m1 + 1
    mh = m
    fsum = .true.
   30   if (.not.finis) go to 40
    go to 150
! pivot search.
   40   ds = 0.0
    np = ns
    do 90 j=ns,n
      if (fsum) go to 50
      go to 70
   50     sum = 0.0
      do 60 l=mv,mh
        sum = sum + dble(qr(l,j))*dble(qr(l,j))
   60     continue
      d(j) = sum
   70     if (ds < d(j)) go to 80
      go to 90
   80     ds = d(j)
      np = j
   90   continue
    if (fsum) dm = ds
    if (ds < eta*dm) go to 100
    fsum = .false.
    go to 110
  100   fsum = .true.
  110   if (fsum) go to 40
    if (np/=ns) go to 120
    go to 140
! column interchange.
  120   ik = ipivot(np)
    ipivot(np) = ipivot(ns)
    ipivot(ns) = ik
    d(np) = d(ns)
    km1 = k - 1
    do 130 l=1,km1
      c = qr(l,np)
      qr(l,np) = qr(l,ns)
      qr(l,ns) = c
  130   continue
! end column interchange.
! end pivot search.
! return here if n1 = 0.  either input matrix qr equals zero or
! matrix of constraints equals zero.
  140   if (ns==1 .and. ds==0.0) return
    go to 160
  150   ms = k - 1
    mh = k - 1
  160   if (finis) go to 170
    c = 0.0
    go to 180
  170   c = 1.0
  180   sum = dble(c)
    do 190 l=mv,mh
      sum = sum + dble(qr(l,ns))*dble(qr(l,ns))
  190   continue
    d(ns) = sum
    ds = d(ns)
    if (tol==0.0) tol2 = (real(n)*eta)**2*d(m1+1)
    if (.not.finis .and. ns > m1 .and. ds <= tol2) go to 200
    go to 290
  200   finis = .true.
    mv = m + 1
    do 280 np=ns,n
      if (1 > m1) go to 250
      do 210 l=1,m1
        qr(l,np) = 0.0
  210     continue
      do 240 j=1,m1
        sum = 0.0
        do 220 l=1,m
          sum = sum + dble(qr(l,j))*dble(qr(l,np))
  220       continue
        c = sum
        c = c/d(j)
        do 230 l=1,m1
          qr(l,np) = qr(l,np) - c*qr(l,j)
  230       continue
  240     continue
  250     mpn1 = m + n1
      do 270 jj=mp1,mpn1
        j = (m + 1) + (m + n1) - jj
        sum = 0.0
        do 260 l=j,mpn1
          lmm = l - m
          sum = sum + dble(qr(j,lmm))*dble(qr(l,np))
  260       continue
        qr(j,np) = -sum
  270     continue
  280   continue
    go to 150
! return here if matrix of constraints is found to be singular.
  290   if (ds==0.0) return
    qr(k,ns) = -1.0
    nsp1 = ns + 1
    if (nsp1 > n) go to 340
! begin orthogonalization.
    do 330 j=nsp1,n
      sum = 0.0
      do 300 l=mv,mh
        sum = sum + dble(qr(l,j))*dble(qr(l,ns))
  300     continue
      rsj = sum
      rsj = rsj/ds
      qr(k,j) = rsj
      do 310 l=1,ms
        qr(l,j) = qr(l,j) - rsj*qr(l,ns)
  310     continue
      if (.not.finis) go to 320
      go to 330
  320     d(j) = d(j) - ds*rsj*rsj
  330   continue
! end orthogonalization.
  340   if (.not.finis) n1 = n1 + 1
  350 continue
! end step number ns.
  sing = .false.
! normal return.
  return
end
subroutine defer (cofx,cofy,usol,idmn,grhs,mn)
!
!*******************************************************************************
!
!! DEFER: ???
!
!     this subroutine first approximates the truncation error given
!     by  trun1(x,y)=dlx**2*tx+dly**2*ty where
!     tx=afun(x)*uxxxx/12.0+bfun(x)*uxxx/6.0 on the interior and
!     at the boundaries if periodic (here uxxx,uxxxx are the third
!     and fourth partial derivatives of u with respect to x).
!
!     tx is of the form afun(x)/3.0*(uxxxx/4.0+uxxx/dlx)
!     at x=a or x=b if the boundary condition there is mixed.
!     tx=0.0 along specified boundaries.  ty has symmetric form
!     in y with x,afun(x),bfun(x) replaced by y,dfun(y),efun(y).
!
!     the second order solution in usol is used to approximate
!     (via second order finite differencing) the truncation error
!     and the result is added to the right hand side in grhs
!     and then transferred to usol to be used as a new right
!     hand side when calling blktri for a fourth order solution.
!
  dimension       grhs(mn,*)             ,usol(idmn,*)
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
!
!     compute truncation error approximation over the entire mesh
!
  do  40 j=js,ns
     yj = cit+real(j-1)*dly
     call cofy (yj,dj,ej,fj)
     do  30 i=is,ms
        xi = ait+real(i-1)*dlx
        call cofx (xi,ai,bi,ci)
!
!     compute partial derivative approximations at (xi,yj)
!
        call dxfn (usol,idmn,i,j,uxxx,uxxxx)
        call dyfn (usol,idmn,i,j,uyyy,uyyyy)
        tx = ai*uxxxx/12.0+bi*uxxx/6.0
        ty = dj*uyyyy/12.0+ej*uyyy/6.0
!
!     reset form of truncation if at boundary which is non-periodic
!
        if (kswx==1 .or. (i > 1 .and. i < k)) go to  10
        tx = ai/3.0*(uxxxx/4.0+uxxx/dlx)
   10       if (kswy==1 .or. (j > 1 .and. j < l)) go to  20
        ty = dj/3.0*(uyyyy/4.0+uyyy/dly)
   20       grhs(i,j) = grhs(i,j)+dlx**2*tx+dly**2*ty
   30    continue
   40 continue
!
!     reset the right hand side in usol
!
  do  60 i=is,ms
     do  50 j=js,ns
        usol(i,j) = grhs(i,j)
   50    continue
   60 continue
  return
end
function dei (x)
!
!*******************************************************************************
!
!! DEI evaluates the exponential integral
!
  double precision dei
  double precision x
  double precision de1e
!
  dei = -de1e(-x)
  if ( x > 4.0d0 .or. x < -1.0d0) dei = dexp(x) * dei
  return
end
function dei0 (x, eps)
!
!*******************************************************************************
!
!! DEI0 evaluates ei(x) near a zero.
!
!
!            taylor series expansion of ei(x) around x0,
!                  where x0 is the zero of ei(x).
!                    eps is the tolerance used.
!
!
!  Author:
!
!    a.h. morris
!    naval surface warfare center
!    Dahlgren, Virginia
!
  double precision dei0
  double precision a(40), c, eps, h, t, x, w
  double precision dk1, dk2, dk3, db, db2, dx
!
  data dk1 /25598514349.d0/, dk2 /12212826724.d0/, &
       dk3 /52346020729.d0/
  data db  /68719476736.d0/
  data dx  /.64725688445954142292644880487403537155379408215561d-33/
!
  data a(1)  / .3896215733907167310156502703593482682018d+01/, &
       a(2)  /-.3281607866398561670879044070702055058438d+01/, &
       a(3)  / .6522376145438925697728352767902339522245d+01/, &
       a(4)  /-.1296969738353651703636356975116693457132d+02/, &
       a(5)  / .2788629796294204997855360701398702087604d+02/, &
       a(6)  /-.6237880152891541873078526672920295283143d+02/, &
       a(7)  / .1435349488096750987841265647073135861344d+03/, &
       a(8)  /-.3371558271787468916821364466977375583658d+03/, &
       a(9)  / .8045318399821382506595322457265602778098d+03/, &
       a(10) /-.1943796645723498840655451915157946462648d+04/
  data a(11) / .4743765650402430835228269085129777320454d+04/, &
       a(12) /-.1167346399116716364394668734600584330571d+05/, &
       a(13) / .2892695530543545087445160311373446386859d+05/, &
       a(14) /-.7210794586837158996878001987822898188198d+05/, &
       a(15) / .1806695585893919626172098163733836311447d+06/, &
       a(16) /-.4546962188544665746524572520110515778526d+06/, &
       a(17) / .1148834546817744310374556891236080193473d+07/, &
       a(18) /-.2912721663850837498392234670693435881386d+07/, &
       a(19) / .7407692958000587759747953639495510375408d+07/, &
       a(20) /-.1889172700038153127288849726417780854730d+08/
  data a(21) / .4830003493086024720868271496253148288055d+08/, &
       a(22) /-.1237682190024917092137405370407916520821d+09/, &
       a(23) / .3178111056663621852260468265468336116367d+09/, &
       a(24) /-.8176185693184928170769596413793786736279d+09/, &
       a(25) / .2107109291864363741291032089276432438927d+10/, &
       a(26) /-.5438996831077284596300440196418865401363d+10/, &
       a(27) / .1406026390995585037838894210474681627693d+11/, &
       a(28) /-.3639689100149205333626392754168250384373d+11/, &
       a(29) / .9433859509219164512733865811047107199412d+11/, &
       a(30) /-.2448111705066430130314746602027041462835d+12/
  data a(31) / .6359981818273706257655285041587660739835d+12/, &
       a(32) /-.1653989211524391716301960841541179924503d+13/, &
       a(33) / .4305601123377464671923711939926758523701d+13/, &
       a(34) /-.1121847693567642152208443795868288937687d+14/, &
       a(35) / .2925565695557339262045727352754930716608d+14/, &
       a(36) /-.7635552741959392076619218035480359307499d+14/, &
       a(37) / .1994372792759425025753893705017248674884d+15/, &
       a(38) /-.5213021921201092276891722450906568692592d+15/, &
       a(39) / .1363558024737805584657706536660107687818d+16/, &
       a(40) /-.3568973490569445692988895507297245137908d+16/
!
!
!     set  h = x - x0  where x0 is the zero of ei(x). x0 has the
!     approximate 60 digit value ...
!
!      .37250741078136663446 19918665801191335356 89497771654051555657
!
!     a more accurate value is given by ...
!
!            x0 = dk1/8**12 + dk2/8**24 + dk3/8**36 + dx
!
!     the following code should yield the correct value for h if a
!     binary, octal, or hexadecimal double precision arithmetic is
!     being used.
!
  db2 = db*db
  h = (((x - dk1/db) - dk2/db2) - dk3/(db*db2)) - dx
!
!
  t = h
  w = 0.d0
  do 10 n = 2,40
     c = a(n)*t
     w = w + c
     if (dabs(c) < eps) go to 20
     t = h*t
   10 continue
!
   20 dei0 = h * (a(1) + w)
  return
end
function dei1 (x)
!
!*******************************************************************************
!
!! DEI1: double precision evaluation of exp(-x)*ei(x)
!
  double precision dei1
  double precision x
  double precision de1e
!
  dei1  = -de1e(-x)
  if (x > 4.d0 .or. x < -1.d0) return
  dei1 = dexp(-x) * dei1
  return
end
subroutine deig (ibal,a,ka,n,wr,wi,ierr)
!
!*******************************************************************************
!
!! DEIG: eigenvalues of double precision matrices
!
  double precision a(ka,n), wr(n), wi(n)
!
  low = 1
  igh = n
  if (ibal /= 0) call dbal (ka,n,a,low,igh,wr)
  call dorth (ka,n,low,igh,a,wr)
  call dhqr (ka,n,low,igh,a,wr,wi,ierr)
  return
end
subroutine deigv (ibal,a,ka,n,wr,wi,zr,zi,ierr)
!
!*******************************************************************************
!
!! DEIGV: eigenvalues and eigenvectors of double precision matrices
!
  double precision a(ka,n),wr(n),wi(n),zr(ka,n),zi(ka,n)
!
  low = 1
  igh = n
  if (ibal /= 0) call dbal (ka,n,a,low,igh,zi)
  call dorth (ka,n,low,igh,a,wr)
  call dortrn (ka,n,low,igh,a,wr,zr)
  call dhqr2 (ka,n,low,igh,a,wr,wi,zr,ierr)
  if (ierr /= 0) return
  if (ibal /= 0) call dbabk (ka,n,low,igh,zi,n,zr)
!
  do 30 k = 1,n
     if (wi(k)) 30,10,20
   10    do 11 j = 1,n
   11       zi(j,k) = 0.d0
     go to 30
   20    kp1 = k + 1
     do 21 j = 1,n
        zi(j,k) = zr(j,kp1)
        zr(j,kp1) = zr(j,k)
   21       zi(j,kp1) = -zi(j,k)
   30 continue
  return
end
subroutine dellpi ( phi, cphi, k, l, f, e, ierr )
!
!*******************************************************************************
!
!! DELLPI: elliptic integrals of the first and second kinds.
!
!
!     phi = argument                    (0.0 <= phi  <= pi/2)
!     cphi = pi/2 - phi                 (0.0 <= cphi <= pi/2)
!     k = modulus                       (dabs(k) <= 1.0)
!     l = comodulus = sqrt (1 - k*k)    (dabs(l) <= 1.0)
!     f = elliptic integral of first kind = f(phi, k)
!     e = elliptic integral of second kind = e(phi, k)
!     ierr = error indicator (ierr = 0  if no errors)
!
  double precision phi, cphi, k, l, f, e
  double precision an, cn, dn, d1, d2, d3, d4, hn, k2, l2, ln4, &
                   p, pn, px, qn, qx, r, ri, rj, rk, rm, rn, r0, &
                   r2, si, sj, sk, sn, ss, s0, s1, s2, s3, s4, &
                   td, th1, tr, ts, t1, t2, w
  double precision dlnrel, dcpabs
!
!     ln4 = ln(4)
!     th1 = tanh(1)
!
  data ln4 /.1386294361119890618834464242916353136151d+01/
  data th1 /.7615941559557648881194582826047935904128d+00/
!
  if (phi < 0.d0 .or. cphi  <  0.d0) go to 100
  if (dabs(k) > 1.d0 .or. dabs(l)  >  1.d0) go to 110
  ierr = 0
  if (phi /= 0.d0) go to 10
     f = 0.d0
     e = 0.d0
     return
!
   10 if (phi < 0.79d0) go to 11
     sn = dcos(cphi)
     cn = dsin(cphi)
     go to 20
   11 sn = dsin(phi)
  cn = dcos(phi)
!
   20 k2 = k*k
  l2 = l*l
  ss = sn*sn
  px = dabs(k*sn)
  qx = dabs(k*cn)
  if (px >= th1) go to 50
!
!     series expansion for abs(k*sin(phi)) <= tanh(1)
!
  pn = 1.d0
  qn = 2.d0
  an = phi
  hn = 1.d0
  s1 = 0.d0
  s2 = 0.d0
  tr = phi*ss
  ts = sn*cn
!
   30 an = (pn*an - ts)/qn
  r  = k2*hn/qn
  s2 = s2 + r*an
  hn = pn*r
  s0 = s1
  s1 = s1 + hn*an
  if (dabs(tr) < dabs(an)) go to 40
  if (dabs(s1) <= dabs(s0)) go to 40
  pn = qn + 1.d0
  qn = pn + 1.d0
  tr = ss*tr
  ts = ss*ts
  go to 30
!
   40 f = phi + s1
  e = phi - s2
  return
!
!     series expansion for abs(k*sin(phi)) > tanh(1)
!
   50 r = dcpabs(l,qx)
  if (r == 0.d0) go to 120
  r2 = r*r
  si = 1.d0
  sj = 1.d0
  sk = 0.d0
  rm = 0.d0
  rn = 0.d0
  s1 = 0.d0
  s2 = 0.d0
  s3 = 0.d0
  s4 = 0.d0
  td = qx*r
  dn = 2.d0
  go to 70
!
   60 si = ri
  sj = rj
  sk = rk
  dn = dn + 2.d0
  td = r2*td
   70 pn = (dn - 1.d0)/dn
  qn = (dn + 1.d0)/(dn + 2.d0)
  ri = pn*si
  rj = pn*pn*l2*sj
  rk = sk + 2.d0/(dn*(dn - 1.d0))
  r0 = td/dn
  rm = qn*qn*l2*(rm - r0*ri)
  rn = pn*qn*l2*(rn - r0*si)
  d1 = rj
  d2 = qn*rj
  d3 = rm - rj*rk
  d4 = rn - pn*l2*sj*rk + l2*sj/(dn*dn)
  r0 = s3
  s1 = s1 + d1
  s2 = s2 + d2
  s3 = s3 + d3
  s4 = s4 + d4
  if (s3 < r0) go to 60
!
  w = 1.d0 + px
  p = ln4 - dlog(r + qx)
  t1 = (1.d0 + s1)*p + qx/r*dlnrel(-0.5d0*r2/w)
  t2 = (0.5d0 + s2)*l2*p + (1.d0 - qx*r/w)
  f = t1 + s3
  e = t2 + s4
  return
!
!     error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
  120 ierr = 3
  return
end
subroutine depi (phi, cphi, k2, l2, n, m, p, ierr)
!
!*******************************************************************************
!
!! DEPI: elliptic integral of the third kind
!
  double precision phi, cphi, k2, l2, n, m, p
  double precision a, b, c, eps, pihalf, r, rf, s, s2, tol
  double precision dpmpar
!
  data pihalf /1.570796326794896619231321691639751442099d0/
!
  eps = epsilon ( eps )
  tol = 4.d0 * eps
  if (dmin1(phi,cphi) < 0.d0) go to 100
  if (dabs((phi + cphi) - pihalf) > tol * pihalf) go to 100
  if (dabs(n) > 1.d0) go to 110
  if (k2 < 0.d0 .or. l2  <  0.d0) go to 120
  if (dabs((k2 + l2) - 1.d0) > tol) go to 120
!
  if (phi < 0.79d0) go to 10
      s = dcos(cphi)
      c = dsin(cphi)
      go to 11
   10 s = dsin(phi)
  c = dcos(phi)
   11 a = c*c
  b = l2 + k2*a
  s2 = s*s
!
  if (n > 0.d0) go to 20
      r = 1.d0 - n*s2
      go to 30
   20 if (m < 0.d0 .or. m > 1.d0) go to 110
  if (dabs((m + n) - 1.d0) > tol) go to 110
  r = m + n*a
!
   30 call drjval (a, b, 1.d0, r, p, ierr)
  if (ierr /= 0) go to 130
  p = p * (s * s2) * n/3.d0
  call drfval (a, b, 1.d0, rf, ierr)
  p = p + s * rf
  return
!
!     error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
  120 ierr = 3
  return
  130 ierr = 4
  return
end
function derf (x)
!
!*******************************************************************************
!
!! DERF: the error function
!
  double precision derf
  double precision ax, eps, t, x, w
  double precision a(21), b(28), e(44)
  double precision dpmpar, dcsevl
!
  data a(1)  / .1283791670955125738961589031215d+00/, &
       a(2)  /-.3761263890318375246320529677070d+00/, &
       a(3)  / .1128379167095512573896158902931d+00/, &
       a(4)  /-.2686617064513125175943235372542d-01/, &
       a(5)  / .5223977625442187842111812447877d-02/, &
       a(6)  /-.8548327023450852832540164081187d-03/, &
       a(7)  / .1205533298178966425020717182498d-03/, &
       a(8)  /-.1492565035840625090430728526820d-04/, &
       a(9)  / .1646211436588924261080723578109d-05/, &
       a(10) /-.1636584469123468757408968429674d-06/
  data a(11) / .1480719281587021715400818627811d-07/, &
       a(12) /-.1229055530145120140800510155331d-08/, &
       a(13) / .9422759058437197017313055084212d-10/, &
       a(14) /-.6711366740969385085896257227159d-11/, &
       a(15) / .4463222608295664017461758843550d-12/, &
       a(16) /-.2783497395542995487275065856998d-13/, &
       a(17) / .1634095572365337143933023780777d-14/, &
       a(18) /-.9052845786901123985710019387938d-16/, &
       a(19) / .4708274559689744439341671426731d-17/, &
       a(20) /-.2187159356685015949749948252160d-18/, &
       a(21) / .7043407712019701609635599701333d-20/
!
  data b(1)  / .483110564084803581889448079057d+00/, &
       b(2)  /-.301071073386594942470731046311d+00/, &
       b(3)  / .689948306898315662466031807180d-01/, &
       b(4)  /-.139162712647221876825465256870d-01/, &
       b(5)  / .242079952243346366289167823900d-02/, &
       b(6)  /-.365863968584808644649382577000d-03/, &
       b(7)  / .486209844323190482828875680000d-04/, &
       b(8)  /-.574925655803568483505421500000d-05/, &
       b(9)  / .611324357843476469706758000000d-06/, &
       b(10) /-.589910153129584343908460000000d-07/
  data b(11) / .520700909206864824045500000000d-08/, &
       b(12) /-.423297587996554326810000000000d-09/, &
       b(13) / .318811350664917497480000000000d-10/, &
       b(14) /-.223615501883268427300000000000d-11/, &
       b(15) / .146732984799108492000000000000d-12/, &
       b(16) /-.904400198538174700000000000000d-14/, &
       b(17) / .525481371547092000000000000000d-15/, &
       b(18) /-.288742612228490000000000000000d-16/, &
       b(19) / .150478518755800000000000000000d-17/, &
       b(20) /-.745728928210000000000000000000d-19/
  data b(21) / .352256381000000000000000000000d-20/, &
       b(22) /-.158944644000000000000000000000d-21/, &
       b(23) / .686436500000000000000000000000d-23/, &
       b(24) /-.284257000000000000000000000000d-24/, &
       b(25) / .113060000000000000000000000000d-25/, &
       b(26) /-.433000000000000000000000000000d-27/, &
       b(27) / .160000000000000000000000000000d-28/, &
       b(28) /-.100000000000000000000000000000d-29/
!
  data e(1)  / .107797785207238315116833591035d+01/, &
       e(2)  /-.265598904091486733721465009040d-01/, &
       e(3)  /-.148707314669809950960504633300d-02/, &
       e(4)  /-.138040145414143859607708920000d-03/, &
       e(5)  /-.112803033322874914985073660000d-04/, &
       e(6)  /-.117286984274372522405373900000d-05/, &
       e(7)  /-.103476150393304615537382000000d-06/, &
       e(8)  /-.118991140858924382544470000000d-07/, &
       e(9)  /-.101622254498949864047600000000d-08/, &
       e(10) /-.137895716146965692169000000000d-09/
  data e(11) /-.936961303373730333500000000000d-11/, &
       e(12) /-.191880958395952534900000000000d-11/, &
       e(13) /-.375730172019937070000000000000d-13/, &
       e(14) /-.370537260269833570000000000000d-13/, &
       e(15) / .262756542349037100000000000000d-14/, &
       e(16) /-.112132287643793300000000000000d-14/, &
       e(17) / .184136028922538000000000000000d-15/, &
       e(18) /-.491302565748860000000000000000d-16/, &
       e(19) / .107044551673730000000000000000d-16/, &
       e(20) /-.267189366240500000000000000000d-17/
  data e(21) / .649326867976000000000000000000d-18/, &
       e(22) /-.165399353183000000000000000000d-18/, &
       e(23) / .426056266040000000000000000000d-19/, &
       e(24) /-.112558407650000000000000000000d-19/, &
       e(25) / .302561744800000000000000000000d-20/, &
       e(26) /-.829042146000000000000000000000d-21/, &
       e(27) / .231049558000000000000000000000d-21/, &
       e(28) /-.654695110000000000000000000000d-22/, &
       e(29) / .188423140000000000000000000000d-22/, &
       e(30) /-.550434100000000000000000000000d-23/
  data e(31) / .163095000000000000000000000000d-23/, &
       e(32) /-.489860000000000000000000000000d-24/, &
       e(33) / .149054000000000000000000000000d-24/, &
       e(34) /-.459220000000000000000000000000d-25/, &
       e(35) / .143180000000000000000000000000d-25/, &
       e(36) /-.451600000000000000000000000000d-26/, &
       e(37) / .144000000000000000000000000000d-26/, &
       e(38) /-.464000000000000000000000000000d-27/, &
       e(39) / .151000000000000000000000000000d-27/, &
       e(40) /-.500000000000000000000000000000d-28/
  data e(41) / .170000000000000000000000000000d-28/, &
       e(42) /-.600000000000000000000000000000d-29/, &
       e(43) / .200000000000000000000000000000d-29/, &
       e(44) /-.100000000000000000000000000000d-29/
!
  eps = epsilon ( eps )
!
!                     dabs(x) <= 1
!
  ax = dabs(x)
  if (ax > 1.d0) go to 20
  t = x*x
  w = a(21)
  do 10 i = 1,20
     k = 21 - i
     w = t*w + a(k)
   10 continue
  derf = x*(1.d0 + w)
  return
!
!                  1 < dabs(x)  <  2
!
   20 if (ax >= 2.d0) go to 30
  n = 28
  if (eps >= 1.d-20) n = 21
  t = 0.5d0*x*x - 1.d0
  w = dcsevl(t, b, n)
  derf = x*(0.5d0 + w)
  return
!
!                     dabs(x) >= 2
!
   30 if (ax >= 8.5d0) go to 40
  n = 44
  if (eps < 1.d-20) go to 31
     if (ax >= 6.8d0) go to 40
     n = 25
   31 t = (1.d0/x)**2
  w = (10.5d0*t - 1.d0)/(2.5d0*t + 1.d0)
  w = dcsevl(w, e, n) / ax
  derf = 0.5d0 + (0.5d0 - dexp(-x*x) * w)
  if (x < 0.d0) derf = -derf
  return
!
!                 limit value for large x
!
   40 derf = 1.d0
  if (x < 0.d0) derf = -1.d0
  return
end
function derfc (x)
!
!*******************************************************************************
!
!! DERFC: the complementary error function
!
  double precision derfc
  double precision an, ax, c, eps, rpinv, t, x, w
  double precision a(21), b(44), e(44)
  double precision dpmpar, dcsevl
!
!     rpinv = 1/sqrt(pi)
!
  data rpinv /.56418958354775628694807945156077259d0/
!
  data a(1)  / .1283791670955125738961589031215d+00/, &
       a(2)  /-.3761263890318375246320529677070d+00/, &
       a(3)  / .1128379167095512573896158902931d+00/, &
       a(4)  /-.2686617064513125175943235372542d-01/, &
       a(5)  / .5223977625442187842111812447877d-02/, &
       a(6)  /-.8548327023450852832540164081187d-03/, &
       a(7)  / .1205533298178966425020717182498d-03/, &
       a(8)  /-.1492565035840625090430728526820d-04/, &
       a(9)  / .1646211436588924261080723578109d-05/, &
       a(10) /-.1636584469123468757408968429674d-06/
  data a(11) / .1480719281587021715400818627811d-07/, &
       a(12) /-.1229055530145120140800510155331d-08/, &
       a(13) / .9422759058437197017313055084212d-10/, &
       a(14) /-.6711366740969385085896257227159d-11/, &
       a(15) / .4463222608295664017461758843550d-12/, &
       a(16) /-.2783497395542995487275065856998d-13/, &
       a(17) / .1634095572365337143933023780777d-14/, &
       a(18) /-.9052845786901123985710019387938d-16/, &
       a(19) / .4708274559689744439341671426731d-17/, &
       a(20) /-.2187159356685015949749948252160d-18/, &
       a(21) / .7043407712019701609635599701333d-20/
!
  data b(1)  / .610143081923200417926465815756d+00/, &
       b(2)  /-.434841272712577471828182820888d+00/, &
       b(3)  / .176351193643605501125840298123d+00/, &
       b(4)  /-.607107956092494148600512158250d-01/, &
       b(5)  / .177120689956941144861471411910d-01/, &
       b(6)  /-.432111938556729381859986496800d-02/, &
       b(7)  / .854216676887098678819832055000d-03/, &
       b(8)  /-.127155090609162742628893940000d-03/, &
       b(9)  / .112481672436711894688470720000d-04/, &
       b(10) / .313063885421820972630152000000d-06/
  data b(11) /-.270988068537762022009086000000d-06/, &
       b(12) / .307376227014076884409590000000d-07/, &
       b(13) / .251562038481762293731400000000d-08/, &
       b(14) /-.102892992132031912759000000000d-08/, &
       b(15) / .299440521199499393630000000000d-10/, &
       b(16) / .260517896872669362900000000000d-10/, &
       b(17) /-.263483992417196938600000000000d-11/, &
       b(18) /-.643404509890636443000000000000d-12/, &
       b(19) / .112457401801663447000000000000d-12/, &
       b(20) / .172815333899860980000000000000d-13/
  data b(21) /-.426410169494237500000000000000d-14/, &
       b(22) /-.545371977880191000000000000000d-15/, &
       b(23) / .158697607761671000000000000000d-15/, &
       b(24) / .208998378443340000000000000000d-16/, &
       b(25) /-.590052686940900000000000000000d-17/, &
       b(26) /-.941893387554000000000000000000d-18/, &
       b(27) / .214977356470000000000000000000d-18/, &
       b(28) / .466609850080000000000000000000d-19/, &
       b(29) /-.724301186200000000000000000000d-20/, &
       b(30) /-.238796682400000000000000000000d-20/
  data b(31) / .191177535000000000000000000000d-21/, &
       b(32) / .120482568000000000000000000000d-21/, &
       b(33) /-.672377000000000000000000000000d-24/, &
       b(34) /-.574799700000000000000000000000d-23/, &
       b(35) /-.428493000000000000000000000000d-24/, &
       b(36) / .244856000000000000000000000000d-24/, &
       b(37) / .437930000000000000000000000000d-25/, &
       b(38) /-.815100000000000000000000000000d-26/, &
       b(39) /-.308900000000000000000000000000d-26/, &
       b(40) / .930000000000000000000000000000d-28/
  data b(41) / .174000000000000000000000000000d-27/, &
       b(42) / .160000000000000000000000000000d-28/, &
       b(43) /-.800000000000000000000000000000d-29/, &
       b(44) /-.200000000000000000000000000000d-29/
!
  data e(1)  / .107797785207238315116833591035d+01/, &
       e(2)  /-.265598904091486733721465009040d-01/, &
       e(3)  /-.148707314669809950960504633300d-02/, &
       e(4)  /-.138040145414143859607708920000d-03/, &
       e(5)  /-.112803033322874914985073660000d-04/, &
       e(6)  /-.117286984274372522405373900000d-05/, &
       e(7)  /-.103476150393304615537382000000d-06/, &
       e(8)  /-.118991140858924382544470000000d-07/, &
       e(9)  /-.101622254498949864047600000000d-08/, &
       e(10) /-.137895716146965692169000000000d-09/
  data e(11) /-.936961303373730333500000000000d-11/, &
       e(12) /-.191880958395952534900000000000d-11/, &
       e(13) /-.375730172019937070000000000000d-13/, &
       e(14) /-.370537260269833570000000000000d-13/, &
       e(15) / .262756542349037100000000000000d-14/, &
       e(16) /-.112132287643793300000000000000d-14/, &
       e(17) / .184136028922538000000000000000d-15/, &
       e(18) /-.491302565748860000000000000000d-16/, &
       e(19) / .107044551673730000000000000000d-16/, &
       e(20) /-.267189366240500000000000000000d-17/
  data e(21) / .649326867976000000000000000000d-18/, &
       e(22) /-.165399353183000000000000000000d-18/, &
       e(23) / .426056266040000000000000000000d-19/, &
       e(24) /-.112558407650000000000000000000d-19/, &
       e(25) / .302561744800000000000000000000d-20/, &
       e(26) /-.829042146000000000000000000000d-21/, &
       e(27) / .231049558000000000000000000000d-21/, &
       e(28) /-.654695110000000000000000000000d-22/, &
       e(29) / .188423140000000000000000000000d-22/, &
       e(30) /-.550434100000000000000000000000d-23/
  data e(31) / .163095000000000000000000000000d-23/, &
       e(32) /-.489860000000000000000000000000d-24/, &
       e(33) / .149054000000000000000000000000d-24/, &
       e(34) /-.459220000000000000000000000000d-25/, &
       e(35) / .143180000000000000000000000000d-25/, &
       e(36) /-.451600000000000000000000000000d-26/, &
       e(37) / .144000000000000000000000000000d-26/, &
       e(38) /-.464000000000000000000000000000d-27/, &
       e(39) / .151000000000000000000000000000d-27/, &
       e(40) /-.500000000000000000000000000000d-28/
  data e(41) / .170000000000000000000000000000d-28/, &
       e(42) /-.600000000000000000000000000000d-29/, &
       e(43) / .200000000000000000000000000000d-29/, &
       e(44) /-.100000000000000000000000000000d-29/
!
  eps = epsilon ( eps )
!
!                     dabs(x) <= 1
!
  ax = dabs(x)
  if (ax > 1.d0) go to 20
  t = x*x
  w = a(21)
  do 10 i = 1,20
     k = 21 - i
     w = t*w + a(k)
   10 continue
  derfc = 0.5d0 + (0.5d0 - x*(1.d0 + w))
  return
!
!                  1 < dabs(x)  <  2
!
   20 if (ax >= 2.d0) go to 30
  n = 44
  if (eps >= 1.d-20) n = 30
  t = (ax - 3.75d0)/(ax + 3.75d0)
  derfc = dcsevl(t, b, n)
   21 derfc = dexp(-x*x) * derfc
  if (x < 0.d0) derfc = 2.d0 - derfc
  return
!
!                  2 < dabs(x)  <  12
!
   30 if (x < -9.d0) go to 60
  if (x >= 12.d0) go to 40
  n = 44
  if (eps >= 1.d-20) n = 25
  t = (1.d0/x)**2
  w = (10.5d0*t - 1.d0)/(2.5d0*t + 1.d0)
  derfc = dcsevl(w, e, n) / ax
  go to 21
!
!                       x >= 12
!
   40 if (x > 50.d0) go to 70
  t = (1.d0/x)**2
  an = -0.5d0
  c  =  0.5d0
  w  =  0.0d0
   50    c = c + 1.d0
     an = - c*an*t
     w = w + an
     if (dabs(an) > eps) go to 50
  w = (-0.5d0 + w)*t + 1.d0
  derfc = dexp(-x*x) * ((rpinv*w)/ax)
  return
!
!             limit value for large negative x
!
   60 derfc = 2.d0
  return
!
!             limit value for large positive x
!
   70 derfc = 0.d0
  return
end
function derfc1 (ind, x)
!
!*******************************************************************************
!
!! DERFC1: evaluation of the complementary error function
!
!          derfc1(ind,x) = erfc(x)           if ind = 0
!          derfc1(ind,x) = exp(x*x)*erfc(x)  otherwise
!
  double precision derfc1
  double precision an, ax, c, eps, rpinv, t, x, w
  double precision a(21), b(44), e(44)
  double precision dpmpar, dcsevl
!
!     rpinv = 1/sqrt(pi)
!
  data rpinv /.56418958354775628694807945156077259d0/
!
  data a(1)  / .1283791670955125738961589031215d+00/, &
       a(2)  /-.3761263890318375246320529677070d+00/, &
       a(3)  / .1128379167095512573896158902931d+00/, &
       a(4)  /-.2686617064513125175943235372542d-01/, &
       a(5)  / .5223977625442187842111812447877d-02/, &
       a(6)  /-.8548327023450852832540164081187d-03/, &
       a(7)  / .1205533298178966425020717182498d-03/, &
       a(8)  /-.1492565035840625090430728526820d-04/, &
       a(9)  / .1646211436588924261080723578109d-05/, &
       a(10) /-.1636584469123468757408968429674d-06/
  data a(11) / .1480719281587021715400818627811d-07/, &
       a(12) /-.1229055530145120140800510155331d-08/, &
       a(13) / .9422759058437197017313055084212d-10/, &
       a(14) /-.6711366740969385085896257227159d-11/, &
       a(15) / .4463222608295664017461758843550d-12/, &
       a(16) /-.2783497395542995487275065856998d-13/, &
       a(17) / .1634095572365337143933023780777d-14/, &
       a(18) /-.9052845786901123985710019387938d-16/, &
       a(19) / .4708274559689744439341671426731d-17/, &
       a(20) /-.2187159356685015949749948252160d-18/, &
       a(21) / .7043407712019701609635599701333d-20/
!
  data b(1)  / .610143081923200417926465815756d+00/, &
       b(2)  /-.434841272712577471828182820888d+00/, &
       b(3)  / .176351193643605501125840298123d+00/, &
       b(4)  /-.607107956092494148600512158250d-01/, &
       b(5)  / .177120689956941144861471411910d-01/, &
       b(6)  /-.432111938556729381859986496800d-02/, &
       b(7)  / .854216676887098678819832055000d-03/, &
       b(8)  /-.127155090609162742628893940000d-03/, &
       b(9)  / .112481672436711894688470720000d-04/, &
       b(10) / .313063885421820972630152000000d-06/
  data b(11) /-.270988068537762022009086000000d-06/, &
       b(12) / .307376227014076884409590000000d-07/, &
       b(13) / .251562038481762293731400000000d-08/, &
       b(14) /-.102892992132031912759000000000d-08/, &
       b(15) / .299440521199499393630000000000d-10/, &
       b(16) / .260517896872669362900000000000d-10/, &
       b(17) /-.263483992417196938600000000000d-11/, &
       b(18) /-.643404509890636443000000000000d-12/, &
       b(19) / .112457401801663447000000000000d-12/, &
       b(20) / .172815333899860980000000000000d-13/
  data b(21) /-.426410169494237500000000000000d-14/, &
       b(22) /-.545371977880191000000000000000d-15/, &
       b(23) / .158697607761671000000000000000d-15/, &
       b(24) / .208998378443340000000000000000d-16/, &
       b(25) /-.590052686940900000000000000000d-17/, &
       b(26) /-.941893387554000000000000000000d-18/, &
       b(27) / .214977356470000000000000000000d-18/, &
       b(28) / .466609850080000000000000000000d-19/, &
       b(29) /-.724301186200000000000000000000d-20/, &
       b(30) /-.238796682400000000000000000000d-20/
  data b(31) / .191177535000000000000000000000d-21/, &
       b(32) / .120482568000000000000000000000d-21/, &
       b(33) /-.672377000000000000000000000000d-24/, &
       b(34) /-.574799700000000000000000000000d-23/, &
       b(35) /-.428493000000000000000000000000d-24/, &
       b(36) / .244856000000000000000000000000d-24/, &
       b(37) / .437930000000000000000000000000d-25/, &
       b(38) /-.815100000000000000000000000000d-26/, &
       b(39) /-.308900000000000000000000000000d-26/, &
       b(40) / .930000000000000000000000000000d-28/
  data b(41) / .174000000000000000000000000000d-27/, &
       b(42) / .160000000000000000000000000000d-28/, &
       b(43) /-.800000000000000000000000000000d-29/, &
       b(44) /-.200000000000000000000000000000d-29/
!
  data e(1)  / .107797785207238315116833591035d+01/, &
       e(2)  /-.265598904091486733721465009040d-01/, &
       e(3)  /-.148707314669809950960504633300d-02/, &
       e(4)  /-.138040145414143859607708920000d-03/, &
       e(5)  /-.112803033322874914985073660000d-04/, &
       e(6)  /-.117286984274372522405373900000d-05/, &
       e(7)  /-.103476150393304615537382000000d-06/, &
       e(8)  /-.118991140858924382544470000000d-07/, &
       e(9)  /-.101622254498949864047600000000d-08/, &
       e(10) /-.137895716146965692169000000000d-09/
  data e(11) /-.936961303373730333500000000000d-11/, &
       e(12) /-.191880958395952534900000000000d-11/, &
       e(13) /-.375730172019937070000000000000d-13/, &
       e(14) /-.370537260269833570000000000000d-13/, &
       e(15) / .262756542349037100000000000000d-14/, &
       e(16) /-.112132287643793300000000000000d-14/, &
       e(17) / .184136028922538000000000000000d-15/, &
       e(18) /-.491302565748860000000000000000d-16/, &
       e(19) / .107044551673730000000000000000d-16/, &
       e(20) /-.267189366240500000000000000000d-17/
  data e(21) / .649326867976000000000000000000d-18/, &
       e(22) /-.165399353183000000000000000000d-18/, &
       e(23) / .426056266040000000000000000000d-19/, &
       e(24) /-.112558407650000000000000000000d-19/, &
       e(25) / .302561744800000000000000000000d-20/, &
       e(26) /-.829042146000000000000000000000d-21/, &
       e(27) / .231049558000000000000000000000d-21/, &
       e(28) /-.654695110000000000000000000000d-22/, &
       e(29) / .188423140000000000000000000000d-22/, &
       e(30) /-.550434100000000000000000000000d-23/
  data e(31) / .163095000000000000000000000000d-23/, &
       e(32) /-.489860000000000000000000000000d-24/, &
       e(33) / .149054000000000000000000000000d-24/, &
       e(34) /-.459220000000000000000000000000d-25/, &
       e(35) / .143180000000000000000000000000d-25/, &
       e(36) /-.451600000000000000000000000000d-26/, &
       e(37) / .144000000000000000000000000000d-26/, &
       e(38) /-.464000000000000000000000000000d-27/, &
       e(39) / .151000000000000000000000000000d-27/, &
       e(40) /-.500000000000000000000000000000d-28/
  data e(41) / .170000000000000000000000000000d-28/, &
       e(42) /-.600000000000000000000000000000d-29/, &
       e(43) / .200000000000000000000000000000d-29/, &
       e(44) /-.100000000000000000000000000000d-29/
!
                  eps = epsilon ( eps )
!
!
!
!                     dabs(x) <= 1
!
  ax = dabs(x)
  if (ax > 1.d0) go to 20
  t = x*x
  w = a(21)
  do 10 i = 1,20
     k = 21 - i
     w = t*w + a(k)
   10 continue
  derfc1 = 0.5d0 + (0.5d0 - x*(1.d0 + w))
  if (ind /= 0) derfc1 = dexp(t) * derfc1
  return
!
!                  1 < dabs(x)  <  2
!
   20 if (ax >= 2.d0) go to 40
  n = 44
  if (eps >= 1.d-20) n = 30
  t = (ax - 3.75d0)/(ax + 3.75d0)
  derfc1 = dcsevl(t, b, n)
!
   30 if (ind == 0) go to 31
     if (x < 0.d0) derfc1 = 2.d0*dexp(x*x) - derfc1
     return
   31 derfc1 = dexp(-x*x) * derfc1
  if (x < 0.d0) derfc1 = 2.d0 - derfc1
  return
!
!                  2 < dabs(x)  <  12
!
   40 if (x < -9.d0) go to 70
  if (x >= 12.d0) go to 50
  n = 44
  if (eps >= 1.d-20) n = 25
  t = (1.d0/x)**2
  w = (10.5d0*t - 1.d0)/(2.5d0*t + 1.d0)
  derfc1 = dcsevl(w, e, n) / ax
  go to 30
!
!                       x >= 12
!
   50 if (ind == 0 .and. x > 50.d0) go to 80
  t = (1.d0/x)**2
  an = -0.5d0
  c  =  0.5d0
  w  =  0.0d0
   60    c = c + 1.d0
     an = - c*an*t
     w = w + an
     if (dabs(an) > eps) go to 60
  w = (-0.5d0 + w)*t + 1.d0
  derfc1 = (rpinv*w) / ax
  if (ind == 0) derfc1 = dexp(-x*x) * derfc1
  return
!
!             limit value for large negative x
!
   70 derfc1 = 2.d0
  if (ind /= 0) derfc1 = 2.d0*dexp(x*x)
  return
!
!             limit value for large positive x
!                       when ind = 0
!
   80 derfc1 = 0.d0
  return
end
function desum (mu, x)

!*******************************************************************************
!
!! DESUM: evaluation of exp(mu + x)
!
  double precision desum
  double precision x, w
!
  if (x > 0.d0) go to 10
!
  if (mu < 0) go to 20
     w = mu + x
     if (w > 0.d0) go to 20
     desum = dexp(w)
     return
!
   10 if (mu > 0) go to 20
     w = mu + x
     if (w < 0.d0) go to 20
     desum = dexp(w)
     return
!
   20 w = mu
  desum = dexp(w)*dexp(x)
  return
end
function det(a,ka,n,x)
!
!*******************************************************************************
!
!! DET evaluates the determinant of a-xi where a is an nxn matrix,
!     x is a scalar, and i is the nxn identity matrix.
!
!     ka is the row dimension of a in the calling program. it is
!     assumed that ka is greater than or equal to n.
!
  dimension a(ka,n)
  if (n >= 2) go to 10
  det = a(1,1)-x
  return
!
!              replace a with a-xi
!
   10 if (x == 0.0) go to 20
  do 11 k=1,n
   11 a(k,k) = a(k,k)-x
!
!                initialization
!
   20 det = 1.0
  nm1 = n-1
  do 52 k=1,nm1
  kp1 = k+1
!
!       search for the k-th pivot element
!
  s = abs(a(k,k))
  l = k
  do 30 i=kp1,n
  c = abs(a(i,k))
  if (s >= c) go to 30
  s = c
  l = i
   30 continue
  pivot = a(l,k)
!
!         update the calculation of det
!
  det = det*pivot
  if (det == 0.0) return
  if (k == l) go to 50
  det = -det
!
!          interchanging rows k and l
!
  do 40 j=k,n
  c = a(k,j)
  a(k,j) = a(l,j)
   40 a(l,j) = c
!
!        reduction of the non-pivot rows
!
   50 do 51 i=kp1,n
  c = a(i,k)/pivot
  do 51 j=kp1,n
   51 a(i,j) = a(i,j)-c*a(k,j)
   52 continue
!
!         final determinant calculation
!
  det = det*a(n,n)
  return
end
function dgam1 (x)
!
!*******************************************************************************
!
!! DGAM1 evaluates 1/gamma(1 + x) - 1  for -0.5 <= x <= 1.5
!
  double precision dgam1
  double precision x, a(49), c, eps, t, w
  double precision dpmpar
!
!     c = a(1) - 1
!
  data c /-.4227843350984671393934879099175975689578d+00/
!
  data a(1)  / .5772156649015328606065120900824024310422d+00/, &
       a(2)  /-.6558780715202538810770195151453904812798d+00/, &
       a(3)  /-.4200263503409523552900393487542981871139d-01/, &
       a(4)  / .1665386113822914895017007951021052357178d+00/, &
       a(5)  /-.4219773455554433674820830128918739130165d-01/, &
       a(6)  /-.9621971527876973562114921672348198975363d-02/, &
       a(7)  / .7218943246663099542395010340446572709905d-02/, &
       a(8)  /-.1165167591859065112113971084018388666809d-02/, &
       a(9)  /-.2152416741149509728157299630536478064782d-03/, &
       a(10) / .1280502823881161861531986263281643233949d-03/
  data a(11) /-.2013485478078823865568939142102181838229d-04/, &
       a(12) /-.1250493482142670657345359473833092242323d-05/, &
       a(13) / .1133027231981695882374129620330744943324d-05/, &
       a(14) /-.2056338416977607103450154130020572836513d-06/, &
       a(15) / .6116095104481415817862498682855342867276d-08/, &
       a(16) / .5002007644469222930055665048059991303045d-08/, &
       a(17) /-.1181274570487020144588126565436505577739d-08/, &
       a(18) / .1043426711691100510491540332312250191401d-09/, &
       a(19) / .7782263439905071254049937311360777226068d-11/, &
       a(20) /-.3696805618642205708187815878085766236571d-11/
  data a(21) / .5100370287454475979015481322863231802727d-12/, &
       a(22) /-.2058326053566506783222429544855237419746d-13/, &
       a(23) /-.5348122539423017982370017318727939948990d-14/, &
       a(24) / .1226778628238260790158893846622422428165d-14/, &
       a(25) /-.1181259301697458769513764586842297831212d-15/, &
       a(26) / .1186692254751600332579777242928674071088d-17/, &
       a(27) / .1412380655318031781555803947566709037086d-17/, &
       a(28) /-.2298745684435370206592478580633699260285d-18/, &
       a(29) / .1714406321927337433383963370267257066813d-19/, &
       a(30) / .1337351730493693114864781395122268022875d-21/
  data a(31) /-.2054233551766672789325025351355733796682d-21/, &
       a(32) / .2736030048607999844831509904330982014865d-22/, &
       a(33) /-.1732356445910516639057428451564779799070d-23/, &
       a(34) /-.2360619024499287287343450735427531007926d-25/, &
       a(35) / .1864982941717294430718413161878666898946d-25/, &
       a(36) /-.2218095624207197204399716913626860379732d-26/, &
       a(37) / .1297781974947993668824414486330594165619d-27/, &
       a(38) / .1180697474966528406222745415509971518560d-29/, &
       a(39) /-.1124584349277088090293654674261439512119d-29/, &
       a(40) / .1277085175140866203990206677751124647749d-30/
!     data a(41) /-.7391451169615140823461289330108552823711d-32/,
!    *     a(42) / .1134750257554215760954165259469306393009d-34/,
!    *     a(43) / .4639134641058722029944804907952228463058d-34/,
!    *     a(44) /-.5347336818439198875077418196709893320905d-35/,
!    *     a(45) / .3207995923613352622861237279082794391090d-36/,
!    *     a(46) /-.4445829736550756882101590352124643637401d-38/,
!    *     a(47) /-.1311174518881988712901058494389922190237d-38/,
!    *     a(48) / .1647033352543813886818259327906394145400d-39/,
!    *     a(49) /-.1056233178503581218600561071538285049997d-40/
!
!
                  eps = epsilon ( eps )
!
!
  n = 29
  if (eps < 1.d-20) n = 40
!     if (eps < 1.d-31) n = 49
  np1 = n + 1
!
  if (x > 0.5d0) go to 20
!
  w = a(n)
  do 10 i = 2,n
     k = np1 - i
     w = a(k) + x*w
   10 continue
  dgam1 = x*w
  return
!
   20 t = x - 1.d0
  if (x < 1.d0) t = (x - 0.5d0) - 0.5d0
  w = a(n)
  nm1 = n - 1
  do 30 i = 2,nm1
     k = np1 - i
     w = a(k) + t*w
   30 continue
  w = c + t*w

  dgam1 = w*t/x
  return
end
function dgamln (a)
!
!*******************************************************************************
!
!! DGAMLN evaluates ln(gamma(a)) for positive a
!
!
!     written by alfred h. morris
!          Naval Surface Weapons Center,
!          Dahlgren, Virginia
!
!     d = 0.5*(ln(2*pi) - 1)
!
  double precision dgamln
  double precision a, d, x, w
  double precision dgmln1, dpdel
!
  data d  /0.41893853320467274178032973640562d0/
!
  if (a >= 0.5d0) go to 10
     dgamln = dgmln1(a) - dlog(a)
     return
   10 if (a > 2.5d0) go to 20
     x = a - 1.d0
     if (a < 1.d0) x = (a - 0.5d0) - 0.5d0
     dgamln = dgmln1(x)
     return
!
   20 if (a >= 10.d0) go to 30
  n = a - 1.5d0
  x = a
  w = 1.d0
  do 21 i = 1,n
     x = x - 1.d0
   21    w = x*w
  dgamln = dgmln1(x - 1.d0) + dlog(w)
  return
!
   30 w = dpdel(a)
  dgamln = (d + w) + (a - 0.5d0)*(dlog(a) - 1.d0)
end
function dgamma(a)
!
!*******************************************************************************
!
!! DGAMMA evaluates the gamma function.
!
!               ---
!
!     dgamma(a) is assigned the value 0 when the gamma function cannot
!     be computed.
!
!
!     written by Alfred Morris,
!          Naval Surface Weapons Center,
!          Dahlgren, Virginia
!
!
!     series for dgamma on the interval  0.0 to 1.0 developed by
!     wayne fullerton (los alamos national laboratory)
!
!                                  with weighted error   5.79e-32
!                                   log weighted error  31.24
!                         significant figures required  30.00
!                              decimal places required  32.05
!
!
  double precision dgamma
  double precision a, c(42), d, pi, s, t, x, w
  double precision dpmpar, dcsevl, dpdel, dxparg
!
!     d = 0.5*(ln(2*pi) - 1)
!
  data pi /3.14159265358979323846264338327950d0/
  data d  /0.41893853320467274178032973640562d0/
!
  data c(1)  / .8571195590989331421920062399942d-02/, &
       c(2)  / .4415381324841006757191315771652d-02/, &
       c(3)  / .5685043681599363378632664588789d-01/, &
       c(4)  /-.4219835396418560501012500186624d-02/, &
       c(5)  / .1326808181212460220584006796352d-02/, &
       c(6)  /-.1893024529798880432523947023886d-03/, &
       c(7)  / .3606925327441245256578082217225d-04/, &
       c(8)  /-.6056761904460864218485548290365d-05/, &
       c(9)  / .1055829546302283344731823509093d-05/, &
       c(10) /-.1811967365542384048291855891166d-06/
  data c(11) / .3117724964715322277790254593169d-07/, &
       c(12) /-.5354219639019687140874081024347d-08/, &
       c(13) / .9193275519859588946887786825940d-09/, &
       c(14) /-.1577941280288339761767423273953d-09/, &
       c(15) / .2707980622934954543266540433089d-10/, &
       c(16) /-.4646818653825730144081661058933d-11/, &
       c(17) / .7973350192007419656460767175359d-12/, &
       c(18) /-.1368078209830916025799499172309d-12/, &
       c(19) / .2347319486563800657233471771688d-13/, &
       c(20) /-.4027432614949066932766570534699d-14/
  data c(21) / .6910051747372100912138336975257d-15/, &
       c(22) /-.1185584500221992907052387126192d-15/, &
       c(23) / .2034148542496373955201026051932d-16/, &
       c(24) /-.3490054341717405849274012949108d-17/, &
       c(25) / .5987993856485305567135051066026d-18/, &
       c(26) /-.1027378057872228074490069778431d-18/, &
       c(27) / .1762702816060529824942759660748d-19/, &
       c(28) /-.3024320653735306260958772112042d-20/, &
       c(29) / .5188914660218397839717833550506d-21/, &
       c(30) /-.8902770842456576692449251601066d-22/
  data c(31) / .1527474068493342602274596891306d-22/, &
       c(32) /-.2620731256187362900257328332799d-23/, &
       c(33) / .4496464047830538670331046570666d-24/, &
       c(34) /-.7714712731336877911703901525333d-25/, &
       c(35) / .1323635453126044036486572714666d-25/, &
       c(36) /-.2270999412942928816702313813333d-26/, &
       c(37) / .3896418998003991449320816639999d-27/, &
       c(38) /-.6685198115125953327792127999999d-28/, &
       c(39) / .1146998663140024384347613866666d-28/, &
       c(40) /-.1967938586345134677295103999999d-29/
  data c(41) / .3376448816585338090334890666666d-30/, &
       c(42) /-.5793070335782135784625493333333d-31/
!
  dgamma = 0.d0
  x = a
  if (dabs(a) > 20.d0) go to 60
!
!             evaluation of dgamma(a) for dabs(a) <= 20
!
  t = 1.d0
  n = x
  n = n - 1
!
!     let t be the product of a-j when a >= 2
!
  if (n) 20,12,10
   10 do 11 j = 1,n
     x = x - 1.d0
   11    t = x*t
   12 x = x - 1.d0
  go to 40
!
!     let t be the product of a+j when a < 1
!
   20 t = a
  if (a > 0.d0) go to 30
  n = - n - 1
  if (n == 0) go to 22
     do j = 1,n
       x = x + 1.d0
       t = x*t
     end do
   22 x = (x + 0.5d0) + 0.5d0
  t = x*t
  if (t == 0.d0) return
!
   30 continue
!
!     the following code checks if 1/t can overflow. this
!     code may be omitted if desired.
!
  if (dabs(t) >= 1.d-33) go to 40
  if (dabs(t)*dpmpar(3) <= 1.000000001d0) return
  dgamma = 1.d0/t
  return
!
!     compute dgamma(1 + x) for 0 <= x < 1
!
   40 dgamma = 0.9375d0 + dcsevl (2.d0*x-1.d0, c, 42)
!
!     termination
!
  if (a < 1.d0) go to 50
     dgamma = dgamma * t
     return
   50 dgamma = dgamma / t
  return
!
!           evaluation of dgamma(a) for dabs(a) > 20
!
   60 if (dabs(a) >= 1.d3) return
  if (a > 0.d0) go to 70
  x = -a
  n = x
  t = x - n
  if (t > 0.9d0) t = 1.d0 - t
  s = dsin(pi*t)/pi
  if (mod(n,2) == 0) s = -s
  if (s == 0.d0) return
!
!     compute the modified asymptotic sum
!
   70 w = dpdel(x)
!
!     final assembly
!
  w = (d + w) + (x - 0.5d0)*(dlog(x) - 1.d0)
  if (w > dxparg(0)) return
  dgamma = dexp(w)
  if (a < 0.d0) dgamma = (1.d0/(dgamma*s))/x
  return
end
function dgmln1 (x)
!
!*******************************************************************************
!
!! DGMLN1: evaluation of ln(gamma(1 + x)) for -0.5 <= x <= 1.5
!
  double precision dgmln1
  double precision x, a(49), c, eps, r, t, w
  double precision dpmpar, dlnrel
!
!     c = a(1) - 1
!
  data c /-.4227843350984671393934879099175975689578d+00/
!
  data a(1)  / .5772156649015328606065120900824024310422d+00/, &
       a(2)  /-.6558780715202538810770195151453904812798d+00/, &
       a(3)  /-.4200263503409523552900393487542981871139d-01/, &
       a(4)  / .1665386113822914895017007951021052357178d+00/, &
       a(5)  /-.4219773455554433674820830128918739130165d-01/, &
       a(6)  /-.9621971527876973562114921672348198975363d-02/, &
       a(7)  / .7218943246663099542395010340446572709905d-02/, &
       a(8)  /-.1165167591859065112113971084018388666809d-02/, &
       a(9)  /-.2152416741149509728157299630536478064782d-03/, &
       a(10) / .1280502823881161861531986263281643233949d-03/
  data a(11) /-.2013485478078823865568939142102181838229d-04/, &
       a(12) /-.1250493482142670657345359473833092242323d-05/, &
       a(13) / .1133027231981695882374129620330744943324d-05/, &
       a(14) /-.2056338416977607103450154130020572836513d-06/, &
       a(15) / .6116095104481415817862498682855342867276d-08/, &
       a(16) / .5002007644469222930055665048059991303045d-08/, &
       a(17) /-.1181274570487020144588126565436505577739d-08/, &
       a(18) / .1043426711691100510491540332312250191401d-09/, &
       a(19) / .7782263439905071254049937311360777226068d-11/, &
       a(20) /-.3696805618642205708187815878085766236571d-11/
  data a(21) / .5100370287454475979015481322863231802727d-12/, &
       a(22) /-.2058326053566506783222429544855237419746d-13/, &
       a(23) /-.5348122539423017982370017318727939948990d-14/, &
       a(24) / .1226778628238260790158893846622422428165d-14/, &
       a(25) /-.1181259301697458769513764586842297831212d-15/, &
       a(26) / .1186692254751600332579777242928674071088d-17/, &
       a(27) / .1412380655318031781555803947566709037086d-17/, &
       a(28) /-.2298745684435370206592478580633699260285d-18/, &
       a(29) / .1714406321927337433383963370267257066813d-19/, &
       a(30) / .1337351730493693114864781395122268022875d-21/
  data a(31) /-.2054233551766672789325025351355733796682d-21/, &
       a(32) / .2736030048607999844831509904330982014865d-22/, &
       a(33) /-.1732356445910516639057428451564779799070d-23/, &
       a(34) /-.2360619024499287287343450735427531007926d-25/, &
       a(35) / .1864982941717294430718413161878666898946d-25/, &
       a(36) /-.2218095624207197204399716913626860379732d-26/, &
       a(37) / .1297781974947993668824414486330594165619d-27/, &
       a(38) / .1180697474966528406222745415509971518560d-29/, &
       a(39) /-.1124584349277088090293654674261439512119d-29/, &
       a(40) / .1277085175140866203990206677751124647749d-30/
!     data a(41) /-.7391451169615140823461289330108552823711d-32/,
!    *     a(42) / .1134750257554215760954165259469306393009d-34/,
!    *     a(43) / .4639134641058722029944804907952228463058d-34/,
!    *     a(44) /-.5347336818439198875077418196709893320905d-35/,
!    *     a(45) / .3207995923613352622861237279082794391090d-36/,
!    *     a(46) /-.4445829736550756882101590352124643637401d-38/,
!    *     a(47) /-.1311174518881988712901058494389922190237d-38/,
!    *     a(48) / .1647033352543813886818259327906394145400d-39/,
!    *     a(49) /-.1056233178503581218600561071538285049997d-40/
!
!
                  eps = epsilon ( eps )
!
!
  n = 29
  if (eps < 1.d-20) n = 40
!     if (eps < 1.d-31) n = 49
  np1 = n + 1
!
  if (x > 0.5d0) go to 20
!
  w = a(n)
  do i = 2,n
     k = np1 - i
     w = a(k) + x*w
  end do
  dgmln1 = - dlnrel(x*w)
  return

   20 t = x - 1.d0
  if (x < 1.d0) t = (x - 0.5d0) - 0.5d0
  w = a(n)
  nm1 = n - 1
  do 30 i = 2,nm1
     k = np1 - i
     w = a(k) + t*w
   30 continue
  w = c + t*w
!
  r = w*t/x
  dgmln1 = - dlnrel(r)
  return
end
subroutine dgnrtp(degree,alpha,psi,indexs, &
                    newkj,sumsqs,coord,ncrows,npolys, &
                    dimen,npts,f,z,c,psiwid,weight, &
                    alfl,dimp1,maxabs,error)
!
!*******************************************************************************
!
!! DGNRTP is a utility routine used by dmfit.
!
!     the multinomial fit is generated incrementally, a basis  element
!     at a time.  this subroutine starts the process off by setting up
!     the first basis element, scaling the  data,  finding  the  first
!     coefficient,  and  initializing  the  work array z.  dgnrtp then
!     calls  dincdg  if more than one basis element is required.
!
!     this subroutine is called by  dmfit .  it is not called by  the
!     user.
!
!     this subroutine calls  dscalp ,  dscald , and  dincdg .
!
!
!     modified by a.h. morris (nswc)
!    ******
  integer degree,dimen,npolys,npts,k,psiwid,alfl,p,sttdeg,onplys
  integer error,dimp1
  integer indexs(4,npolys),newkj(dimen,degree)
  double precision psi(npts,psiwid),alpha(alfl),f(npts)
  double precision coord(ncrows,dimen),maxabs(dimp1),weight(npts)
  double precision z(npts),sumsqs(npolys),c(npolys)
  double precision runtot,rntot1
!    *****
!     set up the scaling.
!    *****
!
  do 10 k = 1,dimen
     call dscalp(coord(1,k),npts,maxabs(k))
 10      call dscald(coord(1,k),npts,maxabs(k))
  call dscalp(f,npts,maxabs(dimp1))
  call dscald(f,npts,maxabs(dimp1))
!
!    *****
!      sumsqs (1) = (1,1)
!     c  = (f,1) / (1,1)
!      1
!    *****
!
  runtot = 0.d0
  rntot1 = 0.d0
  do 20 p = 1,npts
     psi(p,1) = 1.d0
     rntot1 = rntot1 + weight(p)
 20      runtot = runtot + f(p) * weight(p)
  sumsqs(1) = rntot1
  c(1) = runtot / rntot1
!
!    *****
!     z = f - c
!              1
!    *****
!
  do 30 p = 1,npts
 30      z(p) = f(p) - c(1)
!
  if ( npolys == 1 ) return
  sttdeg = 1
  onplys = 1
!
  call dincdg(degree,alpha,psi,indexs,newkj,sumsqs, &
              coord,ncrows,npolys,dimen,npts,f,z,c,psiwid, &
              weight,alfl,onplys,sttdeg,error)
  return
end
function dgsmln (a, b)
!
!*******************************************************************************
!
!! DGSMLN: evaluation of the function ln(gamma(a + b))
!          for 1 <= a <= 2  and  1 <= b <= 2
!
  double precision dgsmln
  double precision a, b, x
  double precision dgmln1, dlnrel
!
  x = (a - 1.d0) + (b - 1.d0)
  if (x > 0.5d0) go to 10
     dgsmln = dgmln1(1.d0 + x)
     return
   10 if (x > 1.5d0) go to 20
     dgsmln = dgmln1(x) + dlnrel(x)
     return
   20 dgsmln = dgmln1(x - 1.d0) + dlog(x*(1.d0 + x))
  return
end
subroutine dh12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv)
!
!*******************************************************************************
!
!! DH12 contructs or applies a single householder transformation.
!
!
!     written by c.l. lawson and r.j. hanson.  modified by a.h. morris.
!     from the book solving least squares problems, prentice-hall, 1974.
!
!     construction and/or application of a single
!     householder transformation..     q = i + u*(u**t)/b
!
!     mode    = 1 or 2   to select algorithm  h1  or  h2 .
!     lpivot is the index of the pivot element.
!     l1,m   if l1 <= m   the transformation will be constructed to
!            zero elements indexed from l1 through m.   if l1 gt. m
!            the subroutine does an identity transformation.
!     u(),iue,up    on entry to h1 u() contains the pivot vector.
!                   iue is the storage increment between elements.
!                                       on exit from h1 u() and up
!                   contain quantities defining the vector u of the
!                   householder transformation.   on entry to h2 u()
!                   and up should contain quantities previously computed
!                   by h1.  these will not be modified by h2.
!     c()    on entry to h1 or h2 c() contains a matrix which will be
!            regarded as a set of vectors to which the householder
!            transformation is to be applied.  on exit c() contains the
!            set of transformed vectors.
!     ice    storage increment between elements of vectors in c().
!     icv    storage increment between vectors in c().
!     ncv    number of vectors in c() to be transformed. if ncv <= 0
!            no operations will be done on c().
!
  double precision u(iue,m),up,c(*)
  double precision b,cl,d,sm
!
  if (0 >= lpivot .or. lpivot >= l1 .or. l1 > m) return
  cl = dabs(u(1,lpivot))
  if (mode == 2) go to 60
!
!                            ****** construct the transformation. ******
!
      do 10 j = l1,m
   10     cl = dmax1(dabs(u(1,j)),cl)
  if (cl <= 0.d0) go to 130
  d = u(1,lpivot)/cl
  sm = d*d
      do 20 j = l1,m
      d = u(1,j)/cl
   20     sm = sm + d*d
!
  cl = cl*dsqrt(sm)
  if (u(1,lpivot) > 0.d0) cl = -cl
  up = u(1,lpivot) - cl
  u(1,lpivot) = cl
  go to 70
!
!            ****** apply the transformation  i+u*(u**t)/b  to c.
!
   60 if (cl) 130,130,70
   70 if (ncv <= 0) return
  b = up*u(1,lpivot)
!
!                       b  must be nonpositive here.  if b = 0., return.
!
  if (b >= 0.d0) go to 130
  b = 1.d0/b
  i2 = 1 - icv + ice*(lpivot - 1)
  incr = ice*(l1 - lpivot)
      do 120 j = 1,ncv
      i2 = i2 + icv
      i3 = i2 + incr
      i4 = i3
      sm = c(i2)*up
          do 90 i = l1,m
          sm = sm + c(i3)*u(1,i)
   90         i3 = i3 + ice
      if (sm == 0.d0) go to 120
      sm = sm*b
      c(i2) = c(i2) + sm*up
          do 110 i = l1,m
          c(i4) = c(i4) + sm*u(1,i)
  110         i4 = i4 + ice
  120     continue
  130 return
end
subroutine dhfti (a,mda,m,n,b,mdb,nb,tau,k,rnorm,h,g,ip)

!*******************************************************************************
!
!! DHFTI solves a linear least squares problem.
!
!
!     double precision a(mda,n),(b(mdb,nb) or b(m))
!     double precision tau,rnorm(nb),h(n),g(n)
!     integer ip(n)
!
!     written by c.l. lawson and r.j. hanson.
!     from the book solving least squares problems, prentice-hall, 1974.
!     for algorithmic details see algorithm hfti in chapter 14.
!
!     abstract
!
!     this subroutine solves a linear least squares problem or a set of
!     linear least squares problems having the same matrix but different
!     right-side vectors.  the problem data consists of an m by n matrix
!     a, an m by nb matrix b, and an absolute tolerance parameter tau
!     whose usage is described below.  the nb column vectors of b
!     represent right-side vectors for nb distinct linear least squares
!     problems.
!
!     this set of problems can also be written as the matrix least
!     squares problem
!
!                       ax = b,
!
!     where x is the n by nb solution matrix.
!
!     note that if b is the m by m identity matrix, then x will be the
!     pseudo-inverse of a.
!
!     this subroutine first transforms the augmented matrix (a b) to a
!     matrix (r c) using premultiplying householder transformations with
!     column interchanges.  all subdiagonal elements in the matrix r are
!     zero and its diagonal elements satisfy
!
!                       dabs(r(i,i)) >= dabs(r(i+1,i+1)),
!
!                       i = 1,...,l-1, where
!
!                       l = min(m,n).
!
!     the subroutine sets k to be the number of diagonal elements
!     of r that exceed tau in magnitude. then the solution of minimum
!     euclidean length is computed using the first k rows of (r c).
!
!     to be specific we suggest that the user consider an easily
!     computable matrix norm, such as, the maximum of all column sums of
!     magnitudes.
!
!     now if the relative uncertainty of b is eps, (norm of uncertainty/
!     norm of b), it is suggested that tau be set approximately equal to
!     eps*(norm of a).
!
!     the entire set of parameters for dhfti are
!
!     input..
!
!     a(*,*),mda,m,n    the array a(*,*) initially contains the m by n
!                       matrix a of the least squares problem ax = b.
!                       the first dimensioning parameter of the array
!                       a(*,*) is mda, which must satisfy mda >= m
!                       either m >= n or m < n is permitted.  there
!                       is no restriction on the rank of a.  the
!                       condition mda < m is considered an error.
!
!     b(*),mdb,nb       if nb = 0 the subroutine will perform the
!                       orthogonal decomposition but will make no
!                       references to the array b(*).  if nb > 0
!                       the array b(*) must initially contain the m by
!                       nb matrix b of the least squares problem ax =
!                       b.  if nb >= 2 the array b(*) must be doubly
!                       subscripted with first dimensioning parameter
!                       mdb >= max(m,n).  if nb = 1 the array b(*) may
!                       be either doubly or singly subscripted.  in
!                       the latter case the value of mdb is arbitrary
!                       but it should be set to some valid integer
!                       value such as mdb = m.
!
!                       the condition of nb > 1.and.mdb <  max(m,n)
!                       is considered an error.
!
!     tau               absolute tolerance parameter provided by user
!                       for pseudorank determination.
!
!     h(*),g(*),ip(*)   arrays of working space used by dhfti.
!
!     output..
!
!     a(*,*)            the contents of the array a(*,*) will be
!                       modified by the subroutine.  these contents
!                       are not generally required by the user.
!
!     b(*)              on return the array b(*) will contain the n by
!                       nb solution matrix x.
!
!     k                 set by the subroutine to indicate the
!                       pseudorank of a.
!
!     rnorm(*)          on return, rnorm(j) will contain the euclidean
!                       norm of the residual vector for the problem
!                       defined by the j-th column vector of the array
!                       b(*,*) for j = 1,...,nb.
!
!     h(*),g(*)         on return these arrays respectively contain
!                       elements of the pre- and post-multiplying
!                       householder transformations used to compute
!                       the minimum euclidean length solution.
!
!     ip(*)             array in which the subroutine records indices
!                       describing the permutation of column vectors.
!                       the contents of arrays h(*),g(*) and ip(*)
!                       are not generally required by the user.
!
  double precision a(mda,n),b(mdb,*),tau,rnorm(*),h(n),g(n)
  integer ip(n)
  double precision factor,hmax,sm,sm1,tmp,z

  data factor /1.d-3/

  k = 0
  ldiag = min (m,n)
  if (ldiag <= 0) go to 270
      do 80 j = 1,ldiag
      if (j == 1) go to 20
!
!     update squared column lengths and find lmax
!
      lmax = j
          do 10 l = j,n
          h(l) = h(l) - a(j-1,l)**2
          if (h(l) > h(lmax)) lmax = l
   10         continue
      z = hmax + factor*h(lmax)
      if (z > hmax) go to 50
!
!     compute squared column lengths and find lmax
!    ..
   20     lmax=j
          do 40 l = j,n
          h(l) = 0.d0
              do 30 i = j,m
   30             h(l) = h(l) + a(i,l)**2
          if (h(l) > h(lmax)) lmax = l
   40         continue
      hmax = h(lmax)
!    ..
!     lmax has been determined
!
!     do column interchanges if needed.
!    ..
   50     ip(j) = lmax
      if (ip(j) == j) go to 70
          do 60 i = 1,m
          tmp = a(i,j)
          a(i,j) = a(i,lmax)
   60         a(i,lmax) = tmp
      h(lmax) = h(j)
!
!     compute the j-th transformation and apply it to a and b.
!    ..
   70     call dh12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)
   80     call dh12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
!
!     determine the pseudorank, k, using the tolerance, tau.
!    ..
      do 90 j = 1,ldiag
      if (dabs(a(j,j)) <= tau) go to 100
   90     continue
  k = ldiag
  go to 110
  100 k = j - 1
  110 kp1 = k + 1
!
!     compute the norms of the residual vectors.
!
  if (nb <= 0) go to 140
      do 130 jb = 1,nb
      tmp = 0.d0
      if (kp1 > m) go to 130
          do 120 i = kp1,m
  120         tmp = tmp + b(i,jb)**2
  130     rnorm(jb) = dsqrt(tmp)
  140 continue
!                                           special for pseudorank = 0
  if (k > 0) go to 160
  if (nb <= 0) go to 270
      do 151 jb = 1,nb
          do 150 i = 1,n
  150         b(i,jb) = 0.d0
  151     continue
  go to 270
!
!     if the pseudorank is less than n compute householder
!     decomposition of first k rows.
!    ..
  160 if (k == n) go to 180
      do 170 ii = 1,k
      i = kp1 - ii
  170     call dh12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
!
!
  if (nb <= 0) go to 270
      do 260 jb = 1,nb
!
!     solve the k by k triangular system.
!    ..
          do 210 l = 1,k
          sm = 0.d0
          i = kp1 - l
          if (i == k) go to 200
          ip1 = i + 1
              do 190 j = ip1,k
  190             sm = sm + a(i,j)*b(j,jb)
  200         sm1 = b(i,jb) - sm
  210         b(i,jb) = sm1/a(i,i)
!
!     complete computation of solution vector.
!    ..
      if (k == n) go to 240
          do 220 j = kp1,n
  220         b(j,jb) = 0.d0
          do 230 i = 1,k
  230         call dh12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
!
!      re-order the solution vector to compensate for the
!      column interchanges.
!    ..
  240         do 250 jj = 1,ldiag
          j = ldiag + 1 - jj
          if (ip(j) == j) go to 250
          l = ip(j)
          tmp = b(l,jb)
          b(l,jb) = b(j,jb)
          b(j,jb) = tmp
  250         continue
  260     continue
!    ..
!     the solution vectors, x, are now
!     in the first  n  rows of the array b(,).
!
  270 return
end
subroutine dhfti2(a,mda,m,n,b,mdb,nb,d,tau,k,rnorm,h,g,ip,ierr)

!*******************************************************************************
!
!! DHFTI2 solves a linear least squares problem.
!
!     written by c.l. lawson and r.j. hanson. modified by a.h. morris.
!     from the book solving least squares problems, prentice-hall, 1974.
!     for algorithmic details see algorithm hfti in chapter 14.
!
!     abstract
!
!     this subroutine solves a linear least squares problem or a set of
!     linear least squares problems having the same matrix but different
!     right-side vectors.  the problem data consists of an m by n matrix
!     a, an m by nb matrix b, and an absolute tolerance parameter tau
!     whose usage is described below.  the nb column vectors of b
!     represent right-side vectors for nb distinct linear least squares
!     problems.
!
!     this set of problems can also be written as the matrix least
!     squares problem
!
!                       ax = b,
!
!     where x is the n by nb solution matrix.
!
!     note that if b is the m by m identity matrix, then x will be the
!     pseudo-inverse of a.
!
!     this subroutine first transforms the augmented matrix (a b) to a
!     matrix (r c) using premultiplying householder transformations with
!     column interchanges.  all subdiagonal elements in the matrix r are
!     zero and its diagonal elements satisfy
!
!                       dabs(r(i,i)) >= dabs(r(i+1,i+1)),
!
!                       i = 1,...,l-1, where
!
!                       l = min(m,n).
!
!     the array d will contain the diagonal elements r(1,1),...,r(l,l).
!     the subroutine sets k to be the number of diagonal elements that
!     exceed tau in magnitude.  then the solution of minimum euclidean
!     length is computed using the first k rows of (r c).
!
!     to be specific we suggest that the user consider an easily
!     computable matrix norm, such as, the maximum of all column sums of
!     magnitudes.
!
!     now if the relative uncertainty of b is eps, (norm of uncertainty/
!     norm of b), it is suggested that tau be set approximately equal to
!     eps*(norm of a).
!
!     the entire set of parameters for dhfti2 are
!
!     input..
!
!     a(*,*),mda,m,n    the array a(*,*) initially contains the m by n
!                       matrix a of the least squares problem ax = b.
!                       the first dimensioning parameter of the array
!                       a(*,*) is mda, which must satisfy mda >= m
!                       either m >= n or m < n is permitted.  there
!                       is no restriction on the rank of a.  the
!                       condition mda < m is considered an error.
!
!     b(*),mdb,nb       if nb = 0 the subroutine will perform the
!                       orthogonal decomposition but will make no
!                       references to the array b(*).  if nb > 0
!                       the array b(*) must initially contain the m by
!                       nb matrix b of the least squares problem ax =
!                       b.  if nb >= 2 the array b(*) must be doubly
!                       subscripted with first dimensioning parameter
!                       mdb >= max(m,n).  if nb = 1 the array b(*) may
!                       be either doubly or singly subscripted.  in
!                       the latter case the value of mdb is arbitrary
!                       but it should be set to some valid integer
!                       value such as mdb = m.
!
!                       the condition of nb > 1.and.mdb <  max(m,n)
!                       is considered an error.
!
!     tau               absolute tolerance parameter provided by user
!                       for pseudorank determination.
!
!     h(*),g(*),ip(*)   arrays of working space used by dhfti2.
!
!     output..
!
!     a(*,*)            the contents of the array a(*,*) will be
!                       modified by the subroutine.  these contents
!                       are not generally required by the user.
!
!     b(*)              on return the array b(*) will contain the n by
!                       nb solution matrix x.
!
!     d(*)              the array of diagonal elements of the
!                       triangular matrix r
!
!     k                 set by the subroutine to indicate the
!                       pseudorank of a.
!
!     rnorm(*)          on return, rnorm(j) will contain the euclidean
!                       norm of the residual vector for the problem
!                       defined by the j-th column vector of the array
!                       b(*,*) for j = 1,...,nb.
!
!     h(*),g(*)         on return these arrays respectively contain
!                       elements of the pre- and post-multiplying
!                       householder transformations used to compute
!                       the minimum euclidean length solution.
!
!     ip(*)             array in which the subroutine records indices
!                       describing the permutation of column vectors.
!                       the contents of arrays h(*),g(*) and ip(*)
!                       are not generally required by the user.
!
!     ierr              error indicator. if no input errors are
!                       detected then ierr is set to 0. otherwise
!                          ierr = 1  if mda < m
!                          ierr = 2  if nb > 1 and mdb < max(m,n)
!                       these errors are fatal.
!
  double precision a(mda,n),b(mdb,*),d(*),tau,rnorm(*),h(n),g(n)
  integer ip(n)
  double precision factor,hmax,sm,sm1,tmp,z
!
  data factor /1.d-3/
!
  k = 0
  ldiag = min (m,n)
  if (ldiag <= 0) go to 270
  if (m > mda) go to 300
  if (nb > 1 .and. max (m,n)  >  mdb) go to 310

      do 80 j = 1,ldiag
      if (j == 1) go to 20
!
!     update squared column lengths and find lmax
!    ..
      lmax = j
          do 10 l = j,n
          h(l) = h(l) - a(j-1,l)**2
          if (h(l) > h(lmax)) lmax = l
   10         continue
      z = hmax + factor*h(lmax)
      if (z > hmax) go to 50
!
!     compute squared column lengths and find lmax
!    ..
   20     lmax = j
          do 40 l = j,n
          h(l) = 0.d0
              do 30 i = j,m
   30             h(l) = h(l) + a(i,l)**2
          if (h(l) > h(lmax)) lmax = l
   40         continue
      hmax = h(lmax)
!    ..
!     lmax has been determined
!
!     do column interchanges if needed.
!    ..
   50     ip(j) = lmax
      if (ip(j) == j) go to 70
          do 60 i = 1,m
          tmp = a(i,j)
          a(i,j) = a(i,lmax)
   60         a(i,lmax) = tmp
      h(lmax) = h(j)
!
!     compute the j-th transformation and apply it to a and b.
!    ..
   70     call dh12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)
   80     call dh12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
!
!     determine the pseudorank, k, using the tolerance, tau.
!     also store the diagonal elements in the array d.
!
      do 90 j = 1,ldiag
      if (dabs(a(j,j)) <= tau) go to 100
   90     d(j) = a(j,j)
      k = ldiag
      kp1 = k + 1
      go to 110
!
  100     k = j - 1
      kp1 = j
      do 105 j = kp1,ldiag
  105     d(j) = a(j,j)
!
!     compute the norms of the residual vectors.
!
  110 if (nb <= 0) go to 140
      do 130 jb = 1,nb
      tmp = 0.d0
      if (kp1 > m) go to 130
          do 120 i = kp1,m
  120         tmp = tmp + b(i,jb)**2
  130     rnorm(jb) = dsqrt(tmp)
  140 continue
!                                           special for pseudorank = 0
  if (k > 0) go to 160
  if (nb <= 0) go to 270
      do 151 jb = 1,nb
          do 150 i = 1,n
  150         b(i,jb) = 0.d0
  151     continue
  go to 270
!
!     if the pseudorank is less than n compute householder
!     decomposition of first k rows.
!    ..
  160 if (k == n) go to 180
      do 170 ii = 1,k
      i = kp1 - ii
  170     call dh12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
!
!
  if (nb <= 0) go to 270
      do 260 jb = 1,nb
!
!     solve the k by k triangular system.
!    ..
          do 210 l = 1,k
          sm = 0.d0
          i = kp1 - l
          if (i == k) go to 200
          ip1 = i + 1
              do 190 j = ip1,k
  190             sm = sm + a(i,j)*b(j,jb)
  200         sm1 = b(i,jb) - sm
  210         b(i,jb)=sm1/a(i,i)
!
!     complete computation of solution vector.
!    ..
      if (k == n) go to 240
          do 220 j = kp1,n
  220         b(j,jb) = 0.d0
          do 230 i = 1,k
  230         call dh12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
!
!      re-order the solution vector to compensate for the
!      column interchanges.
!    ..
  240         do 250 jj = 1,ldiag
          j = ldiag + 1 - jj
          if (ip(j) == j) go to 250
          l = ip(j)
          tmp = b(l,jb)
          b(l,jb) = b(j,jb)
          b(j,jb) = tmp
  250         continue
  260     continue
!    ..
!     the solution vectors, x, are now
!     in the first  n  rows of the array b(,).
!
  270 ierr = 0
  return
!
!     error return
!
  300 ierr = 1
  return
  310 ierr = 2
  return
end
subroutine dhqr(nm,n,low,igh,h,wr,wi,ierr)

!*******************************************************************************
!
!! DHQR finds the eigenvalues of a double precision upper hessenberg matrix
!  by the qr method.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if dbal has not been used then
!          set low=1, igh=n,
!
!        h contains the upper hessenberg matrix.  information about
!          the transformations used in the reduction to hessenberg
!          form by dorth, if performed, is stored
!          in the remaining triangle under the hessenberg matrix.
!
!     on output-
!
!        h has been destroyed.  therefore, it must be saved
!          before calling  hqr  if subsequent calculation and
!          back transformation of eigenvectors is to be performed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 50 iterations.
!
  integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,its,low,mp2,enm2,ierr
  double precision h(nm,n),wr(n),wi(n)
  double precision p,q,r,s,t,w,x,y,zz,norm,machep,dpmpar
!     double precision dsqrt,dabs
!     integer min0
  logical notlas
!
!
!    machep is a machine dependent parameter. assign
!                machep the value u where u is the smallest positive
!                floating point number such that 1.0 + u > 1.0
!                in the double precision arithmetic being used.
!
             machep = dpmpar(1)
!
!
!
  ierr = 0
  norm = 0.d0
  k = 1
!    store roots isolated by dbal
!                and compute matrix norm
  do 50 i = 1, n
!
     do 40 j = k, n
   40    norm = norm + dabs(h(i,j))

     k = i
     if (i >= low .and. i <= igh) go to 50
     wr(i) = h(i,i)
     wi(i) = 0.d0
   50 continue
!
  en = igh
  t = 0.d0
!    search for next eigenvalues
   60 if (en < low) go to 1001
  its = 0
  na = en - 1
  enm2 = na - 1
!    look for single small sub-diagonal element
!                for l=en step -1 until low do --
   70 do 80 ll = low, en
     l = en + low - ll
     if (l == low) go to 100
     s = dabs(h(l-1,l-1)) + dabs(h(l,l))
     if (s == 0.d0) s = norm
     if (dabs(h(l,l-1)) <= machep * s) go to 100
   80 continue
!    form shift
  100 x = h(en,en)
  if (l == en) go to 270
  y = h(na,na)
  w = h(en,na) * h(na,en)
  if (l == na) go to 280
  if (its == 50) go to 1000
  if (its /= 10 .and. its /= 20 .and. its /= 30) go to 130
!    form exceptional shift
  t = t + x
!
  do 120 i = low, en
  120 h(i,i) = h(i,i) - x
!
  s = dabs(h(en,na)) + dabs(h(na,enm2))
  x = .75d0 * s
  y = x
  w = -.4375d0 * s * s
  130 its = its + 1
!    look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do --
  do 140 mm = l, enm2
     m = enm2 + l - mm
     zz = h(m,m)
     r = x - zz
     s = y - zz
     p = (r * s - w) / h(m+1,m) + h(m,m+1)
     q = h(m+1,m+1) - zz - r - s
     r = h(m+2,m+1)
     s = dabs(p) + dabs(q) + dabs(r)
     p = p / s
     q = q / s
     r = r / s
     if (m == l) go to 150
     if (dabs(h(m,m-1)) * (dabs(q) + dabs(r)) <= machep * dabs(p) &
      * (dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))) go to 150
  140 continue
!
  150 mp2 = m + 2
!
  do 160 i = mp2, en
     h(i,i-2) = 0.d0
     if (i == mp2) go to 160
     h(i,i-3) = 0.d0
  160 continue
!    double qr step involving rows l to en and
!                columns m to en
  do 260 k = m, na
     notlas = k /= na
     if (k == m) go to 170
     p = h(k,k-1)
     q = h(k+1,k-1)
     r = 0.d0
     if (notlas) r = h(k+2,k-1)
     x = dabs(p) + dabs(q) + dabs(r)
     if (x == 0.d0) go to 260
     p = p / x
     q = q / x
     r = r / x
  170    s = dsqrt(p*p + q*q + r*r)
     if (p < 0.d0) s = -s
     if (k == m) go to 180
     h(k,k-1) = -s * x
     go to 190
  180    if (l /= m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
     x = p / s
     y = q / s
     zz = r / s
     q = q / p
     r = r / p
!    row modification
     do 210 j = k, en
        p = h(k,j) + q * h(k+1,j)
        if (.not. notlas) go to 200
        p = p + r * h(k+2,j)
        h(k+2,j) = h(k+2,j) - p * zz
  200       h(k+1,j) = h(k+1,j) - p * y
        h(k,j) = h(k,j) - p * x
  210    continue
!
     j = min (en,k+3)
!    column modification
     do 230 i = l, j
        p = x * h(i,k) + y * h(i,k+1)
        if (.not. notlas) go to 220
        p = p + zz * h(i,k+2)
        h(i,k+2) = h(i,k+2) - p * r
  220       h(i,k+1) = h(i,k+1) - p * q
        h(i,k) = h(i,k) - p
  230    continue
!
  260 continue
!
  go to 70
!    one root found
  270 wr(en) = x + t
  wi(en) = 0.d0
  en = na
  go to 60
!    two roots found
  280 p = (y - x) / 2.d0
  q = p * p + w
  zz = dsqrt(dabs(q))
  x = x + t
  if (q < 0.d0) go to 320
!    real pair
  if (p < 0.d0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.d0) wr(en) = x - w / zz
  wi(na) = 0.d0
  wi(en) = 0.d0
  go to 330
!    complex pair
  320 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  330 en = enm2
  go to 60
!    set error -- no convergence to an
!                eigenvalue after 50 iterations
 1000 ierr = en
 1001 return
end
subroutine dhqr2(nm,n,low,igh,h,wr,wi,z,ierr)

!*******************************************************************************
!
!! DHQR2 finds eigenvalues/vectors of a double precision upper hessenberg matrix
!  by the qr method.  the eigenvectors of a real general matrix can
!     also be found if dorth and dortrn have been used to reduce
!     this general matrix to hessenberg form and to accumulate
!     the similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if dbal has not been used then
!          set low=1, igh=n,
!
!        h contains the upper hessenberg matrix,
!
!        z contains the transformation matrix produced by dortrn
!          after the reduction by dorth, if performed. if the
!          eigenvectors of the hessenberg matrix are desired,
!          z must contain the identity matrix.
!
!     on output-
!
!        h has been destroyed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        z contains the real and imaginary parts of the eigenvectors.
!          if the i-th eigenvalue is real, the i-th column of z
!          contains its eigenvector.  if the i-th eigenvalue is complex
!          with positive imaginary part, the i-th and (i+1)-th
!          columns of z contain the real and imaginary parts of its
!          eigenvector.  the eigenvectors are unnormalized.  if an
!          error exit is made, none of the eigenvectors has been found,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 50 iterations.
!
  integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, &
          igh,its,low,mp2,enm2,ierr
  double precision h(nm,n),wr(n),wi(n),z(nm,n)
  double precision a,b,d,p,q,r,s,t,u,w,x,y
  double precision ra,sa,vi,vr,zz,norm,machep
!     integer min0
!     double precision dsqrt,dabs
  double precision dpmpar
  logical notlas
!
  machep = epsilon ( machep )
  ierr = 0
  norm = 0.d0
  k = 1
!    store roots isolated by dbal
!                and compute matrix norm
  do 50 i = 1, n
!
     do 40 j = k, n
   40    norm = norm + dabs(h(i,j))
!
     k = i
     if (i >= low .and. i <= igh) go to 50
     wr(i) = h(i,i)
     wi(i) = 0.d0
   50 continue
!
  en = igh
  t = 0.d0
!    search for next eigenvalues
   60 if (en < low) go to 340
  its = 0
  na = en - 1
  enm2 = na - 1
!    look for single small sub-diagonal element
!                for l=en step -1 until low do --
   70 do 80 ll = low, en
     l = en + low - ll
     if (l == low) go to 100
     s = dabs(h(l-1,l-1)) + dabs(h(l,l))
     if (s == 0.d0) s = norm
     if (dabs(h(l,l-1)) <= machep * s) go to 100
   80 continue
!    form shift
  100 x = h(en,en)
  if (l == en) go to 270
  y = h(na,na)
  w = h(en,na) * h(na,en)
  if (l == na) go to 280
  if (its == 50) go to 1000
  if (its /= 10 .and. its /= 20 .and. its /= 30) go to 130
!    form exceptional shift
  t = t + x
!
  do 120 i = low, en
  120 h(i,i) = h(i,i) - x
!
  s = dabs(h(en,na)) + dabs(h(na,enm2))
  x = .75d0 * s
  y = x
  w = -.4375d0 * s * s
  130 its = its + 1
!    look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do --
  do 140 mm = l, enm2
     m = enm2 + l - mm
     zz = h(m,m)
     r = x - zz
     s = y - zz
     p = (r * s - w) / h(m+1,m) + h(m,m+1)
     q = h(m+1,m+1) - zz - r - s
     r = h(m+2,m+1)
     s = dabs(p) + dabs(q) + dabs(r)
     p = p / s
     q = q / s
     r = r / s
     if (m == l) go to 150
     if (dabs(h(m,m-1)) * (dabs(q) + dabs(r)) <= machep * dabs(p) &
      * (dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))) go to 150
  140 continue
!
  150 mp2 = m + 2
!
  do 160 i = mp2, en
     h(i,i-2) = 0.d0
     if (i == mp2) go to 160
     h(i,i-3) = 0.d0
  160 continue
!    double qr step involving rows l to en and
!                columns m to en
  do 260 k = m, na
     notlas = k /= na
     if (k == m) go to 170
     p = h(k,k-1)
     q = h(k+1,k-1)
     r = 0.d0
     if (notlas) r = h(k+2,k-1)
     x = dabs(p) + dabs(q) + dabs(r)
     if (x == 0.d0) go to 260
     p = p / x
     q = q / x
     r = r / x
  170    s = dsqrt(p*p + q*q + r*r)
     if (p < 0.d0) s = -s
     if (k == m) go to 180
     h(k,k-1) = -s * x
     go to 190
  180    if (l /= m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
     x = p / s
     y = q / s
     zz = r / s
     q = q / p
     r = r / p
!    row modification
     do 210 j = k, n
        p = h(k,j) + q * h(k+1,j)
        if (.not. notlas) go to 200
        p = p + r * h(k+2,j)
        h(k+2,j) = h(k+2,j) - p * zz
  200       h(k+1,j) = h(k+1,j) - p * y
        h(k,j) = h(k,j) - p * x
  210    continue
!
     j = min (en,k+3)
!    column modification
     do 230 i = 1, j
        p = x * h(i,k) + y * h(i,k+1)
        if (.not. notlas) go to 220
        p = p + zz * h(i,k+2)
        h(i,k+2) = h(i,k+2) - p * r
  220       h(i,k+1) = h(i,k+1) - p * q
        h(i,k) = h(i,k) - p
  230    continue
!    accumulate transformations
     do 250 i = low, igh
        p = x * z(i,k) + y * z(i,k+1)
        if (.not. notlas) go to 240
        p = p + zz * z(i,k+2)
        z(i,k+2) = z(i,k+2) - p * r
  240       z(i,k+1) = z(i,k+1) - p * q
        z(i,k) = z(i,k) - p
  250    continue
!
  260 continue
!
  go to 70
!    one root found
  270 h(en,en) = x + t
  wr(en) = h(en,en)
  wi(en) = 0.d0
  en = na
  go to 60
!    two roots found
  280 p = (y - x) / 2.d0
  q = p * p + w
  zz = dsqrt(dabs(q))
  h(en,en) = x + t
  x = h(en,en)
  h(na,na) = y + t
  if (q < 0.d0) go to 320
!    real pair
  if (p < 0.d0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.d0) wr(en) = x - w / zz
  wi(na) = 0.d0
  wi(en) = 0.d0
  x = h(en,na)
  s = dabs(x) + dabs(zz)
  p = x / s
  q = zz / s
  r = dsqrt(p*p+q*q)
  p = p / r
  q = q / r
!    row modification
  do 290 j = na, n
     zz = h(na,j)
     h(na,j) = q * zz + p * h(en,j)
     h(en,j) = q * h(en,j) - p * zz
  290 continue
!    column modification
  do 300 i = 1, en
     zz = h(i,na)
     h(i,na) = q * zz + p * h(i,en)
     h(i,en) = q * h(i,en) - p * zz
  300 continue
!    accumulate transformations
  do 310 i = low, igh
     zz = z(i,na)
     z(i,na) = q * zz + p * z(i,en)
     z(i,en) = q * z(i,en) - p * zz
  310 continue
!
  go to 330
!    complex pair
  320 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  330 en = enm2
  go to 60
!    all roots found.  backsubstitute to find
!                vectors of upper triangular form
  340 if (norm == 0.d0) go to 1001
!    for en=n step -1 until 1 do --
  do 800 nn = 1, n
     en = n + 1 - nn
     p = wr(en)
     q = wi(en)
     na = en - 1
     if (q) 710, 600, 800
!    real vector
  600    m = en
     h(en,en) = 1.d0
     if (na == 0) go to 800
!    for i=en-1 step -1 until 1 do --
     do 700 ii = 1, na
        i = en - ii
        w = h(i,i) - p
        r = h(i,en)
        if (m > na) go to 620
!
        do 610 j = m, na
  610       r = r + h(i,j) * h(j,en)
!
  620       if (wi(i) >= 0.d0) go to 630
        zz = w
        s = r
        go to 700
  630       m = i
        if (wi(i) /= 0.d0) go to 640
        t = w
        if (w == 0.d0) t = machep * norm
        h(i,en) = -r / t
        go to 700
!    solve real equations
  640       x = h(i,i+1)
        y = h(i+1,i)
        q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i)
        t = (x * s - zz * r) / q
        h(i,en) = t
        if (dabs(x) <= dabs(zz)) go to 650
        h(i+1,en) = (-r - w * t) / x
        go to 700
  650       h(i+1,en) = (-s - y * t) / zz
  700    continue
!    end real vector
     go to 800
!    complex vector
  710    m = na
!    last vector component chosen imaginary so that
!                eigenvector matrix is triangular
     if (dabs(h(en,na)) <= dabs(h(na,en))) go to 720
     h(na,na) = q / h(en,na)
     h(na,en) = -(h(en,en) - p) / h(en,na)
     go to 730
  720    u = h(na,na) - p
     b = -h(na,en) / (u * u + q * q)
     h(na,na) = b * q
     h(na,en) = b * u
  730    h(en,na) = 0.d0
     h(en,en) = 1.d0
     enm2 = na - 1
     if (enm2 == 0) go to 800
!    for i=en-2 step -1 until 1 do --
     do 790 ii = 1, enm2
        i = na - ii
        w = h(i,i) - p
        ra = 0.d0
        sa = h(i,en)
!
        do 760 j = m, na
           ra = ra + h(i,j) * h(j,na)
           sa = sa + h(i,j) * h(j,en)
  760       continue
!
        if (wi(i) >= 0.d0) go to 770
        zz = w
        r = ra
        s = sa
        go to 790
  770       m = i
        if (wi(i) /= 0.d0) go to 780
        d = w * w + q * q
        h(i,na) = -(ra * w + sa * q) / d
        h(i,en) = (ra * q - sa * w) / d
        go to 790
!    solve complex equations
  780       x = h(i,i+1)
        y = h(i+1,i)
        vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q
        vi = (wr(i) - p) * 2.d0 * q
        if (vr == 0.d0 .and. vi == 0.d0) vr = machep * norm &
         * (dabs(w) + dabs(q) + dabs(x) + dabs(y) + dabs(zz))
        a = x * r - zz * ra + q * sa
        b = x * s - zz * sa - q * ra
        d = vr * vr + vi * vi
        h(i,na) = (a * vr + b * vi) / d
        h(i,en) = (b * vr - a * vi) / d
        if (dabs(x) <= dabs(zz) + dabs(q)) go to 785
        h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x
        h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x
        go to 790
  785       a = -r - y * h(i,na)
        b = -s - y * h(i,en)
        d = zz * zz + q * q
        h(i+1,na) = (a * zz + b * q) / d
        h(i+1,en) = (b * zz - a * q) / d
  790    continue
!    end complex vector
  800 continue
!    end back substitution.
!                vectors of isolated roots
  do 840 i = 1, n
     if (i >= low .and. i <= igh) go to 840

     do 820 j = i, n
  820    z(i,j) = h(i,j)
!
  840 continue
!    multiply by transformation matrix to give
!                vectors of original full matrix.
!                for j=n step -1 until low do --
  do 880 jj = low, n
     j = n + low - jj
     m = min (j,igh)
!
     do 880 i = low, igh
        zz = 0.d0
!
        do 860 k = low, m
  860       zz = zz + z(i,k) * h(k,j)
!
        z(i,j) = zz
  880 continue
!
  go to 1001
!    set error -- no convergence to an
!                eigenvalue after 50 iterations
 1000 ierr = en
 1001 return
end
function dilogarithm ( x )
!
!*******************************************************************************
!
!! DILOGARITHM evaluates the dilogarithm function.
!
!
!  Discussion:
!
!    The dilogarithm is defined as
!
!      F(X) = - Integral ( 1 <= T <= X ) ln ( T ) / ( T - 1 ) dt
!
!    The dilogarithm is also known as Spence's integral for N = 2.
!
!  Author:
!
!    Alfred Morris,
!    Naval Surface Weapons Center,
!    Dahlgren, Virginia
!
!  Parameters:
!
!    Input, real X, the argument of the function.
!
!    Output, real DILOGARITHM, the value of the function.
!
  real a(5)
  real b(6)
  real c(10)
  real, parameter :: const = 1.64493406684823E+00
  real d(2)
  real dilogarithm
  real e(18)
  real p(4)
  real q(8)
  real r(7)
  real s(6)
  real t
  real w
  real x
  double precision, parameter :: x0 = -12.5951703698450161286398965D+00
  real x2
!
  data a(1)/.217590467528373e+01/, a(2)/.165569610692639e+01/, &
       a(3)/.522944061702389e+00/, a(4)/.626073688152965e-01/, &
       a(5)/.187280204672313e-02/
  data b(1)/.242590467528371e+01/, b(2)/.215106116463796e+01/, &
       b(3)/.853664388896516e+00/, b(4)/.148635712775060e+00/, &
       b(5)/.936304016023909e-02/, b(6)/.115362459229893e-03/
!
  data c(1)/-.139792925233661e+01/, c(2) /.368504569727477e+00/, &
       c(3) /.467406917183686e-01/, c(4) /.113795257294490e-01/, &
       c(5) /.369638462505741e-02/, c(6) /.140888669464352e-02/, &
       c(7) /.580505641503297e-03/, c(8) /.279065584075104e-03/, &
       c(9) /.727678355839120e-04/, c(10)/.941452067850052e-04/
  data d(1)/-.164792925233634e+01/, d(2) /.669375771675355e+00/
!
  data e(1)/-.194565741631859e+00/, e(2)/-.430017756528812e-02/, &
       e(3)/-.129188263110634e-03/, e(4)/-.344864872694838e-05/, &
       e(5) /.566899694553089e-09/, e(6) /.126641834906132e-07/, &
       e(7) /.163966793864421e-08/, e(8) /.164221074630109e-09/, &
       e(9) /.149644905021032e-10/, e(10)/.130214292886747e-11/, &
       e(11)/.110415518123737e-12/, e(12)/.921674760163207e-14/, &
       e(13)/.761646464974859e-15/, e(14)/.625216733700975e-16/, &
       e(15)/.510910937990370e-17/, e(16)/.416215390793180e-18/, &
       e(17)/.338357379188308e-19/, e(18)/.274674744366340e-20/
!
  data p(1)/-.124827318209942e+01/, p(2)/-.593706951284264e-01/, &
       p(3)/ .368603360394688e-01/, p(4)/ .243497524184253e-02/
  data q(1)/ .100000000000000e+01/, q(2)/ .252618047164349e+00/, &
       q(3)/ .171618729068655e-01/, q(4)/ .234444792844727e-03/, &
       q(5)/-.174928841869743e-05/, q(6)/ .347369010951250e-07/, &
       q(7)/-.713275908929482e-09/, q(8)/ .958397514026421e-11/
!
  data r(1)/.265189940015693e+00/, r(2)/.230201018075415e+00/, &
       r(3)/.315999623504943e-01/, r(4)/.154066621939470e-02/, &
       r(5)/.286697611038892e-04/, r(6)/.163031291368652e-06/, &
       r(7)/.838957807732251e-10/
  data s(1)/.100000000000000e+01/, s(2)/.177195068872258e+00/, &
       s(3)/.110559275223905e-01/, s(4)/.291916852717175e-03/, &
       s(5)/.304793254397420e-05/, s(6)/.882114921507386e-08/
!
  x2 = x - 1.0E+00
!
!  x < -26.63
!
  if ( x2 < -26.63E+00 ) then

    t = -1.0E+00 / x2

    w = (((((((((((c(10)*t + c(9))*t + c(8))*t + c(7))*t + c(6))*t + &
                 c(5))*t + c(4))*t + c(3))*t + c(2))*t + c(1))*t + &
                 0.5E+00 ) + 0.5E+00 ) / ((d(2)*t + d(1))*t + 1.0E+00 )

    dilogarithm = 0.5E+00 * log( -x2 )**2 - ( 2.0E+00 * const + w / x2 )
!
!  -26.63 <= x <= -14
!
  else if ( x2 <= -14.0E+00 ) then

    t = - ( x2 + 14.0E+00 )

    dilogarithm = ((((((r(7)*t + r(6))*t + r(5))*t + r(4))*t + r(3))*t + &
              r(2))*t + r(1)) / (((((s(6)*t + s(5))*t + &
              s(4))*t + s(3))*t + s(2))*t + s(1))
!
!  -14 < x <= -11.1
!
  else if ( x2 <= - 11.1E+00 ) then

    t = dble ( x2 ) - x0
    w = e(14)
    do l = 1, 13
      i = 14 - l
      w = w * t + e(i)
    end do

    dilogarithm = t * w
!
!  -11.1 < x <= -6.97
!
  else if ( x2 <= -6.97E+00 ) then

    t = - ( x2 + 7.0E+00 )

    dilogarithm = (((p(4)*t + p(3))*t + p(2))*t + p(1)) / (((((((q(8)*t + &
           q(7))*t + q(6))*t + q(5))*t + q(4))*t + q(3))*t + &
           q(2))*t + q(1))
!
!  -6.97 < x < 2
!
  else if ( x2 < -2.0E+00 ) then

    t = -1.0E+00 / x2

    w = (((((((((((c(10)*t + c(9))*t + c(8))*t + c(7))*t + c(6))*t + &
                 c(5))*t + c(4))*t + c(3))*t + c(2))*t + c(1))*t + &
                 0.5E+00 ) + 0.5E+00 ) / ((d(2)*t + d(1))*t + 1.0E+00 )

    dilogarithm = 0.5E+00 * log ( -x2 )**2 - ( 2.0E+00 * const + w / x2 )
!
!  -2 <= x < -1
!
  else if ( x2 < -1.0E+00 ) then

    t = - ( 1.0E+00 + x2 )

    w = (((((a(5)*t + a(4))*t + a(3))*t + a(2))*t + a(1))*t + 1.0E+00 )/ &
      ((((((b(6)*t + b(5))*t + b(4))*t + b(3))*t + b(2))*t + &
            b(1))*t + 1.0E+00 )

    dilogarithm = - ( const + t * w ) + log ( -x2 ) * log ( t )
!
!  -1 <= x < -1/2
!
  else if ( x2 < -0.5E+00 ) then

    t = 0.5E+00 + ( 0.5E+00 + x2 )

    dilogarithm = -const

    if ( t == 0.0E+00 ) then
      dilogarithm = - dilogarithm
      return
    end if

    w = (((((((((((c(10)*t + c(9))*t + c(8))*t + c(7))*t + c(6))*t + &
                 c(5))*t + c(4))*t + c(3))*t + c(2))*t + c(1))*t + &
                 0.5E+00 ) + 0.5E+00 ) / ((d(2)*t + d(1))*t + 1.0E+00 )

    dilogarithm = ( -const + t * w ) + log ( - x2 ) * log ( t )

!
!  -1/2 <= x < 0
!
  else if ( x2 < 0.0E+00 ) then

    t = -x2

    w = (((((((((((c(10)*t + c(9))*t + c(8))*t + c(7))*t + c(6))*t + &
                 c(5))*t + c(4))*t + c(3))*t + c(2))*t + c(1))*t + &
                 0.5E+00 ) + 0.5E+00 ) / ((d(2)*t + d(1))*t + 1.0E+00 )

    dilogarithm = x2 * w
!
!  0 <= x <= 1
!
  else if ( x2 <= 1.0E+00 ) then

    w = (((((a(5)*x2 + a(4))*x2 + a(3))*x2 + a(2))*x2 + a(1))*x2 + 1.0E+00 )/ &
      ((((((b(6)*x2 + b(5))*x2 + b(4))*x2 + b(3))*x2 + b(2))*x2 + &
            b(1))*x2 + 1.0E+00 )

    dilogarithm = x2 * w
!
!  1 < x
!
  else

    t = 1.0E+00 / x2

    w = (((((a(5)*t + a(4))*t + a(3))*t + a(2))*t + a(1))*t + 1.0E+00 )/ &
      ((((((b(6)*t + b(5))*t + b(4))*t + b(3))*t + b(2))*t + &
            b(1))*t + 1.0E+00 )

    dilogarithm = ( const - w / x2 ) + 0.5E+00 * log ( x2 )**2

  end if

  dilogarithm = - dilogarithm

  return
end
subroutine dilogarithm_values ( n, x, fx )

!*****************************************************************************80
!
!! DILOGARITHM_VALUES returns some values of dilogarithm function for testing.
!
!  Discussion:
!
!    The dilogarithm is defined as
!
!      ALI(X) = - Integral ( 1 <= T <= X ) ln ( T ) / ( T - 1 ) dt
!
!    The dilogarithm is also known as Spence's integral for N = 2.
!
!  Modified:
!
!    19 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 11
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    1.644934067E+00, 1.440633797E+00, 1.299714723E+00, 1.180581124E+00, &
    1.074794600E+00, 0.978469393E+00, 0.889377624E+00, 0.806082689E+00, &
    0.727586308E+00, 0.653157631E+00, 0.582240526E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.00E+00,  0.05E+00,  0.10E+00,  0.15E+00, &
    0.20E+00,  0.25E+00,  0.30E+00,  0.35E+00, &
    0.40E+00,  0.45E+00,  0.50E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine dincdg(degree,alpha,psi,indexs,newkj, &
                    sumsqs,coord,ncrows,npolys, &
                    dimen,npts,f,z,c,psiwid,weight, &
                    alfl,onplys,sttdeg,error)
!
!*******************************************************************************
!
!! DINCDG is a utility routine used by dgnrtp.
!
!
!     the multinomial fit is generated incrementally, a basis  element
!     at a time.  this subroutine continues the process started off by
!      dgnrtp .
!
!     this subroutine is called by  dgnrtp  and not by the user.
!
!
!     modified by a.h. morris (nswc)
!
  integer jprime,p,j,curdeg,kj,kjp,l,jpm1,jm1
  integer m,start,jindex,jpindx,q,j3,j1,j1mj2,error
  integer j0mj1,j1m1,starta,onplys,onpp1,sttdeg,index1,index2
  integer degree,npolys,npts,dimen,psiwid,alfl
  integer indexs(4,npolys),newkj(dimen,degree)
  double precision alpha(alfl),coord(ncrows,dimen),psi(npts,psiwid)
  double precision sumsqs(npolys),c(npolys),f(npts),weight(npts)
  double precision z(npts)
  double precision arc,runtot,rntot1,rntot2
!
!    ******
!
  if ( onplys >= 1 .and. sttdeg >= 1 ) go to 10
     error = 6
  return
 10      if ( indexs(2,onplys) == dimen ) go to 20
        curdeg = sttdeg
     go to 30
 20         curdeg = sttdeg + 1
 30   onpp1 = onplys + 1
  do 170 j = onpp1,npolys
     jprime = indexs(1,j)
     jindex = j - ((j - 1) / psiwid) * psiwid
     jpindx = jprime - ((jprime - 1) / psiwid) * psiwid
     kj = indexs(2,j)
     start = indexs(3,j)
     m = start
     starta = indexs(4,j) - start
     if ( curdeg == 1 ) go to 100
     kjp = indexs(2,jprime)
     j1 = newkj(kj,curdeg - 1)
!
!     calculate those  alpha ( j , m ) that can be calculated from
!     previously calculated alphas.
!
     if ( kj < kjp ) go to 50
!
!     first calculate those between  jpp  and the end of 2 rows back.
!     calculate  alpha ( j , jpp )
!
     index1 = indexs(4,j)
     alpha(index1) = sumsqs(jprime) / sumsqs(start)
!
     m = start + 1
     j3 = newkj(1,curdeg - 1) - 1
     if ( m > j3 ) go to 50
!
!     curdeg > 2 if control has passed the branches in the 3-rd
!     previous and 8-th previous statements.
!
        j1mj2 = j1 - newkj(kj,curdeg - 2)
!
        do 40 l = m,j3
           q = j1mj2 + l
           index1 = starta + l
           index2 = indexs(4,q) - indexs(3,q) + jprime
 40            alpha(index1) = alpha(index2) * sumsqs(jprime) / &
           sumsqs(l)
!
!     calculate  alpha ( j , m ) for  m  between the 2
!     ranges calculated before using
!
!        alpha ( j , l ) = (x  *  psi  ,psi )  / (psi ,psi )
!                             k      jp    l         l    l
!                              j
!
     m = j3 + 1
 50      if ( jprime == j1 ) go to 100
        if ( kj == 1 ) go to 80
        j1m1 = j1 - 1
        do 70 l = m,j1m1
           runtot = 0.d0
           do 60 p = 1,npts
              index1 = l - ((l - 1) / psiwid) * psiwid
 60               runtot = runtot + coord(p,kj) * psi(p,jpindx) * &
              psi(p,index1) * weight(p)
           index1 = starta + l
 70            alpha(index1) = runtot / sumsqs(l)
!
!    *****
!     calculate  alpha ( j , m ) for  m  between
!      newkj ( kj , curdeg  - 1)  and
!      jp  - 1.
!    *****
!
 80         j0mj1 = newkj(kj,curdeg) - j1
        jpm1 = jprime - 1
        do 90 l = j1,jpm1
           q = j0mj1 + l
           index1 = starta + l
           index2 = indexs(4,q) - indexs(3,q) + jprime
 90            alpha(index1) = alpha(index2) * sumsqs(jprime) / &
           sumsqs(l)
        m = jprime
!
!    *****
!     calculate the remaining  alpha ( j , m ) from
!
!      alpha ( j , l ) = (x   * psi  ,psi ) / (psi ,psi )
!                          k       jp    l        l    l
!                           j
!    *****
!
 100     jm1 = j - 1
     do 120 l = m,jm1
        runtot = 0.d0
        do 110 p = 1,npts
           index1 = l - ((l - 1) / psiwid) * psiwid
 110           runtot = runtot + coord(p,kj) * psi(p,jpindx) * &
           psi(p,index1) * weight(p)
        index1 = starta + l
 120        alpha(index1) = runtot / sumsqs(l)
!
!    *****
!     now calculate the  psi (p,j),  sumsqs (j) and  c (j) using
!
!                          j-1
!     psi  = x  * psi   -  sum   alpha(j,l) * psi
!        j    k      jp    l=jpp                 l
!
!     sumsqs  = (psi ,psi )
!           j       j    j
!
!     c  = (z,psi )
!      j         j
!    *****
!
 130      jm1 = j - 1
      arc = 0.d0
      rntot1 = 0.d0
      rntot2 = 0.d0
      do 150 p = 1,npts
          runtot = coord(p,kj) * psi(p,jpindx)
          do 140 l = start,jm1
             index1 = starta + l
             index2 = l - ((l - 1) / psiwid) * psiwid
 140             runtot = runtot - alpha(index1) * psi(p,index2)
          psi(p,jindex) = runtot
          arc = arc + psi(p,index2) * psi(p,jindex) * &
                            weight(p)
          rntot1 = rntot1 + psi(p,jindex) * psi(p,jindex) * &
                            weight(p)
 150          rntot2 = rntot2 + z(p) * psi(p,jindex) * weight(p)
      if (arc * arc >= sumsqs(jm1) * rntot1 * 1.d-06) &
          go to 200
      sumsqs(j) = rntot1
      c(j) = rntot2 / rntot1
!
!    *****
!     calculate the new  z ( p ) and the new  ssres  using
!
!     z = z - c  * psi
!              j      j
!    *****
!
      do 160 p = 1,npts
 160          z(p) = z(p) - c(j) * psi(p,jindex)
      sttdeg = curdeg
 170      if ( kj == dimen ) curdeg = curdeg + 1
  return
!
!    *****
!     the j-th basis multinomial cannot be computed accurately.
!     only j - 1 basis multinomials are generated.
!    *****
!
 200  error = -1
  degree = sttdeg
  npolys = jm1
  return
end
subroutine disort (a, m, n)

!*******************************************************************************
!
!! DISORT uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. the same permutations are
!     performed on m that are performed on a. it is assumed that n >= 1.
!
  double precision a(n), s
  integer m(n), t
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do i = 3,10
    if (n <= k(i)) then
      exit
    end if
    imax = imax + 1
  end do
!
!            stepping through the increments k(imax),...,k(1)
!
  i = imax

  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 32 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
        t = m(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           m(ll) = m(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31       a(ll) = s
        m(ll) = t
   32    continue
!
   40 i = i - 1
  return
end
subroutine dkprod(a,ka,m,n,b,kb,k,l,c,kc)
!
!*******************************************************************************
!
!! DKPROD: kronecker product of double precision matrices a and b
!
  double precision a(ka,n),b(kb,l),c(kc,*)
  integer r,s
!
  j = 0
  do 40 s = 1,n
     do 30 jj = 1,l
     j = j + 1
!
!        compute the j-th column of c
!
        i = 0
        do r = 1,m
           do ii = 1,k
             i = i + 1
             c(i,j) = a(r,s)*b(ii,jj)
           end do
        end do

   30    continue
   40 continue
  return
end
function dlgdiv (a, b)
!
!*******************************************************************************
!
!! DLGDIV: computation of ln(gamma(b)/gamma(a+b)) for b >= 10
!
!
!
!     dlgdiv uses a series for the function del(x) where
!     ln(gamma(x)) = (x - 0.5)*ln(x) - x + 0.5*ln(2*pi) + del(x).
!     the series for del(x), which applies for x >= 10, was
!     derived by a.h. morris from the chebyshev series in the
!     slatec library obtained by wayne fullerton (los alamos).
!
  double precision dlgdiv
  double precision a, b
  double precision c, d, e(15), h, s(15), t, u, v, w, x, x2
  double precision dlnrel
!
  data e(1)  / .833333333333333333333333333333d-01/, &
       e(2)  /-.277777777777777777777777752282d-04/, &
       e(3)  / .793650793650793650791732130419d-07/, &
       e(4)  /-.595238095238095232389839236182d-09/, &
       e(5)  / .841750841750832853294451671990d-11/, &
       e(6)  /-.191752691751854612334149171243d-12/, &
       e(7)  / .641025640510325475730918472625d-14/, &
       e(8)  /-.295506514125338232839867823991d-15/, &
       e(9)  / .179643716359402238723287696452d-16/, &
       e(10) /-.139228964661627791231203060395d-17/
  data e(11) / .133802855014020915603275339093d-18/, &
       e(12) /-.154246009867966094273710216533d-19/, &
       e(13) / .197701992980957427278370133333d-20/, &
       e(14) /-.234065664793997056856992426667d-21/, &
       e(15) / .171348014966398575409015466667d-22/
!
  if (a <= b) go to 10
     h = b/a
     c = 1.d0/(1.d0 + h)
     x = h/(1.d0 + h)
     d = a + (b - 0.5d0)
     go to 20
   10 h = a/b
  c = h/(1.d0 + h)
  x = 1.d0/(1.d0 + h)
  d = b + (a - 0.5d0)
!
!        compute (1 - x**n)/(1 - x) for n = 1,3,5,...
!            store these values in s(1),s(2),...
!
   20 x2 = x*x
  s(1) = 1.d0
  do 21 j = 1,14
     s(j + 1) = 1.d0 + (x + x2*s(j))
   21 continue
!
!                set w = del(b) - del(a + b)
!
  t = (10.d0/b)**2
  w = e(15)*s(15)
  do 30 j = 1,14
     k = 15 - j
     w = t*w + e(k)*s(k)
   30 continue
  w = w*(c/b)
!
!                    combine the results
!
  u = d*dlnrel(a/b)
  v = a*(dlog(b) - 1.d0)
  if (u <= v) go to 40
     dlgdiv = (w - v) - u
     return
   40 dlgdiv = (w - u) - v
  return
end
subroutine dllsq(m,n,a,ka,b,kb,nb,wk,iwk,ierr)
!
!*******************************************************************************
!
!! DLLSQ: ???
!
  double precision a(ka,n),b(kb,nb),wk(n)
  integer iwk(n)
  double precision rnorm
  logical exit
!
  ierr = 0
  if (1 < n .and. n <= m) go to 10
  ierr = 1
  return
!
   10 np1 = n + 1
  call dortho(m,n,a,ka,wk,iwk,exit)
  if (exit) go to 20
  ierr = 2
  return
!
   20 do 22 j = 1,nb
  call dorsol(m,n,a,ka,wk,iwk,b(1,j))
  if (m == n) go to 22
  rnorm = 0.d0
     do 21 i = np1,m
   21    rnorm = rnorm + b(i,j)*b(i,j)
  b(np1,j) = dsqrt(rnorm)
   22 continue
  return
end
function dlnrel (a)
!
!*******************************************************************************
!
!! DLNREL: evaluation of the function ln(1 + a)
!
  double precision dlnrel
  double precision a, eps, c, t, t2, w, z
  double precision dpmpar
!
!
!     ****** eps is a machine dependent constant. eps is the
!            smallest number such that 1.d0 + eps > 1.d0
!
                  eps = epsilon ( eps )
!
!
  if (a > -0.5d0 .and. a < 0.4d0) go to 10
     t = 1.d0 + a
     if (a < 0.d0) t = 0.5d0 + (0.5d0 + a)
     dlnrel = dlog(t)
     return
!
   10 t = a/(a + 2.d0)
  t2 = t*t
  n = 5
  z = t2
  w = 0.d0
   20    c = z/n
     if (c < eps) go to 30
     w = w + c
     n = n + 2
     z = t2*z
     go to 20
   30 w = 1.d0/3.d0 + w
  dlnrel = 2.d0*t*(1.d0 + t2*w)
  return
end
function dloc (x, y)
!
!*******************************************************************************
!
!! DLOC determines if two double precision arrays begin at the same location.
!
!
!     x and y are arrays. it is assumed that x(1) and y(1) contain data.
!
!     dloc(x,y) = .true.   if x and y begin in the same location
!     dloc(x,y) = .false.  if x and y begin in different locations
!
!     it is recommended that this coding not be optimized by eliminating
!     the subroutine dychg. if it is optimized then dloc may not compile
!     properly.
!
  logical dloc 
  double precision x(*), y(*), xold, yold
!
  xold = x(1)
  yold = y(1)
  call dychg(x,y,yold)
  if (x(1) == xold) go to 10
!
!     x and y begin in the same location
!
  y(1) = yold
  dloc = .true.
  return
!
!     x and y begin in different locations
!
   10 y(1) = yold
  dloc = .false.
  return
end
subroutine dmadd (m, n, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! DMADD: addition of double precision matrices
!
  double precision a(ka,n), b(kb,n), c(kc,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
        c(i,j) = a(i,j) + b(i,j)
   10    continue
   20 continue
  return
end
subroutine dmcopy(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! DMCOPY copies a double precision array.
!
  double precision a(ka,n),b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = a(i,j)
   20 continue
  return
end
subroutine dmcvfs(a,ka,n,b)
!
!*******************************************************************************
!
!! DMCVFS: ???
!
  double precision a(ka,n),b(*)
!
  l = 0
  do 20 j = 1,n
     do 10 i = 1,j
     l = l + 1
   10    b(l) = a(i,j)
   20 continue
  return
end
subroutine dmcvsf(a,ka,n,b)
!
!*******************************************************************************
!
!! DMCVSF: ???
!
  double precision a(ka,n),b(*)
!
  a(1,1) = b(1)
  if (n < 2) return
  l = (n*(n + 1))/2
!
  j = n
  do 11 jj = 2,n
  i = j
     do 10 ii = 1,j
     a(i,j) = b(l)
     i = i - 1
   10    l = l - 1
   11 j = j - 1
!
  do 21 i = 2,n
  im1 = i - 1
     do 20 j = 1,im1
   20    a(i,j) = a(j,i)
   21 continue
  return
end
subroutine dmeval(dimen,evldeg,nepols,nepts,evlcds,nerows,evlvls, &
                    error,fitiwk,fitdwk,fiwkln,fdwkln,temp)
!
!*******************************************************************************
!
!! DMEVAL evaluates the least-squares multinomial fit produced by dmfit.
!
!
!  the computation
!     is performed in double precision. either the full
!     multinomial as produced may be evaluated,  or  only  an  initial
!     segment thereof.  as in the case with  dmfit , it is possible
!     (1) to specify multinomials of a full given degree, or
!     (2) to specify  the  number  of  orthogonal  basis  elements  to
!         achieve a partial-degree fit.
!
!     in case (1), the  desired  degree  is  given  as  the  value  of
!     evldeg   (which  must  be  nonnegative and not greater than the
!     value used for  fitdeg  in  dmfit ), and the parameter  nepols
!     will be set  by  dmeval  to specify the number of basis elements
!     required. if  evldeg  <  fitdeg   is  given,  then  only  the
!     initial  portion of the fitting multinomial (of degree  evldeg )
!     will be evaluated.
!
!     in case (2),  evldeg  is to be set negative, in which  case  the
!     value  of   nepols  (which must be positive and not greater than
!     the value used for   nfpols   in   dmfit )  will  be  taken  as
!     defining  the  initial  portion of the fitting multinomial to be
!     evaluated.
!
!     if  nepols  =  nfpols  (with  evldeg  <  0),  or   evldeg   =
!     fitdeg  (with   evldeg   >  0),  then  the  full  multinomial
!     generated by  dmfit  will be evaluated.
!
!     the  evaluation  will  take  place  for  each  of   the   points
!     (collection  of  variable  values)  given as a row of the matrix
!      evlcds .  the  values  produced  from  the  full,  or  partial,
!     multinomial will be placed in the array  evlvls .
!
!     variables
!
!
!      dimen  -- (integer) -- (passed)
!         the number of variables.
!      evldeg  -- (integer) -- (passed)
!         if  evldeg  < 0, then this parameter will be ignored.
!         if  evldeg  >= 0, then the value of  evldeg  must  satisfy
!         evldeg  <= (the  degree  of the approximating multinomial
!         generated in  dmfit ).  in this case  evldeg  will  specify
!         the degree of the initial portion of the fitting multinomial
!         to be evaluated.
!      nepols  -- (integer) -- (passed/returned)
!         if  evldeg  >= 0, then this parameter will be ignored.
!         if evldeg < 0, then the partial multinomial involving the
!         first   nepols  orthogonal basis functions will be evaluated
!         at the points given by  evlcds .  the resulting values  will
!         be stored in  evlvls .
!         the value of nepols must be >= 1 and <= (the size of the
!         basis  generated  in   dmfit ),  which  was returned as the
!         value of  nfpols .
!         nepols  will be changed if evldeg > 0 to give the size of
!         basis required for the multinomial of degree  evldeg .
!      nepts  -- (integer) -- (passed)
!         the number of evaluation points.
!      evlcds  -- (double precision 2-subscript array) -- (passed)
!         evlcds (p,k) is the value of the k-th variable at the  p-th
!         evaluation point.
!      nerows  -- (integer) -- (passed)
!         the row dimension declared for evlcds in the calling program.
!      evlvls  -- (integer) -- (returned)
!         evlvls (p) is the value of the evaluated multinomial at the
!         p-th evaluation point.
!      error  -- (integer) -- (returned)
!          0.......  if no errors
!         -1.......  if  nepols  >  nfpols  or  nepols  < 1
!         -2.......  if  nepts  < 1 or  dimen   <  1
!      fitiwk  -- (integer, 1-subscript array) -- (passed)
!         the integer work array of length  fiwkln  that was  used  in
!          dmfit .
!      fitdwk  -- (double precision 2-subscript array) -- (passed)
!         the real work array of length  fdwkln  that was
!         used in  dmfit .
!      fiwkln  -- (integer) -- (passed)
!         the length of  fitiwk .
!      fdwkln  -- (integer) -- (passed)
!         the length of  fitdwk .
!      temp    -- (double precision 1-subscript array)
!         a work array of length  dimen  (or longer).
!
!     the subroutine  dmevl1  is called to do the actual evaluation.
!
!     modified by a.h. morris (nswc)
!
  integer fiwkln,fdwkln,nepols,nepts,dimen,error,maxstt,alfstt,cstt
  integer gbasiz,alfl,dimp1,evldeg,top,bot,curdeg,psistt
  integer fitiwk(fiwkln)
  double precision fitdwk(fdwkln),evlcds(nerows,dimen)
  double precision evlvls(nepts),temp(dimen)
!
!    *****
!     set up index pointers to the beginning of each row of
!     the mtable -- this sets the beginning point for each
!     full multinomial degree.
!    *****
!
  if (nepts < 1 .or. dimen  <  1) go to 110
  if (evldeg) 40,10,20
!
   10 nepols = 1
  go to 50
!
   20 top = 1
  bot = 1
  do 30 curdeg = 1,evldeg
     top = top * (dimen + curdeg)
   30    bot = bot * curdeg
  nepols = top / bot
!
   40 gbasiz = fitiwk(1)
  if (nepols > gbasiz .or. nepols < 1) go to 100
!
   50 error = 0
  dimp1 = dimen + 1
  alfl = fitiwk(4)
  maxstt = 1
  alfstt = dimp1 + maxstt
  cstt = alfstt + alfl
  psistt = cstt + fitiwk(2)
!
!     the actual evaluation is done inside  dmevl1.
!
  call dmevl1 (evlcds,nerows,fitdwk(cstt),nepts,dimen,nepols, &
               fitdwk(alfstt),fitiwk,fitdwk(psistt), &
               evlvls,alfl,fitdwk(maxstt),temp,dimp1)
  return
!
!     error return
!
  100 error = -1
  return
  110 error = -2
  return
end
subroutine dmevl1 (coord,ncrows,c,nepts,dimen,npolys,alpha, &
                     indexs,psi,f,alfl,maxabs,x,dimp1)
!
!*******************************************************************************
!
!! DMEVL1 performs the main work of evaluating the fitting multinomial
!  (or the initial portion of it  which
!     is requested by the setting of  nepols ,  evldeg  in the
!     call to subroutine  dmeval .
!
!     this subroutine is called by  dmeval .  it is  not  called
!     directly by the user.
!
!     the body of this subroutine follows the explanation
!     given in
!          least squares fitting using
!          orthogonal multinomials
!     by
!          bartels and jezioranski
!     in
!          acm transactions on mathematical software
!
!
!     modified by a.h. morris (nswc)
!
  integer dimen,nepts,npolys,alfl,dimp1
  integer jm1,jprime,m,p,k,i,j,index
  integer indexs(4,npolys)
  double precision alpha(alfl),coord(ncrows,dimen),psi(npolys)
  double precision c(npolys),f(nepts),maxabs(dimp1),x(dimen)
  double precision runtot,rntot1
!
!    ******
!
  if (npolys == 1) go to 50
!
  psi(1) = 1.d0
  do 40 p = 1,nepts
!
!     scale the coordinates of the p-th point
!    *****
!
     do 10 k = 1,dimen
          x(k) = coord(p,k)
          if (maxabs(k) /= 0.d0) x(k) = x(k) / maxabs(k)
 10      continue
!
!    *****
!     use the  basis function coefficients  c  and recurrence
!     coefficients  alpha  to evaluate the fitted multinomial
!     at the p-th point.
!    *****
!
     rntot1 = c(1)
     do 30 j = 2,npolys
          k = indexs(2,j)
          jprime = indexs(1,j)
          runtot = x(k) * psi(jprime)
          i = indexs(3,j)
          jm1 = j - 1
          do 20 m = i,jm1
             index = indexs(4,j) + m - i
 20              runtot = runtot - psi(m) * alpha(index)
          psi(j) = runtot
 30           rntot1 = rntot1 + c(j) * psi(j)
 40       f(p) = rntot1 * maxabs(dimp1)
  return
!
!    *****
!     compute the degree 0 polynomial
!    *****
!
 50   runtot = c(1) * maxabs(dimp1)
  do 60 p = 1,nepts
 60      f(p) = runtot
  return
end
subroutine dmexp (a, ka, n, z, kz, wk, ierr)
!
!*******************************************************************************
!
!! DMEXP computes the matrix exponential.
!
!
!     wk is an array of dimension (n,n+12). wk is a work space
!     for the routine.
!
!     ierr is a variable that reports the status of the results.
!        ierr = 0  exp(a) was successfully computed.
!        ierr = 1  the norm of a is too large.
!        ierr = 2  the pade denominator matrix is
!                  singular.
!
!     written by alfred h. morris
!        Naval Surface Weapons Center,
!        dahlgren virginia
!
  double precision a(ka,n),z(kz,n),wk(n,*)
  double precision anorm,anorm1,c(12),factor,p,q,s,s1
!
!     coefficients for (12,12) pade table entry
!
  data c(1) /.500000000000000000000000000000d+00/, &
       c(2) /.119565217391304347826086956522d+00/, &
       c(3) /.181159420289855072463768115942d-01/, &
       c(4) /.194099378881987577639751552795d-02/, &
       c(5) /.155279503105590062111801242236d-03/, &
       c(6) /.953470633104500381388253241800d-05/, &
       c(7) /.454033634811666848280120591333d-06/, &
       c(8) /.166924130445465753044161982108d-07/, &
       c(9) /.463678140126293758456005505855d-09/
  data c(10)/.927356280252587516912011011710d-11/, &
       c(11)/.120435880552284093105455975547d-12/, &
       c(12)/.772024875335154442983692150941d-15/
!
  ierr = 0
  if (n > 1) go to 10
     z(1,1) = dexp(a(1,1))
     return
!
!       balance a and select the smaller of the 1-norm
!              and infinity-norm of the result
!
   10 call dbal (ka,n,a,low,igh,wk(1,n+12))
  anorm = 0.d0
  anorm1 = 0.d0
  do 12 j = 1,n
  s = 0.d0
  s1 = 0.d0
     do 11 i = 1,n
     s = s + dabs(a(j,i))
   11    s1 = s1 + dabs(a(i,j))
  anorm = dmax1(s,anorm)
   12 anorm1 = dmax1(s1,anorm1)
!
  anorm = dmin1(anorm,anorm1)
  s = anorm + 0.1d0
  if (s == anorm) go to 200
!
!              select the normalization factor
!
  m = 0
  if (anorm <= 1.d0)  go to 40
  factor = 1.d0
   20 m = m + 1
  factor = 2.d0*factor
  if (anorm > factor) go to 20
!
!                normalize the matrix a
!
  do 31 j = 1,n
     do 30 i = 1,n
   30    a(i,j) = a(i,j)/factor
   31 continue
!
   40 np1 = n + 1
  np10 = n + 10
  do 100 j = 1,n
!
!     compute the j-th column of the first 12 powers of a
!
     do 51 i = 1,n
     s = 0.d0
        do 50 l = 1,n
   50       s = s + a(i,l)*a(l,j)
   51    wk(i,np1) = s
!
     do 70 k = np1,np10
     kp1 = k + 1
        do 61 i = 1,n
        s = 0.d0
           do 60 l = 1,n
   60          s = s + a(i,l)*wk(l,k)
   61       wk(i,kp1) = s
   70    continue
!
!     compute the j-th column of the numerator and denominator
!                  of the pade approximation
!
     do 90 i = 1,n
     p = 0.d0
     q = 0.d0
     k = 12
     l = n + 11
        do 80 ll = 1,11
        s = c(k)*wk(i,l)
        p = s + p
        q = s - q
        k = k - 1
   80       l = l - 1
     s = c(1)*a(i,j)
     z(i,j) = p + s
     wk(i,j) = q - s
     if (i /= j) go to 90
        z(i,j) = z(i,j) + 1.d0
        wk(i,j) = wk(i,j) + 1.d0
   90    continue
  100 continue
!
!        calculate exp(a) by solving  wk * exp(a) = z
!
  call dpslv (n, n, wk, n, z, kz, ierr)
  if (ierr /= 0) go to 210
  if (m == 0)  go to 150
!
!          take out the effect of the normalization
!                   operation on exp(a)
!
  do 140 k = 1,m
     do 121 j = 1,n
        do 120 i = 1,n
        s = 0.d0
           do 110 l = 1,n
  110          s = s + z(i,l)*z(l,j)
  120       wk(i,j) = s
  121    continue
!
     do 131 j = 1,n
        do 130 i = 1,n
  130       z(i,j) = wk(i,j)
  131    continue
  140 continue
!
!            take out the effect of the balancing
!                   operation on exp(a)
!
  150 call dbalnv (kz,n,z,low,igh,wk(1,n+12))
  return
!
!                     error return
!
  200 ierr = 1
  return
  210 ierr = 2
  return
end
subroutine dmfit(dimen,fitdeg,nfpols,nfpts, &
                   fitcds,ncrows,fitvls,wts, &
                   resids,error,fitiwk,fitdwk, &
                   fiwkln,fdwkln,ireqd,dreqd)
!
!*******************************************************************************
!
!! DMFIT constructs a least-squares multinomial fit to given data
!  using a basis of orthogonal multinomials. the computa-
!     tion is performed in double precision.
!
!     the data for the fit is given in the arrays fitcds, fitvls, and
!     wts. fitcds is a matrix, each row of which contains an observa-
!     tion point. fitvls is a singly-indexed array, each element of
!     which contains a function value corresponding to an observation
!     point. wts is a singly-indexed array, each element of which is
!     a nonnegative weight for the corresponding observation.
!
!     the fit which is produced is a multinomial expressed in the form
!
!      c  psi  (x ,...,x     ) +...+ c       psi       (x ,...,x     )
!       1    1   1      dimen         nfpols    nfpols   1      dimen
!
!     where the value of  nfpols  will be as given (if  fitdeg < 0)
!     or  as  computed  by  dmfit  to give a full-degree fit (in case
!     fitdeg  is specified >= 0).  the elements
!
!         psi  (x ,...,x     )
!            k   1      dimen
!
!     form a basis for the multinomials which is orthogonal with
!     respect to the weights and observation points.
!
!     the extent of the fit can be specified in one of two ways.
!         if the parameter fitdeg is set >= 0, then a complete basis
!         for the multinomials of degree =  fitdeg  will be used.  (an
!         error will be  flagged  if  this  will  require  more  basis
!         multinomials  than  the  number  of  data  points which were
!         given.)
!         if the parameter  fitdeg  is <  0, then  nfpols  will  be
!         taken as the count of the number of basis multinomials to be
!         used for a partial-degree fit.  (an error will be flagged if
!         nfpols  < 0.)
!
!     variables
!
!
!      dimen  -- (integer) -- (passed)
!         the number of variables.
!      fitdeg  - (integer) -- (passed/returned)
!         ignored if < 0.
!         if fitdeg >= 0 then  fitdeg  is  checked  against  nfpts .
!         the value of  fitdeg  will be reduced if there is a basis of
!         multinomials, all of  degree  <= fitdeg ,  of  cardinality
!         nfpts .  see  error  below.
!      nfpols  - (integer) -- (passed/returned)
!         ignored if  fitdeg  >= 0.
!         if  fitdeg < 0 then the value of nfpols will be taken  as
!         the size of the basis of multinomials to be used in the fit.
!         nfpols  must satisfy  nfpols  < nfpts  and nfpols >= 1
!         see  error  below.
!      nfpts --- (integer) -- (passed)
!         the number of data points to be used in the fit.
!         nfpts  must be >= 1.  see  error  below.
!      fitcds  -- (double precision 2-subscript array) -- (passed)
!         fitcds (p,k) is the value of the k-th variable at the  p-th
!         data point.
!      ncrows  -- (integer) -- (passed)
!         the row dimension  declared  for   fitcds   in  the  calling
!         program.
!      fitvls  -- (double precision 1-subscript array) -- (passed)
!         fitvls (p) is the observed function value of the p-th  data
!         point.
!      wts-- (double precision 1-subscript array) -- (passed)
!         wts (p) is the weight attached to the p-th data point.
!      resids  -- (double precision 1-subscript array) -- (returned)
!         resids (p) is the difference between the fitted function at
!         point p and  fitvls (p).
!      error  -- (integer) -- (returned)
!       0 the desired least square multinomial fit was obtained.
!      -1 only the first nfpols basis polynomials were obtained.
!         fitdeg is the degree of the fit.
!       1 if  fitdeg  >= 0 but there is an interpolating multinomial
!         of smaller degree or if fitdeg < 0 and nfpols > nfpts.
!       2 if  fitdeg  < 0 and  nfpols  <= 0.
!       3 if  nfpts  < 1 and/or  dimen   <  1.
!       4 if  iwklen  and/or  dwklen  is too small.  (set  iwklen   to
!         the value returned in  ireqd , and set  dwklen  to the value
!         returned in  dreqd  to resolve this problem.)
!      fitiwk  -- (integer, 1-subscript array) -- (returned)
!         an integer work array of length  fiwkln .  upon return  from
!         dmfit, fitiwk contains dimension and array length information.
!      fitdwk  -- (double precision 1-subscript array) -- (returned)
!         an array of length  fdwkln  containing the coefficients
!         needed for computing the multinomial fit at a point.
!      fiwkln  -- (integer) -- (passed)
!         the length of the array  fitiwk .
!      fdwkln  -- (integer) -- (passed)
!         the length of the array  fitdwk .
!      ireqd  -- (integer) -- (returned)
!         the length which the array  fitiwk  really needs to be.
!      dreqd  -- (integer) -- (returned)
!         the length which the array  fitdwk  really needs to be.
!
!
!     note. the 20 loop depends on the scaling scheme being used. the
!     residual scaling must be consistent with that defined by dscalp
!     and dscald.
!
!     dmfit  calls  allot  and  dgnrtp.
!
  integer nfpols,fitdeg,nfpts,dimen,fiwkln,fdwkln
  integer error,ireqd,dreqd,indstt,p,dimp1,ncrows
  integer newstt,maxstt,alfstt,psistt,cstt,ssqstt,psiwid,alfl
  integer fitiwk(fiwkln)
  double precision fitdwk(fdwkln),fitcds(ncrows,dimen)
  double precision fitvls(nfpts),resids(nfpts)
  double precision wts(nfpts),scale
!
  dimp1 = dimen + 1
!
!    *****
!
  call allot(fitdeg,nfpols,nfpts,dimen,fitiwk,fiwkln,ireqd,dreqd, &
             error)
  if ( error >= 2 ) return
!
  if ( fdwkln >= dreqd ) go to 10
     error = 4
     return
   10 continue
!
  psiwid = fitiwk(3)
  alfl = fitiwk(4)
  indstt = 1
  newstt = 4 * nfpols + indstt
  maxstt = 1
  alfstt = maxstt + dimp1
  cstt = alfstt + alfl
  ssqstt = cstt + nfpols
  psistt = ssqstt + nfpols
!
!    *****
!
     call dgnrtp(fitdeg,fitdwk(alfstt), &
                 fitdwk(psistt),fitiwk(indstt), &
                 fitiwk(newstt),fitdwk(ssqstt),fitcds, &
                 ncrows,nfpols,dimen,nfpts,fitvls,resids, &
                 fitdwk(cstt),psiwid,wts,alfl,dimp1, &
                 fitdwk(maxstt),error)
!
!     store the number of basis polynomials actually computed
!     by the modified routine dincdg called by dgnrtp.
!
  fitiwk(1) = nfpols
!
!    *****
!     unscale the residuals for the benefit of the user.
!    *****
!
  scale = fitdwk(dimen + 1)
  do 20 p = 1,nfpts
    resids(p) = resids(p) * scale
   20 continue
  return
end
subroutine dmprod (m, n, l, a, ka, b, kb, c, kc, row)
!
!*******************************************************************************
!
!! DMPROD: product of double precision matrices
!
  double precision a(ka,n), b(kb,l), c(kc,l), row(*), w
  logical dloc
!
  w = c(1,1)
  c(1,1) = 1.d0
  if (dloc(c,a)) go to 20
  if (dloc(c,b)) go to 30
!
  do 12 j = 1,l
     do 11 i = 1,m
     w = 0.d0
        do 10 k = 1,n
   10       w = w + a(i,k)*b(k,j)
   11    c(i,j) = w
   12 continue
  return
!
!     here c begins in the same location as a. the dimension of row
!     must be greater than or equal to l. it is assumed that kc=ka.
!
   20 a(1,1) = w
  do 24 i = 1,m
     do 22 j = 1,l
     w = 0.d0
        do 21 k = 1,n
   21       w = w + a(i,k)*b(k,j)
   22    row(j) = w
     do 23 j = 1,l
   23    a(i,j) = row(j)
   24 continue
  return
!
!     here c begins in the same location as b. the dimension of row
!     must be greater than or equal to m. it is assumed that kc=kb.
!
   30 b(1,1) = w
  do 34 j = 1,l
     do 32 i = 1,m
     w = 0.d0
        do 31 k = 1,n
   31       w = w + a(i,k)*b(k,j)
   32    row(i) = w
     do 33 i = 1,m
   33    b(i,j) = row(i)
   34 continue
  return
end
subroutine dmsubt (m, n, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! DMSUBT: subtraction of double precision matrices
!
  double precision a(ka,n), b(kb,n), c(kc,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
        c(i,j) = a(i,j) - b(i,j)
   10    continue
   20 continue
  return
end
subroutine dmtms (m, n, l, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! DMTMS: product of double precision matrices
!
  double precision a(ka,n), b(kb,l), c(kc,l), w
!
  do 30 j = 1,l
     do 20 i = 1,m
        w = 0.d0
        do 10 k = 1,n
           w = w + a(i,k)*b(k,j)
   10       continue
        c(i,j) = w
   20    continue
   30 continue
  return
end
function dnrm2 ( n, dx, incx)
!
!*******************************************************************************
!
!! DNRM2: euclidean norm of the n-vector stored in dx()
!  with storage increment incx .
!     if    n <= 0 return with result = 0.
!     if n >= 1 then incx must be >= 1
!
!           c.l.lawson, 1978 jan 08
!
!     four phase method     using two built-in constants that are
!     hopefully applicable to all machines.
!         cutlo = maximum of  dsqrt(u/eps)  over all known machines.
!         cuthi = minimum of  dsqrt(v)      over all known machines.
!     where
!         eps = smallest no. such that eps + 1. > 1.
!         u   = smallest positive no.   (underflow limit)
!         v   = largest  no.            (overflow  limit)
!
!     brief outline of algorithm..
!
!     phase 1    scans zero components.
!     move to phase 2 when a component is nonzero and <= cutlo
!     move to phase 3 when a component is > cutlo
!     move to phase 4 when a component is >= cuthi/m
!     where m = n for x() real and m = 2*n for complex.
!
  double precision dnrm2
  integer          next
  double precision   dx(*), cutlo, cuthi, hitest, sum, xmax,zero,one
  data   zero, one /0.0d0, 1.0d0/
!
!     values for cutlo and cuthi..
!     from the environmental parameters listed in the imsl converter
!     document the limiting values are as follows..
!     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
!                   univac and dec at 2**(-103)
!                   thus cutlo = 2**(-51) = 4.44089e-16
!     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
!                   thus cuthi = 2**(63.5) = 1.30438e19
!     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
!                   thus cutlo = 2**(-33.5) = 8.23181d-11
!     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
!     data cutlo, cuthi / 8.232d-11,  1.304d19 /
!     data cutlo, cuthi / 4.441e-16,  1.304e19 /
  data cutlo, cuthi / 8.232d-11,  1.304d19 /
!
  if(n > 0) go to 10
     dnrm2  = zero
     go to 300
!
   10 assign 30 to next
  sum = zero
  nn = n * incx
!                                                 begin main loop
  i = 1
   20    go to next,(30, 50, 70, 110)
   30 if( dabs(dx(i)) > cutlo) go to 85
  assign 50 to next
  xmax = zero
!
!                        phase 1.  sum is zero
!
   50 if( dx(i) == zero) go to 200
  if( dabs(dx(i)) > cutlo) go to 85
!
!                                prepare for phase 2.
  assign 70 to next
  go to 105
!
!                                prepare for phase 4.
!
  100 i = j
  assign 110 to next
  sum = (sum / dx(i)) / dx(i)
  105 xmax = dabs(dx(i))
  go to 115
!
!                   phase 2.  sum is small.
!                             scale to avoid destructive underflow.
!
   70 if( dabs(dx(i)) > cutlo ) go to 75
!
!                     common code for phases 2 and 4.
!                     in phase 4 sum is large.  scale to avoid overflow.
!
  110 if( dabs(dx(i)) <= xmax ) go to 115
     sum = one + sum * (xmax / dx(i))**2
     xmax = dabs(dx(i))
     go to 200
!
  115 sum = sum + (dx(i)/xmax)**2
  go to 200
!
!
!                  prepare for phase 3.
!
   75 sum = (sum * xmax) * xmax
!
!
!     for real or d.p. set hitest = cuthi/n
!     for complex      set hitest = cuthi/(2*n)
!
   85 hitest = cuthi/real( n )
!
!                   phase 3.  sum is mid-range.  no scaling.
!
  do 95 j =i,nn,incx
  if(dabs(dx(j)) >= hitest) go to 100
   95    sum = sum + dx(j)**2
  dnrm2 = dsqrt( sum )
  go to 300
!
  200 continue
  i = i + incx
  if ( i <= nn ) go to 20
!
!              end of main loop.
!
!              compute square root and adjust for scaling.
!
  dnrm2 = xmax * dsqrt(sum)
  300 continue
  return
end
subroutine dnspiv (n,ia,ja,a,b,max,r,c,ic,x,y,p,iu,ju,u,ierr)
!
!*******************************************************************************
!
!! DNSPIV uses sparse gaussian elimination with column interchanges
!  to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!
!  see dspslv for descriptions of all input and output arguments
!  other than those described below
!
!  ic  integer array of n entries which is the inverse of c
!      (i.e., ic(c(i)) = i). ic is both an input and output
!      argument.
!
!  input arguments (used internally only)---
!
!  y   double precision array of n entries used to compute
!      the updated right hand side
!
!  p   integer array of n+1 entries used for a linked list.
!      p(n+1) is the list header, and the entry following
!      p(k) is in p(p(k)).  thus, p(n+1) is the first data
!      item, p(p(n+1)) is the second, etc.  a pointer of
!      n+1 marks the end of the list
!
!  iu  integer array of n+1 entries used for row pointers to u
!      (see matrix storage description below)
!
!  ju  integer array of max entries used for column numbers of
!      the nonzeros in the strict upper triangle of u.  (see
!      matrix storage description below)
!
!  u   double precision array of max entries used for the actual
!      nonzeros in the strict upper triangle of u. (see matrix
!      storage description below)
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzeros in
!  a.  iu, ju, and u are used in a similar way to store the strict upper
!  triangle of u, except that ju actually contains c(j) instead of j
!
!
  double precision a(*), b(n), u(max), x(n), y(n)
  double precision dk, lki, xpv, xpvmax, yk
  integer c(n), ia(*), ic(n), iu(*), ja(*), ju(max), p(*), r(n)
  integer ck, pk, ppk, pv, v, vi, vj, vk
!
!  initialize work storage and pointers to ju
!
  do 10 j = 1,n
    x(j) = 0.d0
 10   continue
  iu(1) = 1
  juptr = 0
!
!  perform symbolic and numeric factorization row by row
!  vk (vi,vj) is the graph vertex for row k (i,j) of u
!
  do 170 k = 1,n
!
!  initialize linked list and free storage for this row
!  the r(k)-th row of a becomes the k-th row of u.
!
    p(n+1) = n+1
    vk = r(k)
!
!  set up adjacency list for vk, ordered in
!  current column order of u.  the loop index
!  goes downward to exploit any columns
!  from a in correct relative order
!
    jmin = ia(vk)
    jmax = ia(vk+1) - 1
    if (jmin > jmax)  go to 1002
    j = jmax
 20       jaj = ja(j)
      vj = ic(jaj)
!
!  store a(k,j) in work vector
!
      x(vj) = a(j)
!  this code inserts vj into adjacency list of vk
      ppk = n+1
 30       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  30,1003,40
 40       p(vj) = ppk
      p(pk) = vj
      j = j - 1
      if (j >= jmin) go to 20
!
!  the following code computes the k-th row of u
!
    vi = n+1
    yk = b(vk)
 50     vi = p(vi)
    if (vi >= k) go to 110
!
!  vi lt vk -- process the l(k,i) element and merge the
!  adjacency of vi with the ordered adjacency of vk
!
    lki = - x(vi)
    x(vi) = 0.d0
!
!  adjust right hand side to reflect elimination
!
    yk = yk + lki * y(vi)
    ppk = vi
    jmin = iu(vi)
    jmax = iu(vi+1) - 1
    if (jmin > jmax)  go to 50
    do 100 j = jmin,jmax
      juj = ju(j)
      vj = ic(juj)
!
!  if vj is already in the adjacency of vk,
!  skip the insertion
!
      if (x(vj) /= 0.d0)  go to 90
!
!  insert vj in adjacency list of vk.
!  reset ppk to vi if we have passed the correct
!  insertion spot.  (this happens when the adjacency of
!  vi is not in current column order due to pivoting.)
!
      if (vj - ppk) 60,90,70
 60       ppk = vi
 70       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  70,90,80
 80       p(vj) = ppk
      p(pk) = vj
      ppk = vj
!
!  compute l(k,j) = l(k,j) - l(k,i)*u(i,j) for l(k,i) nonzero
!  compute u*(k,j) = u*(k,j) - l(k,i)*u(i,j) for u(k,j) nonzero
!  (u*(k,j) = u(k,j)*d(k,k))
!
 90       x(vj) = x(vj) + lki * u(j)
 100    continue
    go to 50
!
!  pivot--interchange largest entry of k-th row of u with
!  the diagonal entry.
!
!  find largest entry, counting off-diagonal nonzeros
!
 110    if (vi > n) go to 1004
    xpvmax = dabs(x(vi))
    maxc = vi
    nzcnt = 0
    pv = vi
 120      v = pv
      pv = p(pv)
      if (pv > n) go to 130
      nzcnt = nzcnt + 1
      xpv = dabs(x(pv))
      if (xpv <= xpvmax) go to 120
      xpvmax = xpv
      maxc = pv
      maxcl = v
      go to 120
 130    if (xpvmax == 0.d0) go to 1004
!
!  if vi = k, then there is an entry for diagonal
!  which must be deleted.  otherwise, delete the
!  entry which will become the diagonal entry
!
    if (vi == k) go to 140
    if (vi == maxc) go to 140
    p(maxcl) = p(maxc)
    go to 150
 140    vi = p(vi)
!
!  compute d(k) = 1/l(k,k) and perform interchange.
!
 150    dk = 1.d0 / x(maxc)
    x(maxc) = x(k)
    i = c(k)
    c(k) = c(maxc)
    c(maxc) = i
    ck = c(k)
    ic(ck) = k
    ic(i) = maxc
    x(k) = 0.d0
!
!  update right hand side.
!
    y(k) = yk * dk
!
!  compute value for iu(k+1) and check for storage overflow
!
    iu(k+1) = iu(k) + nzcnt
    if (iu(k+1) > max+1) go to 1005
!
!  move column indices from linked list to ju.
!  columns are stored in current order with original
!  column number (c(j)) stored for current column j
!
    if (vi > n)  go to 170
    j = vi
 160      juptr = juptr + 1
      ju(juptr) = c(j)
      u(juptr) = x(j) * dk
      x(j) = 0.d0
      j = p(j)
      if (j <= n) go to 160
 170    continue
!
!  backsolve u x = y, and reorder x to correspond with a
!
  k = n
  do 200 i = 1,n
    yk = y(k)
    jmin = iu(k)
    jmax = iu(k+1) - 1
    if (jmin > jmax)  go to 190
    do 180 j = jmin,jmax
      juj = ju(j)
      juj = ic(juj)
      yk = yk - u(j) * y(juj)
 180    continue
 190    y(k) = yk
    ck = c(k)
    x(ck) = yk
    k = k - 1
 200  continue
!
!  return with ierr = number of off-diagonal nonzeros in u
!
  ierr = iu(n+1) - iu(1)
  return
!
!  error returns
!
!  row k of a is null
!
 1002 ierr = -k
  return
!
!  row k of a has a duplicate entry
!
 1003 ierr = -(n+k)
  return
!
!  zero pivot in row k
!
 1004 ierr = -(2*n+k)
  return
!
!  storage for u exceeded on row k
!
 1005 ierr = -(3*n+k)
  return
end
subroutine dogleg ( n, r, lr, diag, qtb, delta, x )
!
!*******************************************************************************
!
!! DOGLEG finds the minimizing combination of Gauss-Newton and gradient steps.
!
!
!  Discussion:
!
!    Given an M by N matrix A, an N by N nonsingular diagonal
!    matrix D, an M-vector B, and a positive number DELTA, the
!    problem is to determine the convex combination X of the
!    Gauss-Newton and scaled gradient directions that minimizes
!    (A*X - B) in the least squares sense, subject to the
!    restriction that the euclidean norm of D*X be at most DELTA.
!
!    This subroutine completes the solution of the problem
!    if it is provided with the necessary information from the
!    QR factorization of A.  That is, if A = Q*R, where Q has
!    orthogonal columns and R is an upper triangular matrix,
!    then DOGLEG expects the full upper triangle of R and
!    the first N components of Q'*B.
!
!  Reference:
!
!    More, Garbow and Hillstrom,
!    User Guide for MINPACK-1
!    Argonne National Laboratory,
!    Argonne, Illinois.
!
!  Parameters:
!
!    Input, integer N, the order of the matrix R.
!
!    Input, real R(LR), the upper triangular matrix R stored by rows.
!
!    Input, integer LR, the size of the R array, which must be no less
!    than (N*(N+1))/2.
!
!    Input, real DIAG(N), the diagonal elements of the matrix D.
!
!    Input, real QTB(N), the first N elements of the vector Q'* B.
!
!    Input, real DELTA, is a positive upper bound on the euclidean norm
!    of D*X(1:N).
!
!    Output, real X(N), the desired convex combination of the Gauss-Newton
!    direction and the scaled gradient direction.
!
  integer lr
  integer n
!
  real alpha
  real bnorm
  real delta
  real diag(n)
  real enorm
  real epsmch
  real gnorm
  integer i
  integer j
  integer jj
  integer k
  integer l
  real qnorm
  real qtb(n)
  real r(lr)
  real sgnorm
  real sum2
  real temp
  real wa1(n)
  real wa2(n)
  real x(n)
!
  epsmch = epsilon ( epsmch )
!
!  Calculate the Gauss-Newton direction.
!
  jj = ( n * ( n + 1 ) ) / 2 + 1

  do k = 1, n

     j = n - k + 1
     jj = jj - k
     l = jj + 1
     sum2 = 0.0E+00

     do i = j+1, n
       sum2 = sum2 + r(l) * x(i)
       l = l + 1
     end do

     temp = r(jj)

     if ( temp == 0.0E+00 ) then

       l = j
       do i = 1, j
         temp = max ( temp, abs ( r(l)) )
         l = l + n - i
       end do

       if ( temp == 0.0E+00 ) then
         temp = epsmch
       else
         temp = epsmch * temp
       end if

     end if

     x(j) = ( qtb(j) - sum2 ) / temp

  end do
!
!  Test whether the Gauss-Newton direction is acceptable.
!
  wa1(1:n) = 0.0E+00
  wa2(1:n) = diag(1:n) * x(1:n)
  qnorm = enorm ( n, wa2 )

  if ( qnorm <= delta ) then
    return
  end if
!
!  The Gauss-Newton direction is not acceptable.
!  Calculate the scaled gradient direction.
!
  l = 1
  do j = 1, n
     temp = qtb(j)
     do i = j, n
       wa1(i) = wa1(i) + r(l) * temp
       l = l + 1
     end do
     wa1(j) = wa1(j) / diag(j)
  end do
!
!  Calculate the norm of the scaled gradient.
!  Test for the special case in which the scaled gradient is zero.
!
  gnorm = enorm ( n, wa1 )
  sgnorm = 0.0E+00
  alpha = delta / qnorm

  if ( gnorm /= 0.0E+00 ) then
!
!  Calculate the point along the scaled gradient which minimizes the quadratic.
!
    wa1(1:n) = ( wa1(1:n) / gnorm ) / diag(1:n)

    l = 1
    do j = 1, n
      sum2 = 0.0E+00
      do i = j, n
        sum2 = sum2 + r(l) * wa1(i)
        l = l + 1
      end do
      wa2(j) = sum2
    end do

    temp = enorm ( n, wa2 )
    sgnorm = ( gnorm / temp ) / temp
!
!  Test whether the scaled gradient direction is acceptable.
!
    alpha = 0.0E+00
!
!  The scaled gradient direction is not acceptable.
!  Calculate the point along the dogleg at which the quadratic is minimized.
!
    if ( sgnorm < delta ) then

      bnorm = enorm ( n, qtb )
      temp = ( bnorm / gnorm ) * ( bnorm / qnorm ) * ( sgnorm / delta )
      temp = temp - ( delta / qnorm ) * ( sgnorm / delta)**2 &
        + sqrt ( ( temp - ( delta / qnorm ) )**2 &
        + ( 1.0E+00 - ( delta / qnorm )**2 ) &
        * ( 1.0E+00 - ( sgnorm / delta )**2 ) )

      alpha = ( ( delta / qnorm ) * ( 1.0E+00 - ( sgnorm / delta )**2 ) ) / temp

    end if

  end if
!
!  Form appropriate convex combination of the Gauss-Newton
!  direction and the scaled gradient direction.
!
  temp = ( 1.0E+00 - alpha ) * min ( sgnorm, delta )

  x(1:n) = temp * wa1(1:n) + alpha * x(1:n)

  return
end
subroutine dorsol ( m, n, qr, ms, s, ip, x )
!
!*******************************************************************************
!
!! DORSOL: least squares solution of a linear system
!  given an orthogonal-triangular factorization of the coefficient
!                matrix produced by subroutine dortho
!        fortran subroutine subprogram
!        aerospace research laboratories
!        wright-patterson afb, ohio  45433
!      purpose
!        dorsol computes the least squares solution of the linear system
!        qrx = pax = b where q, r, and p are determined from a by dortho
!      control
!
!        dimension qr(ms,n), s(n), ip(n), x(m)
!        .
!        .
!        .
!        call dorsol(m, n, qr, ms, s, ip, x)
!
!        where
!        m  is an integer input variable, the number of rows of a.
!        n  is an integer input variable, the number of columns of a
!             (1 < n <= m).
!        qr is a real input array, the orthogonal and triangular factors
!           of a produced by dortho.
!        ms is an integer input variable, the leading dimension of
!           qr in the calling program.
!        s  is a real input array, the relevant parts of q produced by
!           dortho.
!        ip is an integer input array, the permutation information
!           produced by dortho.
!        x  as a real input array is the right-hand side b of ax = b.
!        x  as a real output array is x(i), i = 1, ..., n, the least
!           squares solution, and x(j), j = n+1, ..., m, the vector
!           whose length is the minimum of all residual b - ax.
!      method
!        the factored system qrx = pax = pb are solved in the sequence
!        of qy = pb and rx = y. full rank for the matrix a is assumed
!        which can be checked by interrogating the logical output
!        variable produced by dortho.
!      references
!        (1) peter businger and g.h. golub, linear least squares solu-
!            tions by householder transformations, numer. math. 7(1965),
!            269-276.
!        (2) n.k. tsao and p.j. nikolai, procedures using orthogonal
!            transformations for linear least squares problems, arl
!            technical report arl tr 74-0124(1974).
!
  double precision qr(ms,n)
  double precision s(n)
  double precision x(m)
  integer ip(n)
  double precision sav, ss, y
!
  nn = n
  if(n == m) nn = n - 1
  do 30 j = 1, nn
    jp = j + 1
    ij = ip(j)
    y = 1.d0 - s(j)
    sav = x(j)
    x(j) = x(ij)
    x(ij) = sav
!                                       premultiply x with the j-th
!                                       orthogonal matrix.
    sav = x(j)
    do 10 k = jp, m
   10     sav = sav + qr(k,j)*x(k)
    ss = x(j)
    x(j) = sav/s(j)
    ss = (ss - x(j))/y
    do 20 k = jp, m
   20     x(k) = x(k) - qr(k,j)*ss
   30 continue
!                                       back substitute to find the
!                                       least squares solution.
  x(n) = x(n)/qr(n,n)
  nm = n - 1
  do 50 i = 1, nm
    ni = n - i
    nn = n
    do 40 j = 1, i
      x(ni) = x(ni) - qr(ni,nn)*x(nn)
   40     nn = nn - 1
    x(ni) = x(ni)/qr(ni,ni)
   50 continue
  return
end
subroutine dorth(nm,n,low,igh,a,ort)
!
!*******************************************************************************
!
!! DORTH reduces a matrix to upper hessenberg form.
!
!
!     given a real general matrix, this subroutine
!     reduces a submatrix situated in rows and columns
!     low through igh to upper hessenberg form by
!     orthogonal similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if dbal has not been used then
!          set low=1, igh=n,
!
!        a contains the input matrix.
!
!     on output-
!
!        a contains the hessenberg matrix.  information about
!          the orthogonal transformations used in the reduction
!          is stored in the remaining triangle under the
!          hessenberg matrix,
!
!        ort contains further information about the transformations.
!          only elements low through igh are used.
!
  integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
  double precision a(nm,n),ort(igh)
  double precision f,g,h,scale
!     double precision dsqrt,dabs
!
!
  la = igh - 1
  kp1 = low + 1
  if (la < kp1) go to 200
!
  do 180 m = kp1, la
     h = 0.d0
     ort(m) = 0.d0
     scale = 0.d0
!    scale column (algol tol then not needed)
     do 90 i = m, igh
   90    scale = scale + dabs(a(i,m-1))
!
     if (scale == 0.d0) go to 180
     mp = m + igh
!    for i=igh step -1 until m do --
     do 100 ii = m, igh
        i = mp - ii
        ort(i) = a(i,m-1) / scale
        h = h + ort(i) * ort(i)
  100    continue
!
     g = dsqrt(h)
     if (ort(m) >= 0.d0) g = -g
     h = h - ort(m) * g
     ort(m) = ort(m) - g
!    form (i-(u*ut)/h) * a
     do 130 j = m, n
        f = 0.d0
!    for i=igh step -1 until m do --
        do 110 ii = m, igh
           i = mp - ii
           f = f + ort(i) * a(i,j)
  110       continue
!
        f = f / h
!
        do 120 i = m, igh
  120       a(i,j) = a(i,j) - f * ort(i)
!
  130    continue
!    form (i-(u*ut)/h)*a*(i-(u*ut)/h)
     do 160 i = 1, igh
        f = 0.d0
!    for j=igh step -1 until m do --
        do 140 jj = m, igh
           j = mp - jj
           f = f + ort(j) * a(i,j)
  140       continue
!
        f = f / h
!
        do 150 j = m, igh
  150       a(i,j) = a(i,j) - f * ort(j)
!
  160    continue
!
     ort(m) = scale * ort(m)
     a(m,m-1) = scale * g
  180 continue
!
  200 return
end
subroutine dortho(m, n, qr, ms, s, ip, exit)
!
!*******************************************************************************
!
!! DORTHO: orthogonal transformation of a rectangular matrix to triangular form.
!
!        fortran subroutine subprogram
!        aerospace research laboratories
!        wright-patterson afb, ohio  45433
!      purpose
!        dortho computes an implicit orthogonal matrix q and an explicit
!        upper triangular matrix r and a permutation matrix p satisfying
!        qr = pa given an m by n real matrix a.  dortho is intended for
!        use with the subroutine dorsol to produce the least squares
!        solution of the equation ax = b.
!      control
!
!        dimension qr(ms,n), s(n), ip(n)
!        logical exit
!        .
!        .
!        .
!        call dortho(m, n, qr, ms, s, ip, exit)
!
!        where
!        m    is an integer input variable, the number of rows of a.
!        n    is an integer input variable, the number of columns of a,
!             (1 < n <= m).
!        qr   as a real input array is matrix a to be triangularized.
!        qr   as a real output array is the upper triangular factor r in
!             qr(i,j), i <= j, and the relevant parts of q in qr(i,j),
!             i > j.
!        ms   is an integer input variable, the leading dimension of
!             qr in the calling program.
!        s    is a real output array, the relevant parts of q.
!        ip   is an integer output array containing in ip(i), i=1,...,n,
!             the images of the permutation corresponding to the permu-
!             tation matrix p.
!        exit is set to the value .true. if the rank of a is equal to n
!             and .false. otherwise.
!      method
!        the matrix a in the array qr is reduced to upper triangular
!        form using orthogonal transformation with partial pivoting.
!      references
!        (1) peter businger and g.h. golub, linear least squares solu-
!            tions by householder transformations, numer. math. 7(1965),
!            269-276.
!        (2) n.k. tsao and p.j. nikolai, procedures using orthogonal
!            transformations for linear least squares problems, arl
!            technical report arl tr 74-0124(1974).
!
  double precision qr(ms,n), s(n)
  integer ip(n)
  double precision ajj, sav, ss, y
  logical exit
!
  exit = .true.
  nn = n
  if (n == m) nn = n - 1
  do 80 j = 1, nn
    ip(j) = j
    jp = j + 1
    kj = j
!                                       search for pivot in the j-th
!                                       column and interchange rows.
    do 10 k = jp, m
       if (dabs(qr(k,j)) > dabs(qr(kj,j))) kj = k
   10   continue
    if (qr(kj,j) == 0.d0) go to 90
    if (kj == j) go to 30
    ip(j) = kj
    do 20 i = j, n
       sav = qr(j,i)
       qr(j,i) = qr(kj,i)
   20      qr(kj,i) = sav
!                                       normalize the pivoting column
!                                       and find its norm.
   30   ajj = qr(j,j)
    do 31 i = jp, m
   31      qr(i,j) = qr(i,j)/ajj
    sav = 1.d0
    do 40 i = jp, m
   40      sav = sav + qr(i,j)*qr(i,j)
    s(j) = -dsqrt(sav)
    qr(j,j) = s(j)*ajj
    if (jp > n) go to 80
!                                       premultiply qr with the j-th
!                                       orthogonal matrix.
    y = 1.d0 - s(j)
    do 70 k = jp, n
       sav = qr(j,k)
       do 50 i = jp, m
   50         sav = sav + qr(i,j)*qr(i,k)
       ss = qr(j,k)
       qr(j,k) = sav/s(j)
       ss = (ss - qr(j,k))/y
       do 60 i = jp, m
   60         qr(i,k) = qr(i,k) - qr(i,j)*ss
   70   continue
   80 continue
  return
!
   90 exit = .false.
  return
end
subroutine dortrn(nm,n,low,igh,a,ort,z)
!
!*******************************************************************************
!
!! DORTRN accumulates the orthogonal similarity transformations
!  used in the reduction of a real double
!     precision matrix to upper hessenberg form by dorth.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if dbal has not been used then
!          set low=1, igh=n,
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction by dorth
!          in its strict lower triangle,
!
!        ort contains further information about the trans-
!          formations used in the reduction by dorth.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by dorth,
!
!        ort has been altered.
!
  integer i,j,n,kl,mm,mp,nm,igh,low,mp1
  double precision a(nm,igh),ort(igh),z(nm,n)
  double precision g
!
!    initialize z to identity matrix
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.d0
!
     z(i,i) = 1.d0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!    for mp=igh-1 step -1 until low+1 do --
  do 140 mm = 1, kl
     mp = igh - mm
     if (a(mp,mp-1) == 0.d0) go to 140
     mp1 = mp + 1
!
     do 100 i = mp1, igh
  100    ort(i) = a(i,mp-1)
!
     do 130 j = mp, igh
        g = 0.d0
!
        do 110 i = mp, igh
  110       g = g + ort(i) * z(i,j)
!    divisor below is negative of h formed in orthes.
!                double division avoids possible underflow
        g = (g / ort(mp)) / a(mp,mp-1)
!
        do 120 i = mp, igh
  120       z(i,j) = z(i,j) + g * ort(i)
!
  130    continue
!
  140 continue
!
  200 return
end
subroutine dpadd (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! DPADD: addition of double precision polynomials
!
  double precision a(*), b(*), c(*)
!
  la = 1
  lb = 1
  lc = 1
  do i = 1,n
     c(lc) = 0.d0
     if (i <= l) c(lc) = a(la)
     if (i <= m) c(lc) = c(lc) + b(lb)
     la = la + ka
     lb = lb + kb
     lc = lc + kc
  end do

  return
end
subroutine dpchol (mo,n,m,a,b,kb,ierr)
!
!*******************************************************************************
!
!! DPCHOL: cholesky matrix factorization.
!
  double precision a(*)
  double precision b(*)
  double precision d(2)
  integer onej
!
!  matrix factorization
!
  call dppfa (a,n,ierr)
  if (ierr /= 0) return
!
!  solution of the equation ax=b
!
  onej = 1

  do j = 1,m
    call dppsl (a,n,b(onej))
    onej = onej + kb
  end do
!
!  computation of the inverse of a
!
  if ( mo == 0 ) then
    call dppdi (a,n,d,1)
  end if

  return
end
subroutine dpcopy (a,ka,m,b,kb,n)
!
!*******************************************************************************
!
!! DPCOPY: copying double precision polynomials
!
  double precision a(*), b(*)
!
  la = 1
  lb = 1
  jmax = min (m, n)
  do 10 j = 1,jmax
     b(lb) = a(la)
     la = la + ka
     lb = lb + kb
   10 continue
  if (jmax == n) return
!
  mp1 = m + 1
  do 20 j = mp1,n
     b(lb) = 0.d0
     lb = lb + kb
   20 continue
  return
end
function dpdel(x)
!
!*******************************************************************************
!
!! DPDEL: computation of the function del(x) for  x >= 10
!  where
!     ln(gamma(x)) = (x - 0.5)*ln(x) - x + 0.5*ln(2*pi) + del(x)
!
!             --
!
!     the series for dpdel on the interval 0.0 to 1.0 derived by
!     a.h. morris from the chebyshev series in the slatec library
!     obtained by wayne fullerton (los alamos).
!
!
  double precision dpdel
  double precision x, a(15), t, w
!
  data a(1)  / .833333333333333333333333333333d-01/, &
       a(2)  /-.277777777777777777777777752282d-04/, &
       a(3)  / .793650793650793650791732130419d-07/, &
       a(4)  /-.595238095238095232389839236182d-09/, &
       a(5)  / .841750841750832853294451671990d-11/, &
       a(6)  /-.191752691751854612334149171243d-12/, &
       a(7)  / .641025640510325475730918472625d-14/, &
       a(8)  /-.295506514125338232839867823991d-15/, &
       a(9)  / .179643716359402238723287696452d-16/, &
       a(10) /-.139228964661627791231203060395d-17/
  data a(11) / .133802855014020915603275339093d-18/, &
       a(12) /-.154246009867966094273710216533d-19/, &
       a(13) / .197701992980957427278370133333d-20/, &
       a(14) /-.234065664793997056856992426667d-21/, &
       a(15) / .171348014966398575409015466667d-22/
!
  t = (10.d0/x)**2
  w = a(15)
  do 10 i = 1,14
     k = 15 - i
     w = t*w + a(k)
   10 continue
  dpdel = w/x
  return
end
function dpdet(a,ka,n,x)
!
!*******************************************************************************
!
!! DPDET: evaluation of the determinant of a-xi
!  where a is an nxn matrix,
!     x is a scalar, and i is the nxn identity matrix.
!
!     ka is the row dimension of a in the calling program. it is
!     assumed that ka is greater than or equal to n.
!
  double precision dpdet
  double precision a(ka,n),x
  double precision pivot,s,c
  if (n >= 2) go to 10
  dpdet = a(1,1) - x
  return
!
!              replace a with a-xi
!
   10 if (x == 0.d0) go to 20
  do 11 k=1,n
   11 a(k,k) = a(k,k) - x
!
!                initialization
!
   20 dpdet = 1.d0
  nm1 = n - 1
  do 52 k=1,nm1
  kp1 = k + 1
!
!       search for the k-th pivot element
!
  s = dabs(a(k,k))
  l = k
  do 30 i=kp1,n
  c = dabs(a(i,k))
  if (s >= c) go to 30
  s = c
  l = i
   30 continue
  pivot = a(l,k)
!
!         update the calculation of det
!
  dpdet = dpdet*pivot
  if (dpdet == 0.d0) return
  if (k == l) go to 50
  dpdet = -dpdet
!
!          interchanging rows k and l
!
  do 40 j=k,n
  c = a(k,j)
  a(k,j) = a(l,j)
   40 a(l,j) = c
!
!        reduction of the non-pivot rows
!
   50 do 51 i=kp1,n
  c = a(i,k)/pivot
  do 51 j=kp1,n
   51 a(i,j) = a(i,j) - c*a(k,j)
   52 continue
!
!         final determinant calculation
!
  dpdet = dpdet*a(n,n)
  return
end
subroutine dpdiv (a,ka,l,b,kb,m,c,kc,n,ierr)
!
!*******************************************************************************
!
!! DPDIV: division of double precision polynomials
!
  double precision a(*), b(*), c(*)
  double precision b0, sum
!
  b0 = b(1)
  if (b0 == 0.d0) go to 100
  ierr = 0
  c(1) = a(1)/b0
  if (n == 1) return
!
!               case when m = 1
!
  if (m > 1) go to 20
  la = 1
  lc = 1
  do 10 j = 2,n
     la = la + ka
     lc = lc + kc
     c(lc) = 0.d0
     if (j <= l) c(lc) = a(la)/b0
   10 continue
  return
!
!              case when m > 1
!
   20 la = 1
  lc = 1
  do 40 j = 2,n
     la = la + ka
     lc = lc + kc
     ib = 1
     ic = lc
     sum = 0.d0
     if (j <= l) sum = a(la)
     imax = min (j, m)
     do 30 i = 2,imax
        ib = ib + kb
        ic = ic - kc
        sum = sum - b(ib)*c(ic)
   30    continue
     c(lc) = sum/b0
   40 continue
  return
!
!                error return
!
  100 ierr = 1
  return
end
subroutine dpinv (a, d, n, q)
!
!*******************************************************************************
!
!! DPINV: computation of the inverse of the power series
!                  sum (a(i)*x**i, i = 1,2,...)
!
  double precision a(n), d(n), q(*)
  double precision s, sum, t, u
!
!     num = (n*(n + 1))/2
!     real q(num)
!
!
!                 compute the coefficient matrix q
!
  q(1) = 1.d0
  k = 2
  do 10 i = 2,n
     q(k) = 0.d0
   10 k = k + i
!
  jj = 1
  do 22 j = 2,n
     l0 = jj
     jj = (j*(j + 1))/2
     k = jj
     do 21 i = j,n
        sum = 0.d0
        m = i - j + 2
        ll = l0
        do 20 l = j,i
           sum = sum + a(m)*q(ll)
           m = m - 1
           ll = ll + (l - 1)
   20       continue
        q(k) = sum
        k = k + i
   21    continue
   22 continue
!
!              compute the coefficients of the inverse
!
  k = 1
  do 31 j = 1,n
     u = 1.d0/(j*a(1)**j)
     sum = 0.d0
     do 30 l = 1,j
        sum = sum + u*q(k)
        s = l + j - 1
        t = l
        u = -(s*u)/(t*a(1))
        k = k + 1
   30    continue
     d(j) = sum
   31 continue
  return
end
subroutine dple (rowk,n,b,c,d,ip,ierr)
!
!*******************************************************************************
!
!! DPLE: solution of linear equations with reduced storage
!
  double precision b(n),c(n),d(*)
  integer ip(*)
  double precision bk,cj,ck,c1,dkj,zero
  external rowk
  data zero/0.d0/
!
!     set the necessary constants
!
  ierr = 0
  np1 = n + 1
  max = n*n/4 + n + 3
  k = 1
  iflag = -1
!
!     get the first column of the transposed system
!
  call rowk(n,1,c)
  bk = b(1)
!
  if (n > 1) go to 10
  if (c(1) == zero) go to 200
  c(1) = bk/c(1)
  return
!
!     find the pivot for column 1
!
   10 m = 1
  do 20 i = 2,n
  if (dabs(c(m)) < dabs(c(i))) m = i
   20 continue
!
  ip(1) = m
  c1 = c(m)
  c(m) = c(1)
  c(1) = c1
  if (c(1) == zero) go to 200
!
!     find the first elementary matrix and store it in d
!
  do 30 i = 2,n
   30 d(i-1) = -c(i)/c(1)
  d(n) = bk/c(1)
!
!     k loop - each k for a new column of the transposed system
!
  do 120 k = 2,n
  kp1 = k + 1
  km1 = k - 1
!
!       get column k
!
  call rowk(n,k,c)
  do 40 j = 1,km1
  m = ip(j)
  cj = c(j)
  c(j) = c(m)
   40 c(m) = cj
  bk = b(k)
!
  iflag = -iflag
  lcol = np1 - k
  lcolp1 = lcol + 1
  lastm1 = 1
  last = max - n + k
  if (k == 2) go to 50
!
  lastm1 = max - n + km1
  if (iflag < 0) last = last - n + k - 2
  if (iflag > 0) lastm1 = lastm1 - n + k - 3
!
!     j loop - effect of columns 1 to k-1 of l-inverse
!
   50 do 61 j = 1,km1
  cj = c(j)
  ij = (j-1)*lcolp1
  if (j == km1) ij = lastm1 - 1
!
!     i loop - effect of l-inverse on rows k to n+1
!
  do 60 i = k,n
  ij = ij + 1
   60 c(i) = c(i) + d(ij)*cj
   61 bk = bk - d(ij+1)*cj
!
!       k=n case
!
  m = k
  if (k < n) go to 70
  if (c(k) == zero) go to 200
  d(last) = bk/c(k)
  go to 90
!
!     find the pivot
!
   70 do 71 i = kp1,n
  if (dabs(c(m)) < dabs(c(i))) m = i
   71 continue
!
  ip(k) = m
  ck = c(m)
  c(m) = c(k)
  c(k) = ck
  if (c(k) == zero) go to 200
!
!     find the k-th elementary matrix
!
  ik = last
  do 80 i = kp1,n
  d(ik) = -c(i)/c(k)
   80 ik = ik + 1
  d(ik) = bk/c(k)
!
!     form the product of the elementary matrices
!
   90 do 110 j = 1,km1
  kjold = j*lcolp1 + k - np1
  mjold = kjold + m - k
  ij = (j-1)*lcol
  ijold = ij + j
  if (j /= km1) go to 100
!
  kjold = lastm1
  mjold = lastm1 + m - k
  ijold = lastm1
!
  100 ik = last - 1
  dkj = d(mjold)
  d(mjold) = d(kjold)
  do 110 i = kp1,np1
  ij = ij + 1
  ijold = ijold + 1
  ik = ik + 1
  d(ij) = d(ijold) + d(ik)*dkj
  110 continue
  120 continue
!
  last = max
  if (iflag < 0) last = max - 2
  d(n) = d(last)
!
!     insert the solution in c
!
  do 130 i = 1,n
  130 c(i) = d(i)
!
  nm1 = n - 1
  do 140 i = 1,nm1
  k = n - i
  m = ip(k)
  ck = c(k)
  c(k) = c(m)
  140 c(m) = ck
  return
!
!     the system is singular
!
  200 ierr = k
  return
end
subroutine dplpwr(r,a,ka,m,b,kb,n,ierr)
!
!*******************************************************************************
!
!! DPLPWR: set b = a**r where a is a double precision polynomial
!
  double precision a(*), b(*), r
  double precision a0, coeff, jm1, rp1, sum
!
  a0 = a(1)
  if (a0 <= 0.d0) go to 100
  ierr = 0
  b(1) = a0**r
  if (n == 1) return
!
!            case when m = 1 or r = 0
!
  if (m > 1 .and. r /= 0.d0) go to 20
  lb = 1
  do 10 j = 2,n
     lb = lb + kb
     b(lb) = 0.d0
   10 continue
  return
!
!                  general case
!
   20 rp1 = r + 1.d0
  lb = 1
  do 40 j = 2,n
     lb = lb + kb
     jm1 = j - 1
     ia = 1
     ib = lb
     coeff = -jm1
     sum = 0.d0
     imax = min (j, m)
     do 30 i = 2,imax
        ia = ia + ka
        ib = ib - kb
        coeff = coeff + rp1
        sum = sum + coeff*a(ia)*b(ib)
   30    continue
     b(lb) = sum/(jm1*a0)
   40 continue
  return
!
!                error return
!
  100 ierr = 1
  return
end
function dpmpar (i)
!
!*******************************************************************************
!
!! DPMPAR provides the double precision machine constants for the computer
!  being used. it is assumed that the argument
!     i is an integer having one of the values 1, 2, or 3. if the
!     double precision arithmetic being used has m base b digits and
!     its smallest and largest exponents are emin and emax, then
!
!        dpmpar(1) = b**(1 - m), the machine precision,
!
!        dpmpar(2) = b**(emin - 1), the smallest magnitude,
!
!        dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
!
!
!     written by
!        Alfred Morris,
!        naval surface warfare center
!        dahlgren virginia
!
  double precision dpmpar
  integer emin, emax
  double precision b, binv, bm1, one, w, z
!
  if (i > 1) go to 10
     b = ipmpar(4)
     m = ipmpar(8)
     dpmpar = b**(1 - m)
     return
!
   10 if (i > 2) go to 20
     b = ipmpar(4)
     emin = ipmpar(9)
     one = real(1)
     binv = one/b
     w = b**(emin + 2)
     dpmpar = ((w * binv) * binv) * binv
     return
!
   20 ibeta = ipmpar(4)
  m = ipmpar(8)
  emax = ipmpar(10)
!
  b = ibeta
  bm1 = ibeta - 1
  one = real(1)
  z = b**(m - 1)
  w = ((z - one)*b + bm1)/(b*z)
!
  z = b**(emax - 2)
  dpmpar = ((w * z) * b) * b
  return
end
subroutine dpmult (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! DPMULT: multiplication of double precision polynomials
!
  double precision a(*), b(*), c(*)
  double precision sum
!
  lc = 1
  jmax = min (l + m - 1, n)
  do 40 j = 1,jmax
     if (j <= l) go to 10
        imin = 1 + (j - l)
        la = 1 + (l - 1)*ka
        lb = 1 + (imin - 1)*kb
        go to 20
   10    imin = 1
     la = 1 + (j - 1)*ka
     lb = 1
!
   20    imax = min (j, m)
     sum = 0.d0
     do 30 i = imin,imax
        sum = sum + a(la)*b(lb)
        la = la - ka
        lb = lb + kb
   30    continue
     c(lc) = sum
   40 lc = lc + kc
  if (jmax == n) return
!
  jmin = jmax + 1
  do 60 j = jmin,n
     c(lc) = 0.d0
   60 lc = lc + kc
  return
end
subroutine dpose (a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! DPOSE: transposing a sparse double precision matrix
!
  double precision a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1
  do 41 j = 1,np1
     ib(j) = 1
   41 continue
  return
end
subroutine dpose1 (p, a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! DPOSE1: transposing a sparse double precision matrix
!                 where the rows are interchanged
!
  integer p(m)
  double precision a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ii = p(i)
     ipmin = ia(ii)
     ipmax = ia(ii+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1
  do 41 j = 1,np1
     ib(j) = 1
   41 continue
  return
end
subroutine dppdi(ap,n,det,job)
!
!*******************************************************************************
!
!! DPPDI: determinant and inverse of a symmetric positive definite matrix
!     using the factors computed by dppco or dppfa .
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the output from dppco or dppfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        job     integer
!                = 11   both determinant and inverse.
!                = 01   inverse only.
!                = 10   determinant only.
!
!     on return
!
!        ap      the upper triangular half of the inverse .
!
!        det     double precision(2)
!                determinant of original matrix if requested.
!                otherwise not referenced.
!                determinant = det(1) * 10.0**det(2)
!                with  1.0 <= det(1) < 10.0
!                or  det(1) == 0.0 .
!
!     error condition
!
!        a division by zero will occur if the input factor contains
!        a zero on the diagonal and the inverse is requested.
!        it will not occur if the subroutines are called correctly
!        and if dpoco or dpofa has set info == 0 .
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas daxpy,dscal
!     fortran mod
!
!     internal variables
!
  integer n,job
  double precision ap(*)
  double precision det(2)
!
  double precision t
  double precision s
  integer i,ii,j,jj,jm1,j1,k,kj,kk,kp1,k1
!
!     compute determinant
!
  if (job/10 == 0) go to 70
     det(1) = 1.0d0
     det(2) = 0.0d0
     s = 10.0d0
     ii = 0
     do 50 i = 1, n
        ii = ii + i
        det(1) = ap(ii)**2*det(1)
!        ...exit
        if (det(1) == 0.0d0) go to 60
   10       if (det(1) >= 1.0d0) go to 20
           det(1) = s*det(1)
           det(2) = det(2) - 1.0d0
        go to 10
   20       continue
   30       if (det(1) < s) go to 40
           det(1) = det(1)/s
           det(2) = det(2) + 1.0d0
        go to 30
   40       continue
   50    continue
   60    continue
   70 continue
!
!     compute inverse(r)
!
  if (mod(job,10) == 0) go to 140
     kk = 0
     do 100 k = 1, n
        k1 = kk + 1
        kk = kk + k
        ap(kk) = 1.0d0/ap(kk)
        t = -ap(kk)
        call dscal(k-1,t,ap(k1),1)
        kp1 = k + 1
        j1 = kk + 1
        kj = kk + k
        if (n < kp1) go to 90
        do 80 j = kp1, n
           t = ap(kj)
           ap(kj) = 0.0d0
           call daxpy(k,t,ap(k1),1,ap(j1),1)
           j1 = j1 + j
           kj = kj + j
   80       continue
   90       continue
  100    continue
!
!        form  inverse(r) * trans(inverse(r))
!
     jj = 0
     do 130 j = 1, n
        j1 = jj + 1
        jj = jj + j
        jm1 = j - 1
        k1 = 1
        kj = j1
        if (jm1 < 1) go to 120
        do 110 k = 1, jm1
           t = ap(kj)
           call daxpy(k,t,ap(j1),1,ap(k1),1)
           k1 = k1 + k
           kj = kj + 1
  110       continue
  120       continue
        t = ap(jj)
        call dscal(j,t,ap(j1),1)
  130    continue
  140 continue
  return
end
subroutine dppfa(ap,n,info)
!
!*******************************************************************************
!
!! DPPFA factors a symmetric positive definite matrix stored in packed form.
!
!     dppfa is usually called by dppco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!     (time for dppco) = (1 + 18/n)*(time for dppfa) .
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        ap      an upper triangular matrix  r , stored in packed
!                form, so that  a = trans(r)*r .
!
!        info    integer
!                = 0  for normal return.
!                = k  if the leading minor of order  k  is not
!                     positive definite.
!
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k) = a(i,j)
!             10    continue
!             20 continue
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas ddot
!     fortran dsqrt
!
!     internal variables
!
  integer n,info
  double precision ap(*)
!
  double precision ddot,t
  double precision s
  integer j,jj,jm1,k,kj,kk
!     begin block with ...exits to 40
!
!
     jj = 0
     do 30 j = 1, n
        info = j
        s = 0.0d0
        jm1 = j - 1
        kj = jj
        kk = 0
        if (jm1 < 1) go to 20
        do 10 k = 1, jm1
           kj = kj + 1
           t = ap(kj) - ddot(k-1,ap(kk+1),1,ap(jj+1),1)
           kk = kk + k
           t = t/ap(kk)
           ap(kj) = t
           s = s + t*t
   10       continue
   20       continue
        jj = jj + j
        s = ap(jj) - s
!    ....exit
        if (s <= 0.0d0) go to 40
        ap(jj) = dsqrt(s)
   30    continue
     info = 0
   40 continue
  return
end
subroutine dppsl(ap,n,b)
!
!*******************************************************************************
!
!! DPPSL solves double precision symmetric positive definite system a * x = b
!     using the factors computed by dppco or dppfa.
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the output from dppco or dppfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        b       double precision(n)
!                the right hand side vector.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains
!        a zero on the diagonal.  technically this indicates
!        singularity but it is usually caused by improper subroutine
!        arguments.  it will not occur if the subroutines are called
!        correctly and  info == 0 .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call dppco(ap,n,rcond,z,info)
!           if (rcond is too small .or. info /= 0) go to ...
!           do 10 j = 1, p
!              call dppsl(ap,n,c(1,j))
!        10 continue
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas daxpy,ddot
!
!     internal variables
!
  integer n
  double precision ap(*),b(*)
!
  double precision ddot,t
  integer k,kb,kk
!
  kk = 0
  do 10 k = 1, n
     t = ddot(k-1,ap(kk+1),1,b(1),1)
     kk = kk + k
     b(k) = (b(k) - t)/ap(kk)
   10 continue
  do 20 kb = 1, n
     k = n + 1 - kb
     b(k) = b(k)/ap(kk)
     kk = kk - k
     t = -b(k)
     call daxpy(k-1,t,ap(kk+1),1,b(1),1)
   20 continue
  return
end
function dpsi(a)
!
!*******************************************************************************
!
!! DPSI: evaluation of the digamma function
!  for double precision arguments
!
!               ---
!
!     dpsi(a) is assigned the value 0 when the digamma function cannot
!     be computed.
!
!
!     written by Alfred Morris,
!          naval surface warfare center
!          Dahlgren, Virginia
!
!
!     the series for dpsi on the interval 0.0 to 1.0 was derived
!     by wayne fullerton (los alamos national laboratory).
!
!                                  with weighted error   5.79e-32
!                                   log weighted error  31.24
!                         significant figures required  30.93
!                              decimal places required  32.05
!
!     the series for  a >= 10  was derived by a.h. morris from
!     the chebyshev series in the slatec library obtained by wayne
!     fullerton (los alamos).
!
!
  double precision dpsi
  integer imax
  double precision a, c(42), eps, p(15), pi, s, t, x, x0, xmax, w
  double precision dcsevl, dpsi0, dpmpar
!
  data pi /3.1415926535897932384626433832795d0/
  data x0 /.46163214496836234126265954232572d0/
!
  data c(1)  / -.38057080835217921520437677667039d-01/, &
       c(2)  /  .49141539302938712748204699654277d+00/, &
       c(3)  / -.56815747821244730242892064734081d-01/, &
       c(4)  /  .83578212259143131362775650747862d-02/, &
       c(5)  / -.13332328579943425998079274172393d-02/, &
       c(6)  /  .22031328706930824892872397979521d-03/, &
       c(7)  / -.37040238178456883592889086949229d-04/, &
       c(8)  /  .62837936548549898933651418717690d-05/, &
       c(9)  / -.10712639085061849855283541747074d-05/, &
       c(10) /  .18312839465484165805731589810378d-06/
  data c(11) / -.31353509361808509869005779796885d-07/, &
       c(12) /  .53728087762007766260471919143615d-08/, &
       c(13) / -.92116814159784275717880632624730d-09/, &
       c(14) /  .15798126521481822782252884032823d-09/, &
       c(15) / -.27098646132380443065440589409707d-10/, &
       c(16) /  .46487228599096834872947319529549d-11/, &
       c(17) / -.79752725638303689726504797772737d-12/, &
       c(18) /  .13682723857476992249251053892838d-12/, &
       c(19) / -.23475156060658972717320677980719d-13/, &
       c(20) /  .40276307155603541107907925006281d-14/
  data c(21) / -.69102518531179037846547422974771d-15/, &
       c(22) /  .11856047138863349552929139525768d-15/, &
       c(23) / -.20341689616261559308154210484223d-16/, &
       c(24) /  .34900749686463043850374232932351d-17/, &
       c(25) / -.59880146934976711003011081393493d-18/, &
       c(26) /  .10273801628080588258398005712213d-18/, &
       c(27) / -.17627049424561071368359260105386d-19/, &
       c(28) /  .30243228018156920457454035490133d-20/, &
       c(29) / -.51889168302092313774286088874666d-21/, &
       c(30) /  .89027730345845713905005887487999d-22/
  data c(31) / -.15274742899426728392894971904000d-22/, &
       c(32) /  .26207314798962083136358318079999d-23/, &
       c(33) / -.44964642738220696772598388053333d-24/, &
       c(34) /  .77147129596345107028919364266666d-25/, &
       c(35) / -.13236354761887702968102638933333d-25/, &
       c(36) /  .22709994362408300091277311999999d-26/, &
       c(37) / -.38964190215374115954491391999999d-27/, &
       c(38) /  .66851981388855302310679893333333d-28/, &
       c(39) / -.11469986654920864872529919999999d-28/, &
       c(40) /  .19679385886541405920515413333333d-29/
  data c(41) / -.33764488189750979801907200000000d-30/, &
       c(42) /  .57930703193214159246677333333333d-31/
!
  data p(1)  / .833333333333333333333333333147d-03/, &
       p(2)  /-.833333333333333333333317475057d-06/, &
       p(3)  / .396825396825396825343072884056d-08/, &
       p(4)  /-.416666666666666570859890514548d-10/, &
       p(5)  / .757575757575654146210665696401d-12/, &
       p(6)  /-.210927960920616064592099772274d-13/, &
       p(7)  / .833333329719356554828382131321d-15/, &
       p(8)  /-.443259676504784387819140445894d-16/, &
       p(9)  / .305392145578967948828783519552d-17/, &
       p(10) /-.264499326810660590871410866039d-18/
  data p(11) / .280568932535744579536244004181d-19/, &
       p(12) /-.351388195869099967789469969066d-20/, &
       p(13) / .476233402067211507540059750399d-21/, &
       p(14) /-.575024569953144855161645738666d-22/, &
       p(15) / .416180125797657207803740160000d-23/
!
  imax  = huge ( imax )
  eps  = epsilon ( eps )
  xmax = dpmpar(3)
  dpsi = 0.d0
  x = a
  if (dabs(a) >= 10.d0) go to 60
!
!             evaluation of dpsi(a) for dabs(a) < 10
!
  t = 0.d0
  n = x
  n = n - 1
!
!     let t be the sum of 1/(a-j) when a >= 2
!
  if (n) 20,12,10
   10 do 11 j = 1,n
     x = x - 1.d0
     t = 1.d0/x + t
   11 continue
   12 x = x - 1.d0
  go to 40
!
!     check if 1/a can overflow
!
   20 if (dabs(a) >= 1.d-35) go to 30
  if (dabs(a)*xmax <= 1.000000001d0) return
!
!     let t be the sum of -1/(a+j) when a < 1
!
   30 t = -1.d0/a
  if (a > 0.d0) go to 40
  n = - n - 1
  if (n == 0) go to 32
  do 31 j = 1,n
     x = x + 1.d0
     if (x == 0.d0) return
     t = t - 1.d0/x
   31 continue
   32 x = (x + 0.5d0) + 0.5d0
  if (x == 0.d0) return
  t = t - 1.d0/x
!
!     compute  t + dpsi(1 + x)  for 0 <= x < 1
!
   40 if (dabs(x - x0) > 2.d-2) go to 50
     dpsi = t + dpsi0(1.d0 + x)
     return
   50 k = 42
  if (eps > 1.d-20) k = 28
  dpsi = t + dcsevl (2.d0*x - 1.d0, c, k)
  return
!
!           evaluation of dpsi(a) for dabs(a) >= 10
!
   60 if (a > 0.d0) go to 70
  t = imax
  if (dabs(a) >= dmin1(t, 1.d0/eps)) return
!
!     set w = pi*cot(pi*a) when a is negative
!
  k = dabs(a)
  t = a + k
  if (t == 0.d0) return
  if (t <= -0.5d0) t = 1.d0 + t
  t = pi*t
  w = pi*(dcos(t)/dsin(t))
  x = 1.d0 - x
!
!     compute the modified asymptotic sum
!
   70 t = (10.d0/x)**2
  s = p(15)
  do 71 j = 1,14
     l = 15 - j
     s = p(l) + t*s
   71 continue
  s = 0.5d0/x + t*s
!
!     final assembly
!
  dpsi = dlog(x) - s
  if (a < 0.d0) dpsi = dpsi - w
  return
end
function dpsi0 (x)
!
!*******************************************************************************
!
!! DPSI0: taylor series expansion of psi(x) around a zero.
!
!
!     written by a.h. morris
!        naval surface warfare center
!        Dahlgren, Virginia
!
  double precision dpsi0
  double precision a(20), h, x, w
  double precision dk1, dk2, dk3, db, db2, dx
!
  data dk1 /100442596182.d0/, dk2 /51069247913.d0/, &
       dk3 /53827985572.d0/
  data db  /68719476736.d0/
  data dx  /.28939299282041499433886199389507989269636d-32/
!
  data a(1)  / .967672245447621170427444761710d+00/, &
       a(2)  /-.442763168983592106092865281853d+00/, &
       a(3)  / .258499760955651010624401385701d+00/, &
       a(4)  /-.163942705442406527504251292747d+00/, &
       a(5)  / .107824050691262365757182948867d+00/, &
       a(6)  /-.721995612564547109261217836051d-01/, &
       a(7)  / .488042881641431072250925255079d-01/, &
       a(8)  /-.331611264748473592922583984045d-01/, &
       a(9)  / .225976482322181046596248251178d-01/, &
       a(10) /-.154247659049489591388003168412d-01/
  data a(11) / .105387916166121753881240498824d-01/, &
       a(12) /-.720453438635686824097047437040d-02/, &
       a(13) / .492678139572985344635426640268d-02/, &
       a(14) /-.336980165543932808279285672353d-02/, &
       a(15) / .230512632673492783693838028298d-02/, &
       a(16) /-.157693677143019725927093497173d-02/, &
       a(17) / .107882520191629658069191777474d-02/, &
       a(18) /-.738070938996005129566047389379d-03/, &
       a(19) / .504953265834602035177398177463d-03/, &
       a(20) /-.345468025106307699555567970882d-03/
!
!
!     set  h = x - x0  where x0 is the zero of psi(x). x0 has the
!     approximate 60 digit value ...
!
!      1.4616321449683623412 62659542325721328468 19620400644635129598
!
!     a more accurate value is given by ...
!
!            x0 = dk1/8**12 + dk2/8**24 + dk3/8**36 + dx
!
!     the following code should yield the correct value for h if a
!     binary, octal, or hexadecimal double precision arithmetic is
!     being used.
!
  db2 = db*db
  h = (((x - dk1/db) - dk2/db2) - dk3/(db*db2)) - dx
!
!
!
  n = 20
  nm1 = n - 1
  w = a(n)
  do 10 i = 1,nm1
     l = n - i
     w = a(l) + h*w
   10 continue
  dpsi0 = h*w
  return
end
subroutine dpslv (n, m, a, ka, b, kb, ierr)
!
!*******************************************************************************
!
!! DPSLV: partial pivot solution of a*x = b
!  where a is a matrix of order n and b is a matrix having n rows and m columns.
!     the solution matrix x is stored in b.
!
!     ierr is a variable that reports the status of the results.
!        ierr = 0   the equations have been solved.
!        ierr = j   the j-th pivot element was found to be 0.
!
  double precision a(ka,n), b(kb,m), p, t
!
  ierr = 0
  nm1 = n - 1
  if (nm1 == 0) go to 140
  do 80 k = 1,nm1
!
!     search for the k-th pivot element
!
     p = 0.d0
     do 10 i = k,n
        t = dabs(a(i,k))
        if (p >= t) go to 10
        p = t
        l = i
   10    continue
     if (p == 0.d0) go to 210
     if (k == l) go to 40
!
!     interchange rows k and l
!
     do 20 j = k,n
        t = a(k,j)
        a(k,j) = a(l,j)
        a(l,j) = t
   20    continue
     do 30 j = 1,m
        t = b(k,j)
        b(k,j) = b(l,j)
        b(l,j) = t
   30    continue
!
!     eliminate the coefficients of x(k) in rows i = k+1,...,n
!
   40    p = a(k,k)
     kp1 = k + 1
     do 70 i = kp1,n
        t = a(i,k)/p
        do 50 j = kp1,n
   50          a(i,j) = a(i,j) - t*a(k,j)
        do 60 j = 1,m
   60          b(i,j) = b(i,j) - t*b(k,j)
   70    continue
   80 continue
  if (a(n,n) == 0.d0) go to 220
!
!     backsolve the triangular set of equations
!
  do 120 j = 1,m
  k = n
  km1 = nm1
     do 110 l = 2,n
     b(k,j) = b(k,j)/a(k,k)
     t = b(k,j)
        do 100 i = 1,km1
  100       b(i,j) = b(i,j) - t*a(i,k)
     k = km1
  110    km1 = k - 1
  120 b(1,j) = b(1,j)/a(1,1)
  return
!
!     case when n = 1
!
 140  if (a(1,1) == 0.d0) go to 200
  do 150 j = 1,m
 150  b(1,j) = b(1,j)/a(1,1)
  return
!
!     error return
!
 200  ierr = 1
  return
 210  ierr = k
  return
 220  ierr = n
  return
end
subroutine dpsubt (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! DPSUBT: subtraction of double precision polynomials
!
  double precision a(*), b(*), c(*)
!
  la = 1
  lb = 1
  lc = 1
  do 10 i = 1,n
     c(lc) = 0.d0
     if (i <= l) c(lc) = a(la)
     if (i <= m) c(lc) = c(lc) - b(lb)
     la = la + ka
     lb = lb + kb
     lc = lc + kc
   10 continue
  return
end
subroutine dqagi(f,bound,inf,epsabs,epsrel,result,abserr, &
    neval,ier,limit,lenw,last,iwork,work)
!
!*******************************************************************************
!
!! DQAGI: integration over infinite intervals
!
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - double precision
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            bound  - double precision
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - double precision
!                     absolute accuracy requested
!
!            epsrel - double precision
!                     relative accuracy requested
!
!         on return
!            result - double precision
!                     approximation to the integral
!
!            abserr - double precision
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative, limit < 1,
!                             or lenw < 4 * limit.
!                             result, abserr, neval, last are
!                             set to zero.
!
!         dimensioning parameters
!            limit - integer
!                    dimensioning parameter for iwork
!                    limit determines the maximum number
!                    of subintervals in the partition of the given
!                    integration interval (a,b), limit >= 1.
!                    if limit < 1, the routine will end with
!                    ier = 6.
!
!            lenw  - integer
!                    dimensioning parameter for work
!                    lenw must be at least limit*4.
!                    if lenw < limit*4, the routine will end
!                    with ier = 6.
!
!            last  - integer
!                    on return, last equals the number of
!                    subintervals produced in the subdivision
!                    process, which determines the number of significant
!                    elements actually in the work arrays.
!
!         work arrays
!            iwork - integer
!                    vector of dimension at least limit, the first
!                    k elements of which contain pointers
!                    to the error estimates over the subintervals,
!                    such that work(limit*3+iwork(1)),... ,
!                    work(limit*3+iwork(k)) form a decreasing
!                    sequence, with k = last if last <= (limit/2+2), and
!                    k = limit+1-last otherwise
!
!            work  - double precision
!                    vector of dimension at least lenw
!                    on return
!                    work(1), ..., work(last) contain the left
!                     end points of the subintervals in the
!                     partition of (a,b),
!                    work(limit+1), ..., work(limit+last) contain
!                     the right end points,
!                    work(limit*2+1), ..., work(limit*2+last)
!                     contain the integral approximations over
!                     the subintervals,
!                    work(limit*3+1), ..., work(limit*3+last)
!                     contain the error estimates.
!
!        subroutines or functions needed
!              - dqagie
!              - dqk15i
!              - dqpsrt
!              - dqelg
!              - f (user provided function)
!              - dpmpar
!              - fortran dabs, dmax1, dmin1, min0
!
!
  double precision abserr,bound,epsabs,epsrel,f,result,work
  integer ier,iwork,lenw,limit,l1,l2,l3,neval
!
  dimension iwork(limit),work(lenw)
!
  external f
!
!         check validity of limit and lenw.
!
  ier = 6
  neval = 0
  last = 0
  result = 0.0d+00
  abserr = 0.0d+00
  if (limit < 1 .or. lenw  <  limit*4) return
!
!         prepare call for dqagie
!
  l1 = limit+1
  l2 = limit+l1
  l3 = limit+l2
!
  call dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, &
    neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last)
  return
end
subroutine dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, &
    neval,ier,alist,blist,rlist,elist,iord,last)
!
!*******************************************************************************
!
!! DQAGIE: integration over infinite intervals
!
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - double precision
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            bound  - double precision
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - double precision
!                     absolute accuracy requested
!
!            epsrel - double precision
!                     relative accuracy requested
!
!            limit  - integer
!                     gives an upper bound on the number of
!                     subintervals in the partition of (a,b),
!                     limit >= 1
!
!         on return
!            result - double precision
!                     approximation to the integral
!
!            abserr - double precision
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative.
!                             result, abserr, neval, last, rlist(1),
!                             elist(1) and iord(1) are set to zero.
!                             alist(1) and blist(1) are set to 0
!                             and 1 respectively.
!
!            alist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the left
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            blist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the right
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            rlist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the integral
!                     approximations on the subintervals
!
!            elist  - double precision
!                     vector of dimension at least limit,  the first
!                      last  elements of which are the moduli
!                     of the absolute error estimates on the
!                     subintervals
!
!            iord   - integer
!                     vector of dimension limit, the first k
!                     elements of which are pointers to the
!                     error estimates over the subintervals,
!                     such that elist(iord(1)), ..., elist(iord(k))
!                     form a decreasing sequence, with k = last
!                     if last <= (limit/2+2), and k = limit+1-last
!                     otherwise
!
!            last   - integer
!                     number of subintervals actually produced
!                     in the subdivision process
!
!        subroutines or functions needed
!              - dqk15i
!              - dqpsrt
!              - dqelg
!              - f (user-provided function)
!              - dpmpar
!              - fortran dabs, dmax1, dmin1, min0
!
!
  double precision abseps,abserr,alist,area,area1,area12,area2,a1, &
    a2,blist,boun,bound,b1,b2,correc,defabs,defab1,defab2,dres, &
    dpmpar,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, &
    errmax,error1,error2,erro12,errsum,ertest,f,oflow,rerr,resabs, &
    reseps,result,res3la,rlist,rlist2,small,uflow
  integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, &
    ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
  logical extrap,noext
!
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
    res3la(3),rlist(limit),rlist2(52)
!
  external f
!
!            the dimension of rlist2 is determined by the value of
!            limexp in subroutine dqelg.
!
!
!            list of major variables
!
!
!           alist     - list of left end points of all subintervals
!                       considered up to now
!           blist     - list of right end points of all subintervals
!                       considered up to now
!           rlist(i)  - approximation to the integral over
!                       (alist(i),blist(i))
!           rlist2    - array of dimension at least (limexp+2),
!                       containing the part of the epsilon table
!                       wich is still needed for further computations
!           elist(i)  - error estimate applying to rlist(i)
!           maxerr    - pointer to the interval with largest error
!                       estimate
!           errmax    - elist(maxerr)
!           erlast    - error on the interval currently subdivided
!                       (before that subdivision has taken place)
!           area      - sum of the integrals over the subintervals
!           errsum    - sum of the errors over the subintervals
!           errbnd    - requested accuracy max(epsabs,epsrel*
!                       abs(result))
!           *****1    - variable for the left subinterval
!           *****2    - variable for the right subinterval
!           last      - index for subdivision
!           nres      - number of calls to the extrapolation routine
!           numrl2    - number of elements currently in rlist2. if an
!                       appropriate approximation to the compounded
!                       integral has been obtained, it is put in
!                       rlist2(numrl2) after numrl2 has been increased
!                       by one.
!           small     - length of the smallest interval considered up
!                       to now, multiplied by 1.5
!           erlarg    - sum of the errors over the intervals larger
!                       than the smallest interval considered up to now
!           extrap    - logical variable denoting that the routine
!                       is attempting to perform extrapolation. i.e.
!                       before subdividing the smallest interval we
!                       try to decrease the value of erlarg.
!           noext     - logical variable denoting that extrapolation
!                       is no longer allowed (true-value)
!
!            machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!           oflow is the largest positive magnitude.
!
  epmach = dpmpar(1)
  uflow = dpmpar(2)
  oflow = dpmpar(3)
!
!           check epsabs and epsrel
!
!
  neval = 0
  last = 0
  result = 0.0d+00
  abserr = 0.0d+00
  alist(1) = 0.0d+00
  blist(1) = 0.1d+01
  rlist(1) = 0.0d+00
  elist(1) = 0.0d+00
  iord(1) = 0
  ier = 6
  if (epsabs < 0.0d0 .or. epsrel  <  0.0d0) go to 999
  ier = 0
  rerr = dmax1(epsrel, 50.d0*epmach, 0.5d-28)
!
!
!           first approximation to the integral
!
!
!           determine the interval to be mapped onto (0,1).
!           if inf = 2 the integral is computed as i = i1+i2, where
!           i1 = integral of f over (-infinity,0),
!           i2 = integral of f over (0,+infinity).
!
  boun = bound
  if(inf==2) boun = 0.0d+00
  call dqk15i(f,boun,inf,0.0d+00,0.1d+01,result,abserr, &
    defabs,resabs)
!
!           test on accuracy
!
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  dres = dabs(result)
  errbnd = dmax1(epsabs,rerr*dres)
  if(abserr <= 1.0d+02*epmach*defabs.and.abserr >  &
    errbnd) ier = 2
  if(limit==1) ier = 1
  if(ier/=0.or.(abserr <= errbnd.and.abserr/=resabs).or. &
    abserr==0.0d+00) go to 130
!
!           initialization
!
!
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  correc = 0.0d+00
  nrmax = 1
  nres = 0
  ktmin = 0
  numrl2 = 2
  extrap = .false.
  noext = .false.
  ierro = 0
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0
  ksgn = -1
  if(dres >= (0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1
!
!           main do-loop
!
!
  do 90 last = 2,limit
!
!           bisect the subinterval with nrmax-th largest
!           error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call dqk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1)
    call dqk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2)
!
!           improve previous approximations to integral
!           and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1==error1.or.defab2==error2)go to 15
    if(dabs(rlist(maxerr)-area12) > 0.1d-04*dabs(area12) &
    .or.erro12 < 0.99d+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
   10   if(last > 10.and.erro12 > errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
    rlist(last) = area2
    errbnd = dmax1(epsabs,rerr*dabs(area))
!
!           test for roundoff error and eventually
!           set error flag.
!
    if(iroff1+iroff2 >= 10.or.iroff3 >= 20) ier = 2
    if(iroff2 >= 5) ierro = 3
!
!           set error flag in the case that the number of
!           subintervals equals limit.
!
    if(last==limit) ier = 1
!
!           set error flag in the case of bad integrand behaviour
!           at some points of the integration range.
!
    if(dmax1(dabs(a1),dabs(b2)) <= (0.1d+01+0.1d+03*epmach)* &
    (dabs(a2)+0.1d+04*uflow)) ier = 4
!
!           append the newly-created intervals to the list.
!
    if(error2 > error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!           call subroutine qpsrt to maintain the descending ordering
!           in the list of error estimates and select the
!           subinterval with nrmax-th largest error estimate (to be
!           bisected next).
!
   30   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
    if(errsum <= errbnd) go to 115
    if(ier/=0) go to 100
    if(last==2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if(dabs(b1-a1) > small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!           test whether the interval to be bisected next is the
!           smallest interval.
!
    if(dabs(blist(maxerr)-alist(maxerr)) > small) go to 90
    extrap = .true.
    nrmax = 2
   40   if(ierro==3.or.erlarg <= ertest) go to 60
!
!           the smallest interval has the largest error.
!           before bisecting decrease the sum of the errors
!           over the larger intervals (erlarg) and perform
!           extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last > (2+limit/2)) jupbnd = limit+3-last
    do 50 k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
      if(dabs(blist(maxerr)-alist(maxerr)) > small) go to 90
      nrmax = nrmax+1
   50   continue
!
!           perform extrapolation.
!
   60   numrl2 = numrl2+1
    rlist2(numrl2) = area
    call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin > 5.and.abserr < 0.1d-02*errsum) ier = 5
    if(abseps >= abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest = dmax1(epsabs,rerr*dabs(reseps))
    if(abserr <= ertest) go to 100
!
!            prepare bisection of the smallest interval.
!
   70   if(numrl2==1) noext = .true.
    if(ier==5) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small*0.5d+00
    erlarg = errsum
    go to 90
   80   small = 0.375d+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area
   90 continue
!
!           set final result and error estimate.
!
!
  100 if(abserr==oflow) go to 115
  if((ier+ierro)==0) go to 110
  if(ierro==3) abserr = abserr+correc
  if(ier==0) ier = 3
  if(result/=0.0d+00.and.area/=0.0d+00)go to 105
  if(abserr > errsum)go to 115
  if(area==0.0d+00) go to 130
  go to 110
  105 if(abserr/dabs(result) > errsum/dabs(area)) go to 115
!
!           test on divergence
!
  110 if(ksgn==(-1).and.dmax1(dabs(result),dabs(area)) <=  &
   defabs*0.1d-01) go to 130
  if(0.1d-01 > (result/area).or.(result/area) > 0.1d+03 &
   .or.errsum > dabs(area)) ier = 6
  go to 130
!
!           compute global integral sum.
!
  115 result = 0.0d+00
  do 120 k = 1,last
    result = result+rlist(k)
  120 continue
  abserr = errsum
  130 neval = 30*last-15
  if(inf==2) neval = 2*neval
  if(ier > 2) ier=ier-1
  999 return
end
subroutine dqags(f,a,b,epsabs,epsrel,result,abserr, &
    neval,ier,limit,lenw,last,iwork,work)
!
!*******************************************************************************
!
!! DQAGS: computation of a definite integral
!
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           definite integral   i = integral of  f  over (a,b),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - double precision
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            a      - double precision
!                     lower limit of integration
!
!            b      - double precision
!                     upper limit of integration
!
!            epsabs - double precision
!                     absolute accuracy requested
!
!            epsrel - double precision
!                     relative accuracy requested
!
!         on return
!            result - double precision
!                     approximation to the integral
!
!            abserr - double precision
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                     ier > 0 abnormal termination of the routine
!                             the estimates for integral and error are
!                             less reliable. it is assumed that the
!                             requested accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more sub-
!                             divisions by increasing the value of
!                             limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a
!                             local difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the sub-
!                             ranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is detec-
!                             ted, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour
!                             occurs at some  points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             it is presumed that the requested
!                             tolerance cannot be achieved, and that the
!                             returned result is the best which can be
!                             obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted
!                             that divergence can occur with any other
!                             value of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative, limit < 1,
!                             or lenw < 4 * limit.
!                             result, abserr, neval, last are
!                             set to zero.
!
!         dimensioning parameters
!            limit - integer
!                    dimensioning parameter for iwork
!                    limit determines the maximum number
!                    of subintervals in the partition of the given
!                    integration interval (a,b), limit >= 1.
!                    if limit < 1, the routine will end with
!                    ier = 6.
!
!            lenw  - integer
!                    dimensioning parameter for work
!                    lenw must be at least limit*4.
!                    if lenw < limit*4, the routine will end
!                    with ier = 6.
!
!            last  - integer
!                    on return, last equals the number of
!                    subintervals produced in the subdivision
!                    process, which determines the number of
!                    significant elements actually in the work
!                    arrays.
!
!         work arrays
!            iwork - integer
!                    vector of dimension at least limit, the first k
!                    elements of which contain pointers
!                    to the error estimates over the subintervals
!                    such that work(limit*3+iwork(1)),... ,
!                    work(limit*3+iwork(k)) form a decreasing
!                    sequence, with k = last if last <= (limit/2+2), and
!                    k = limit+1-last otherwise
!
!            work  - double precision
!                    vector of dimension at least lenw
!                    on return
!                    work(1), ..., work(last) contain the left
!                     end points of the subintervals in the
!                     partition of (a,b),
!                    work(limit+1), ..., work(limit+last) contain
!                     the right end points,
!                    work(limit*2+1), ..., work(limit*2+last)
!                     contain the integral approximations over
!                     the subintervals,
!                    work(limit*3+1), ..., work(limit*3+last)
!                     contain the error estimates.
!
!         subroutines or functions needed
!              - dqagse
!              - dqk21
!              - dqpsrt
!              - dqelg
!              - f (user-provided function)
!              - dpmpar
!              - fortran dabs, dmax1, dmin1
!
!
  double precision a,abserr,b,epsabs,epsrel,f,result,work
  integer ier,iwork,lenw,limit,l1,l2,l3,neval
!
  dimension iwork(limit),work(lenw)
!
  external f
!
!         check validity of limit and lenw.
!
  ier = 6
  neval = 0
  last = 0
  result = 0.0d+00
  abserr = 0.0d+00
  if (limit < 1 .or. lenw  <  limit*4) return
!
!         prepare call for dqagse
!
  l1 = limit+1
  l2 = limit+l1
  l3 = limit+l2
!
  call dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, &
    ier,work(1),work(l1),work(l2),work(l3),iwork,last)
  return
end
subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr, &
    neval,ier,alist,blist,rlist,elist,iord,last)
!
!*******************************************************************************
!
!! DQAGSE: computation of a definite integral
!
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           definite integral   i = integral of  f  over (a,b),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - double precision
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            a      - double precision
!                     lower limit of integration
!
!            b      - double precision
!                     upper limit of integration
!
!            epsabs - double precision
!                     absolute accuracy requested
!
!            epsrel - double precision
!                     relative accuracy requested
!
!            limit  - integer
!                     gives an upperbound on the number of
!                     subintervals in the partition of (a,b)
!
!         on return
!            result - double precision
!                     approximation to the integral
!
!            abserr - double precision
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                     ier > 0 abnormal termination of the routine
!                             the estimates for integral and error are
!                             less reliable. it is assumed that the
!                             requested accuracy has not been achieved.
!
!                         = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more sub-
!                             divisions by increasing the value of
!                             limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a
!                             local difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the sub-
!                             ranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is detec-
!                             ted, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour
!                             occurs at some  points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             it is presumed that the requested
!                             tolerance cannot be achieved, and that the
!                             returned result is the best which can be
!                             obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted
!                             that divergence can occur with any other
!                             value of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative.
!                             result, abserr, neval, last, rlist(1),
!                             iord(1) and elist(1) are set to zero.
!                             alist(1) and blist(1) are set to a and b
!                             respectively.
!
!            alist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the left
!                     end points of the subintervals in the partition
!                     of the given integration range (a,b)
!
!            blist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the right
!                     end points of the subintervals in the partition
!                     of the given integration range (a,b)
!
!            rlist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the integral
!                     approximations on the subintervals
!
!            elist  - double precision
!                     vector of dimension at least limit, the first
!                      last  elements of which are the moduli
!                     of the absolute error estimates on the
!                     subinervals
!
!            iord   - integer
!                     vector of dimension at least limit, the first k
!                     elements of which are pointers to the error
!                     estimates over the subintervals, such
!                     that elist(iord(1)), ..., elist(iord(k))
!                     form a decreasing sequence, with k = last
!                     if last <= (limit/2+2), and k = limit+1-last
!                     otherwise
!
!            last   - integer
!                     number of subintervals actually produced in the
!                     subdivision process
!
!         subroutines or functions needed
!              - dqk21
!              - dqpsrt
!              - dqelg
!              - f (user-provided function)
!              - dpmpar
!              - fortran dabs, dmax1, dmin1
!
!
  double precision a,abseps,abserr,alist,area,area1,area12,area2, &
    a1,a2,b,blist,b1,b2,correc,defabs,defab1,defab2,dpmpar, &
    dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, &
    errmax,error1,error2,erro12,errsum,ertest,f,oflow,rerr,resabs, &
    reseps,result,res3la,rlist,rlist2,small,uflow
  integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, &
    ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
  logical extrap,noext
!
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
   res3la(3),rlist(limit),rlist2(52)
!
  external f
!
!            the dimension of rlist2 is determined by the value of
!            limexp in subroutine dqelg (rlist2 should be of dimension
!            (limexp+2) at least).
!
!            list of major variables
!
!
!           alist     - list of left end points of all subintervals
!                       considered up to now
!           blist     - list of right end points of all subintervals
!                       considered up to now
!           rlist(i)  - approximation to the integral over
!                       (alist(i),blist(i))
!           rlist2    - array of dimension at least limexp+2
!                       containing the part of the epsilon table
!                       which is still needed for further computations
!           elist(i)  - error estimate applying to rlist(i)
!           maxerr    - pointer to the interval with largest error
!                       estimate
!           errmax    - elist(maxerr)
!           erlast    - error on the interval currently subdivided
!                       (before that subdivision has taken place)
!           area      - sum of the integrals over the subintervals
!           errsum    - sum of the errors over the subintervals
!           errbnd    - requested accuracy max(epsabs,epsrel*
!                       abs(result))
!           *****1    - variable for the left interval
!           *****2    - variable for the right interval
!           last      - index for subdivision
!           nres      - number of calls to the extrapolation routine
!           numrl2    - number of elements currently in rlist2. if an
!                       appropriate approximation to the compounded
!                       integral has been obtained it is put in
!                       rlist2(numrl2) after numrl2 has been increased
!                       by one.
!           small     - length of the smallest interval considered
!                       up to now, multiplied by 1.5
!           erlarg    - sum of the errors over the intervals larger
!                       than the smallest interval considered up to now
!           extrap    - logical variable denoting that the routine
!                       is attempting to perform extrapolation
!                       i.e. before subdividing the smallest interval
!                       we try to decrease the value of erlarg.
!           noext     - logical variable denoting that extrapolation
!                       is no longer allowed (true value)
!
!            machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!           oflow is the largest positive magnitude.
!
  epmach = dpmpar(1)
  uflow = dpmpar(2)
  oflow = dpmpar(3)
!
!            check epsabs and epsrel
!
!
  neval = 0
  last = 0
  result = 0.0d+00
  abserr = 0.0d+00
  alist(1) = a
  blist(1) = b
  rlist(1) = 0.0d+00
  elist(1) = 0.0d+00
  ier = 6
  if (epsabs < 0.0d0 .or. epsrel  <  0.0d0) go to 999
  ier = 0
  rerr = dmax1(epsrel, 50.d0*epmach, 0.5d-28)
!
!           first approximation to the integral
!
!
  ierro = 0
  call dqk21(f,a,b,result,abserr,defabs,resabs,id)
  if (id /= 0) go to 999
!
!           test on accuracy.
!
  dres = dabs(result)
  errbnd = dmax1(epsabs,rerr*dres)
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  if(abserr <= 1.0d+02*epmach*defabs.and.abserr >  &
    errbnd) ier = 2
  if(limit==1) ier = 1
  if(ier/=0.or.(abserr <= errbnd.and.abserr/=resabs).or. &
    abserr==0.0d+00) go to 140
!
!           initialization
!
!
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  correc = 0.0d+00
  nrmax = 1
  nres = 0
  numrl2 = 2
  ktmin = 0
  extrap = .false.
  noext = .false.
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0
  ksgn = -1
  if(dres >= (0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1
!
!           main do-loop
!
!
  do 90 last = 2,limit
!
!           bisect the subinterval with the nrmax-th largest
!           error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call dqk21(f,a1,b1,area1,error1,resabs,defab1,ier)
    if (ier /= 0) go to 100
    call dqk21(f,a2,b2,area2,error2,resabs,defab2,ier)
!
!           improve previous approximations to integral
!           and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1==error1.or.defab2==error2) go to 15
    if(dabs(rlist(maxerr)-area12) > 0.1d-04*dabs(area12) &
    .or.erro12 < 0.99d+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
   10   if(last > 10.and.erro12 > errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
    rlist(last) = area2
    errbnd = dmax1(epsabs,rerr*dabs(area))
!
!           test for roundoff error and eventually
!           set error flag.
!
    if(iroff1+iroff2 >= 10.or.iroff3 >= 20) ier = 2
    if(iroff2 >= 5) ierro = 3
!
!           set error flag in the case that the number of
!           subintervals equals limit.
!
    if(last==limit) ier = 1
!
!           set error flag in the case of bad integrand behaviour
!           at a point of the integration range.
!
    if(dmax1(dabs(a1),dabs(b2)) <= (0.1d+01+0.1d+03*epmach)* &
    (dabs(a2)+0.1d+04*uflow)) ier = 4
!
!           append the newly-created intervals to the list.
!
    if(error2 > error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!           call subroutine qpsrt to maintain the descending ordering
!           in the list of error estimates and select the
!           subinterval with nrmax-th largest error estimate (to be
!           bisected next).
!
   30   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
! ***jump out of do-loop
    if(errsum <= errbnd) go to 115
! ***jump out of do-loop
    if(ier/=0) go to 100
    if(last==2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if(dabs(b1-a1) > small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!           test whether the interval to be bisected next is the
!           smallest interval.
!
    if(dabs(blist(maxerr)-alist(maxerr)) > small) go to 90
    extrap = .true.
    nrmax = 2
   40   if(ierro==3.or.erlarg <= ertest) go to 60
!
!           the smallest interval has the largest error.
!           before bisecting decrease the sum of the errors
!           over the larger intervals (erlarg) and perform
!           extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last > (2+limit/2)) jupbnd = limit+3-last
    do 50 k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
! ***jump out of do-loop
      if(dabs(blist(maxerr)-alist(maxerr)) > small) go to 90
      nrmax = nrmax+1
   50   continue
!
!           perform extrapolation.
!
   60   numrl2 = numrl2+1
    rlist2(numrl2) = area
    call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin > 5.and.abserr < 0.1d-02*errsum) ier = 5
    if(abseps >= abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest = dmax1(epsabs,rerr*dabs(reseps))
! ***jump out of do-loop
    if(abserr <= ertest) go to 100
!
!           prepare bisection of the smallest interval.
!
   70   if(numrl2==1) noext = .true.
    if(ier==5) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small*0.5d+00
    erlarg = errsum
    go to 90
   80   small = dabs(b-a)*0.375d+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area
   90 continue
!
!           set final result and error estimate.
!
!
  100 if(abserr==oflow) go to 115
  if(ier+ierro==0) go to 110
  if(ierro==3) abserr = abserr+correc
  if(ier==0) ier = 3
  if(result/=0.0d+00.and.area/=0.0d+00) go to 105
  if(abserr > errsum) go to 115
  if(area==0.0d+00) go to 130
  go to 110
  105 if(abserr/dabs(result) > errsum/dabs(area)) go to 115
!
!           test on divergence.
!
  110 if(ksgn==(-1).and.dmax1(dabs(result),dabs(area)) <=  &
   defabs*0.1d-01) go to 130
  if(0.1d-01 > (result/area).or.(result/area) > 0.1d+03 &
   .or.errsum > dabs(area)) ier = 6
  go to 130
!
!           compute global integral sum.
!
  115 result = 0.0d+00
  do 120 k = 1,last
     result = result+rlist(k)
  120 continue
  abserr = errsum
  130 if(ier > 2) ier = ier-1
  140 neval = 42*last-21
  999 return
end
subroutine dqdcrt (a, zr, zi)
!
!*******************************************************************************
!
!! DQDCRT computes the roots of a quadratic polynomial
!                a(1) + a(2)*z + a(3)*z**2
!     and stores the results in zr and zi. it is assumed that
!     a(3) is nonzero.
!
!
  double precision a(3), zr(3), zi(3)
  double precision d, eps, r, w
  double precision dpmpar
!
!
!     ***** eps is a machine dependent constant. eps is the
!           smallest number such that 1.d0 + eps > 1.d0.
!
           eps = epsilon ( eps )
!
!
  if (a(1) == 0.d0) go to 40
  d = a(2)*a(2) - 4.d0*a(1)*a(3)
  if (dabs(d) <= 2.d0*eps*a(2)*a(2)) go to 20
  r = dsqrt(dabs(d))
  if (d < 0.d0) go to 30
!
!                 distinct real roots
!
  zi(1) = 0.d0
  zi(2) = 0.d0
  if (a(2) /= 0.d0) go to 10
     zr(1) = dabs(0.5d0*r/a(3))
     zr(2) = -zr(1)
     return
   10 w = -(a(2) + dsign(r,a(2)))
  zr(1) = 2.d0*a(1)/w
  zr(2) = 0.5d0*w/a(3)
  return
!
!                  equal real roots
!
   20 zr(1) = -0.5d0*a(2)/a(3)
  zr(2) = zr(1)
  zi(1) = 0.d0
  zi(2) = 0.d0
  return
!
!                   complex roots
!
   30 zr(1) = -0.5d0*a(2)/a(3)
  zr(2) = zr(1)
  zi(1) = dabs(0.5d0*r/a(3))
  zi(2) = -zi(1)
  return
!
!                 case when a(1) = 0
!
   40 zr(1) = 0.d0
  zr(2) = -a(2)/a(3)
  zi(1) = 0.d0
  zi(2) = 0.d0
  return
end
subroutine dqelg(n,epstab,result,abserr,res3la,nres)
!
!*******************************************************************************
!
!! DQELG implements the epsilon algorithm.
!
!
!
! 1.        dqelg
!           epsilon algorithm
!              standard fortran subroutine
!              double precision version
!
! 2.        purpose
!              the routine determines the limit of a given sequence of
!              approximations, by means of the epsilon algorithm
!              of p. wynn.
!              an estimate of the absolute error is also given.
!              the condensed epsilon table is computed. only those
!              elements needed for the computation of the next diagonal
!              are preserved.
!
! 3.        calling sequence
!              call dqelg(n,epstab,result,abserr,res3la,nres)
!
!           parameters
!              n      - integer
!                       epstab(n) contains the new element in the
!                       first column of the epsilon table.
!
!              epstab - double precision
!                       vector of dimension 52 containing the
!                       elements of the two lower diagonals of
!                       the triangular epsilon table
!                       the elements are numbered starting at the
!                       right-hand corner of the triangle.
!
!              result - double precision
!                       resulting approximation to the integral
!
!              abserr - double precision
!                       estimate of the absolute error computed from
!                       result and the 3 previous results
!
!              res3la - double precision
!                       vector of dimension 3 containing the last 3
!                       results
!
!              nres   - integer
!                       number of calls to the routine
!                       (should be zero at first call)
!
! 4.        subroutines or functions needed
!                     - dpmpar
!                     - fortran dabs, dmax
!
  double precision abserr,delta1,delta2,delta3,dpmpar, &
    epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, &
    oflow,res,result,res3la,ss,tol1,tol2,tol3
  integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num
  dimension epstab( *),res3la(*)
!
!           list of major variables
!
!
!           e0     - the 4 elements on which the
!           e1       computation of a new element in
!           e2       the epsilon table is based
!           e3                 e0
!                        e3    e1    new
!                              e2
!           newelm - number of elements to be computed in the new
!                    diagonal
!           error  - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
!           result - the element in the new diagonal with least value
!                    of error
!
!           machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           oflow is the largest positive magnitude.
!           limexp is the maximum number of elements the epsilon
!           table can contain. if this number is reached, the upper
!           diagonal of the epsilon table is deleted.
!
!***first executable statement dqelg
  epmach = dpmpar(1)
  oflow = dpmpar(3)
  nres = nres+1
  abserr = oflow
  result = epstab(n)
  if(n < 3) go to 100
  limexp = 50
  epstab(n+2) = epstab(n)
  newelm = (n-1)/2
  epstab(n) = oflow
  num = n
  k1 = n
  do 40 i = 1,newelm
    k2 = k1-1
    k3 = k1-2
    res = epstab(k1+2)
    e0 = epstab(k3)
    e1 = epstab(k2)
    e2 = res
    e1abs = dabs(e1)
    delta2 = e2-e1
    err2 = dabs(delta2)
    tol2 = dmax1(dabs(e2),e1abs)*epmach
    delta3 = e1-e0
    err3 = dabs(delta3)
    tol3 = dmax1(e1abs,dabs(e0))*epmach
    if(err2 > tol2.or.err3 > tol3) go to 10
!
!           if e0, e1 and e2 are equal to within machine
!           accuracy, convergence is assumed.
!           result = e2
!           abserr = dabs(e1-e0)+dabs(e2-e1)
!
    result = res
    abserr = err2+err3
! ***jump out of do-loop
    go to 100
   10   e3 = epstab(k1)
    epstab(k1) = e1
    delta1 = e1-e3
    err1 = dabs(delta1)
    tol1 = dmax1(e1abs,dabs(e3))*epmach
!
!           if two elements are very close to each other, omit
!           a part of the table by adjusting the value of n
!
    if(err1 <= tol1.or.err2 <= tol2.or.err3 <= tol3) go to 20
    ss = 0.1d+01/delta1+0.1d+01/delta2-0.1d+01/delta3
    epsinf = dabs(ss*e1)
!
!           test to detect irregular behaviour in the table, and
!           eventually omit a part of the table adjusting the value
!           of n.
!
    if(epsinf > 0.1d-03) go to 30
   20   n = i+i-1
! ***jump out of do-loop
    go to 50
!
!           compute a new element and eventually adjust
!           the value of result.
!
   30   res = e1+0.1d+01/ss
    epstab(k1) = res
    k1 = k1-2
    error = err2+dabs(res-e2)+err3
    if(error > abserr) go to 40
    abserr = error
    result = res
   40 continue
!
!           shift the table.
!
   50 if(n==limexp) n = 2*(limexp/2)-1
  ib = 1
  if((num/2)*2==num) ib = 2
  ie = newelm+1
  do 60 i=1,ie
    ib2 = ib+2
    epstab(ib) = epstab(ib2)
    ib = ib2
   60 continue
  if(num==n) go to 80
  indx = num-n+1
  do 70 i = 1,n
    epstab(i)= epstab(indx)
    indx = indx+1
   70 continue
   80 if(nres >= 4) go to 90
  res3la(nres) = result
  abserr = oflow
  go to 100
!
!           compute error estimate
!
   90 abserr = dabs(result-res3la(3))+dabs(result-res3la(2)) &
    +dabs(result-res3la(1))
  res3la(1) = res3la(2)
  res3la(2) = res3la(3)
  res3la(3) = result
  100 abserr = dmax1(abserr,0.5d+01*epmach*dabs(result))
  return
end
subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
!
!*******************************************************************************
!
!! DQK15I approximates an integral on an infinite interval.
!
!
! 1.        dqk15i
!           integration rule
!              standard fortran subroutine
!              double precision version
!
! 2.        purpose
!              the original (infinite) integration range is mapped
!              onto the interval (0,1) and (a,b) is a part of (0,1).
!              it is the purpose to compute
!              i = integral of transformed integrand over (a,b),
!              j = integral of abs(transformed integrand) over (a,b).
!
! 3.        calling sequence
!              call dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
!
!           parameters
!            on entry
!              f      - double precision
!                       function subprogram defining the integrand
!                       function f(x). the actual name for f needs
!                       to be declared e x t e r n a l in the
!                       calling program.
!
!              boun   - double precision
!                       finite bound of original integration
!                       range (set to zero if inf = +2)
!
!              inf    - integer
!                       if inf = -1, the original interval is
!                                   (-infinity,bound),
!                       if inf = +1, the original interval is
!                                   (bound,+infinity),
!                       if inf = +2, the original interval is
!                                   (-infinity,+infinity) and
!                       the integral is computed as the sum of two
!                       integrals, one over (-infinity,0)
!                       and one over (0,+infinity).
!
!              a      - double precision
!                       lower limit for integration over subrange
!                       of (0,1)
!
!              b      - double precision
!                       upper limit for integration over subrange
!                       of (0,1)
!
!            on return
!              result - double precision
!                       approximation to the integral i
!                       result is computed by applying the 15-point
!                       kronrod rule(resk) obtained by optimal
!                       addition of abscissae to the 7-point gauss
!                       rule(resg).
!
!              abserr - double precision
!                       estimate of the modulus of the absolute error,
!                       which should equal or exceed abs(i-result)
!
!              resabs - double precision
!                       approximation to the integral j
!
!              resasc - double precision
!                       approximation to the integral of
!                       abs((transformed integrand)-i/(b-a))
!                       over (a,b)
!
! 4.        subroutines or functions needed
!                 - f (user-provided function)
!                 - dpmpar
!                 - fortran dabs, dmax1, dmin1, min0
!
!.........
!
  double precision a,absc,absc1,absc2,abserr,b,boun,centr, &
    dinf,dpmpar,epmach,f,fc,fsum,fval1,fval2,fv1, &
    fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2, &
    uflow,wg,wgk,xgk
  integer inf,j,min0
  external f
!
  dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
!
!           the abscissae and weights are supplied for the interval
!           (-1,1).  because of symmetry only the positive abscissae and
!           their corresponding weights are given.
!
!           xgk    - abscissae of the 15-point kronrod rule
!                    xgk(2), xgk(4), ... abscissae of the 7-point
!                    gauss rule
!                    xgk(1), xgk(3), ...  abscissae which are optimally
!                    added to the 7-point gauss rule
!
!           wgk    - weights of the 15-point kronrod rule
!
!           wg     - weights of the 7-point gauss rule, corresponding
!                    to the abscissae xgk(2), xgk(4), ...
!                    wg(1), wg(3), ... are set to zero.
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), &
    xgk(8)/ &
       0.991455371120812639206854697526d+00, &
       0.949107912342758524526189684048d+00, &
       0.864864423359769072789712788641d+00, &
       0.741531185599394439863864773281d+00, &
       0.586087235467691130294144838259d+00, &
       0.405845151377397166906606412077d+00, &
       0.207784955007898467600689403773d+00, &
       0.000000000000000000000000000000d+00/
!
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), &
    wgk(8)/ &
       0.229353220105292249637320080590d-01, &
       0.630920926299785532907006631892d-01, &
       0.104790010322250183839876322542d+00, &
       0.140653259715525918745189590510d+00, &
       0.169004726639267902826583426599d+00, &
       0.190350578064785409913256402421d+00, &
       0.204432940075298892414161999235d+00, &
       0.209482141084727828012999174892d+00/
!
  data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ &
       0.0d+00,    0.129484966168869693270611432679d+00, &
       0.0d+00,    0.279705391489276667901467771424d+00, &
       0.0d+00,    0.381830050505118944950369775489d+00, &
       0.0d+00,    0.417959183673469387755102040816d+00/
!
!
!           list of major variables
!
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc*  - abscissa
!           tabsc* - transformed abscissa
!           fval*  - function value
!           resg   - result of the 7-point gauss formula
!           resk   - result of the 15-point kronrod formula
!           reskh  - approximation to the mean value of the transformed
!                    integrand over (a,b), i.e. to i/(b-a)
!
!           machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!
  epmach = dpmpar(1)
  uflow = dpmpar(2)
  dinf = min (1,inf)
!
  centr = 0.5d+00*(a+b)
  hlgth = 0.5d+00*(b-a)
  tabsc1 = boun+dinf*(0.1d+01-centr)/centr
  fval1 = f(tabsc1)
  if(inf==2) fval1 = fval1+f(-tabsc1)
  fc = (fval1/centr)/centr
!
!           compute the 15-point kronrod approximation to
!           the integral, and estimate the error.
!
  resg = wg(8)*fc
  resk = wgk(8)*fc
  resabs = dabs(resk)
  do 10 j=1,7
    absc = hlgth*xgk(j)
    absc1 = centr-absc
    absc2 = centr+absc
    tabsc1 = boun+dinf*(0.1d+01-absc1)/absc1
    tabsc2 = boun+dinf*(0.1d+01-absc2)/absc2
    fval1 = f(tabsc1)
    fval2 = f(tabsc2)
    if(inf==2) fval1 = fval1+f(-tabsc1)
    if(inf==2) fval2 = fval2+f(-tabsc2)
    fval1 = (fval1/absc1)/absc1
    fval2 = (fval2/absc2)/absc2
    fv1(j) = fval1
    fv2(j) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(j)*fsum
    resabs = resabs+wgk(j)*(dabs(fval1)+dabs(fval2))
   10 continue
  reskh = resk*0.5d+00
  resasc = wgk(8)*dabs(fc-reskh)
  do 20 j=1,7
    resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh))
   20 continue
  result = resk*hlgth
  resasc = resasc*hlgth
  resabs = resabs*hlgth
  abserr = dabs((resk-resg)*hlgth)
  if(resasc/=0.0d+00.and.abserr/=0.d0) abserr = resasc* &
   dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00)
  if(resabs > uflow/(0.5d+02*epmach)) abserr = dmax1 &
   ((epmach*0.5d+02)*resabs,abserr)
  return
end
subroutine dqk21(f,a,b,result,abserr,resabs,resasc,isig)
!
!*******************************************************************************
!
!! DQK21 approximates an integral over a finite interval.
!
! 1.        dqk21
!           integration rules
!              standard fortran subroutine
!              double precision version
!
! 2.        purpose
!              to compute i = integral of f over (a,b), with error
!                             estimate
!                         j = integral of abs(f) over (a,b)
!
! 3.        calling sequence
!              call dqk21(f,a,b,result,abserr,resabs,resasc,isig)
!
!           parameters
!            on entry
!              f      - double precision
!                       function subprogram defining the integrand
!                       function f(x). the actual name for f needs
!                       to be declared e x t e r n a l in the
!                       calling program.
!
!              a      - double precision
!                       lower limit of integration
!
!              b      - double precision
!                       upper limit of integration
!
!            on return
!              result - double precision
!                       approximation to the integral i
!                       result is computed by applying the 21-point
!                       kronrod rule (resk) obtained by optimal
!                       addition of abscissae to the 10-point gauss
!                       rule (resg).
!
!              abserr - double precision
!                       estimate of the modulus of the absolute error,
!                       which should not exceed abs(i-result)
!
!              resabs - double precision
!                       approximation to the integral j
!
!              resasc - double precision
!                       approximation to the integral of abs(f-i/(b-a))
!                       over (a,b)
!
!              isig   - integer
!                       isig=0  the integral was approximated.
!                       isig=5  the interval (a,b) is too short.
!                               the integral cannot be computed.
!
! 4.        subroutines or functions needed
!                 - f (user-provided function)
!                 - dpmpar
!                 - fortran dabs, dmax1, dmin1
!
!.........
!
  double precision a,absc,abserr,b,centr,dhlgth,dpmpar,epmach,f,fc, &
    fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resg,resk,reskh,result, &
    uflow,wg,wgk,xgk,resasc
  integer isig,j,jtw,jtwm1
  external f
!
  dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11)
!
!           the abscissae and weights are given for the interval (-1,1).
!           because of symmetry only the positive abscissae and their
!           corresponding weights are given.
!
!           xgk    - abscissae of the 21-point kronrod rule
!                    xgk(2), xgk(4), ...  abscissae of the 10-point
!                    gauss rule
!                    xgk(1), xgk(3), ...  abscissae which are optimally
!                    added to the 10-point gauss rule
!
!           wgk    - weights of the 21-point kronrod rule
!
!           wg     - weights of the 10-point gauss rule
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), &
    xgk(8),xgk(9),xgk(10),xgk(11)/ &
       0.995657163025808080735527280689d+00, &
       0.973906528517171720077964012084d+00, &
       0.930157491355708226001207180060d+00, &
       0.865063366688984510732096688423d+00, &
       0.780817726586416897063717578345d+00, &
       0.679409568299024406234327365115d+00, &
       0.562757134668604683339000099273d+00, &
       0.433395394129247190799265943166d+00, &
       0.294392862701460198131126603104d+00, &
       0.148874338981631210884826001130d+00, &
       0.000000000000000000000000000000d+00/
!
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), &
    wgk(8),wgk(9),wgk(10),wgk(11)/ &
       0.116946388673718742780643960622d-01, &
       0.325581623079647274788189724594d-01, &
       0.547558965743519960313813002446d-01, &
       0.750396748109199527670431409162d-01, &
       0.931254545836976055350654650834d-01, &
       0.109387158802297641899210590326d+00, &
       0.123491976262065851077958109831d+00, &
       0.134709217311473325928054001772d+00, &
       0.142775938577060080797094273139d+00, &
       0.147739104901338491374841515972d+00, &
       0.149445554002916905664936468390d+00/
!
  data wg(1),wg(2),wg(3),wg(4),wg(5)/ &
       0.666713443086881375935688098933d-01, &
       0.149451349150580593145776339658d+00, &
       0.219086362515982043995534934228d+00, &
       0.269266719309996355091226921569d+00, &
       0.295524224714752870173892994651d+00/
!
!
!           list of major variables
!
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc   - abscissa
!           fval*  - function value
!           resg   - result of the 10-point gauss formula
!           resk   - result of the 21-point kronrod formula
!           reskh  - approximation to the mean value of f over (a,b),
!                    i.e. to i/(b-a)
!
!
!           machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!
  epmach = dpmpar(1)
  uflow = dpmpar(2)
!
  centr = 0.5d+00*(a+b)
  hlgth = 0.5d+00*(b-a)
  dhlgth = dabs(hlgth)
!
!             check if the interval (a,b) is too short
!
  isig = 5
  absc = dabs(centr) + dhlgth*0.14d+00
  if (absc == dabs(centr)) return
!
!           compute the 21-point kronrod approximation to
!           the integral, and estimate the absolute error.
!
  isig = 0
  resg = 0.0d+00
  fc = f(centr)
  resk = wgk(11)*fc
  resabs = dabs(resk)
  do 10 j=1,5
    jtw = 2*j
    absc = hlgth*xgk(jtw)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtw) = fval1
    fv2(jtw) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(jtw)*fsum
    resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2))
   10 continue
  do 15 j = 1,5
    jtwm1 = 2*j-1
    absc = hlgth*xgk(jtwm1)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtwm1) = fval1
    fv2(jtwm1) = fval2
    fsum = fval1+fval2
    resk = resk+wgk(jtwm1)*fsum
    resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2))
   15 continue
  reskh = resk*0.5d+00
  resasc = wgk(11)*dabs(fc-reskh)
  do 20 j=1,10
    resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh))
   20 continue
  result = resk*hlgth
  resabs = resabs*dhlgth
  resasc = resasc*dhlgth
  abserr = dabs((resk-resg)*hlgth)
  if(resasc/=0.0d+00.and.abserr/=0.0d+00) &
    abserr = resasc*dmin1(0.1d+01, &
    (0.2d+03*abserr/resasc)**1.5d+00)
  if(resabs > uflow/(0.5d+02*epmach)) abserr = dmax1 &
    ((epmach*0.5d+02)*resabs,abserr)
  return
end
subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
!
!*******************************************************************************
!
!! DQPSRT maintains the sorted order of the local error estimates.
!
! 1.        dqpsrt
!           ordering routine
!              standard fortran subroutine
!              double precision version
!
! 2.        purpose
!              this routine maintains the descending ordering
!              in the list of the local error estimates resulting from
!              the interval subdivision process. at each call two error
!              estimates are inserted using the sequential search
!              method, top-down for the largest error estimate
!              and bottom-up for the smallest error estimate.
!
! 3.        calling sequence
!              call dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
!
!           parameters (meaning at output)
!              limit  - integer
!                       maximum number of error estimates the list
!                       can contain
!
!              last   - integer
!                       number of error estimates currently
!                       in the list
!
!              maxerr - integer
!                       maxerr points to the nrmax-th largest error
!                       estimate currently in the list
!
!              ermax  - double precision
!                       nrmax-th largest error estimate
!                       ermax = elist(maxerr)
!
!              elist  - double precision
!                       vector of dimension last containing
!                       the error estimates
!
!              iord   - integer
!                       vector of dimension last, the first k
!                       elements of which contain pointers
!                       to the error estimates, such that
!                       elist(iord(1)),... , elist(iord(k))
!                       form a decreasing sequence, with
!                       k = last if last <= (limit/2+2), and
!                       k = limit+1-last otherwise
!
!              nrmax  - integer
!                       maxerr = iord(nrmax)
!
  double precision elist,ermax,errmax,errmin
  integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, &
    nrmax
  dimension elist(last),iord(last)
!
!           check whether the list contains more than
!           two error estimates.
!
  if(last > 2) go to 10
  iord(1) = 1
  iord(2) = 2
  go to 90
!
!           this part of the routine is only executed
!           if, due to a difficult integrand, subdivision
!           increased the error estimate. in the normal case
!           the insert procedure should start after the
!           nrmax-th largest error estimate.
!
   10 errmax = elist(maxerr)
  if(nrmax==1) go to 30
  ido = nrmax-1
  do 20 i = 1,ido
    isucc = iord(nrmax-1)
! ***jump out of do-loop
    if(errmax <= elist(isucc)) go to 30
    iord(nrmax) = isucc
    nrmax = nrmax-1
   20    continue
!
!           compute the number of elements in the list to
!           be maintained in descending order. this number
!           depends on the number of subdivisions still
!           allowed.
!
   30 jupbn = last
  if(last > (limit/2+2)) jupbn = limit+3-last
  errmin = elist(last)
!
!           insert errmax by traversing the list top-down,
!           starting comparison from the element elist(iord(nrmax+1)).
!
  jbnd = jupbn-1
  ibeg = nrmax+1
  if(ibeg > jbnd) go to 50
  do 40 i=ibeg,jbnd
    isucc = iord(i)
! ***jump out of do-loop
    if(errmax >= elist(isucc)) go to 60
    iord(i-1) = isucc
   40 continue
   50 iord(jbnd) = maxerr
  iord(jupbn) = last
  go to 90
!
!           insert errmin by traversing the list bottom-up.
!
   60 iord(i-1) = maxerr
  k = jbnd
  do 70 j=i,jbnd
    isucc = iord(k)
    if(errmin < elist(isucc)) go to 80
    iord(k+1) = isucc
    k = k-1
   70 continue
  iord(i) = last
  go to 90
   80 iord(k+1) = last
!
!           set maxerr and ermax.
!
   90 maxerr = iord(nrmax)
  ermax = elist(maxerr)
  return
end
subroutine dqtcrt (a, zr, zi)
!
!*******************************************************************************
!
!! DQTCRT computes the roots of a real quartic polynomial
!               a(1) + a(2)*z + ... + a(5)*z**4
!         and stores the results in zr and zi. it is assumed
!         that a(5) is nonzero.
!
!
!     written by alfred h. morris
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  double precision a(5), zr(4), zi(4)
  double precision b, b2, c, d, e, h, p, q, r, t, temp(4), &
                   u, v, v1, v2, w(2), x, x1, x2, x3
!
  if (a(1) == 0.d0) go to 100
  b = a(4)/(4.d0*a(5))
  c = a(3)/a(5)
  d = a(2)/a(5)
  e = a(1)/a(5)
  b2 = b*b
!
  p = 0.5d0*(c - 6.d0*b2)
  q = d - 2.d0*b*(c - 4.d0*b2)
  r = b2*(c - 3.d0*b2) - b*d + e
!
!          solve the resolvent cubic equation. the cubic has
!          at least one nonnegative real root. if w1, w2, w3
!          are the roots of the cubic then the roots of the
!          originial equation are
!
!             z = -b + csqrt(w1) + csqrt(w2) + csqrt(w3)
!
!          where the signs of the square roots are chosen so
!          that csqrt(w1) * csqrt(w2) * csqrt(w3) = -q/8.
!
  temp(1) = -q*q/64.d0
  temp(2) = 0.25d0*(p*p - r)
  temp(3) =  p
  temp(4) = 1.d0
  call dcbcrt (temp, zr, zi)
  if (zi(2) /= 0.d0) go to 60
!
!               the resolvent cubic has only real roots
!                reorder the roots in increasing order
!
  x1 = zr(1)
  x2 = zr(2)
  x3 = zr(3)
  if (x1 <= x2) go to 10
     t = x1
     x1 = x2
     x2 = t
   10 if (x2 <= x3) go to 20
     t = x2
     x2 = x3
     x3 = t
  if (x1 <= x2) go to 20
     t = x1
     x1 = x2
     x2 = t
!
   20 u = 0.d0
  if (x3 > 0.d0) u = dsqrt(x3)
  if (x2 <= 0.d0) go to 41
  if (x1 >= 0.d0) go to 30
  if (dabs(x1) > x2) go to 40
  x1 = 0.d0
!
   30 x1 = dsqrt(x1)
  x2 = dsqrt(x2)
  if (q > 0.d0) x1 = -x1
  zr(1) = (( x1 + x2) + u) - b
  zr(2) = ((-x1 - x2) + u) - b
  zr(3) = (( x1 - x2) - u) - b
  zr(4) = ((-x1 + x2) - u) - b
  call daord (zr, 4)
  if (dabs(zr(1)) >= 0.1d0*dabs(zr(4))) go to 31
     t = zr(2)*zr(3)*zr(4)
     if (t /= 0.d0) zr(1) = e/t
   31 zi(1) = 0.d0
  zi(2) = 0.d0
  zi(3) = 0.d0
  zi(4) = 0.d0
  return
!
   40 v1 = dsqrt(dabs(x1))
  v2 = 0.d0
  go to 50
   41 v1 = dsqrt(dabs(x1))
  v2 = dsqrt(dabs(x2))
  if (q < 0.d0) u = -u
!
   50 zr(1) = -u - b
  zi(1) = v1 - v2
  zr(2) =  zr(1)
  zi(2) = -zi(1)
  zr(3) =  u - b
  zi(3) = v1 + v2
  zr(4) =  zr(3)
  zi(4) = -zi(3)
  return
!
!  The resolvent cubic has complex roots
!
   60 t = zr(1)
  x = 0.d0
  if (t) 61,70,62
   61 h = dabs(zr(2)) + dabs(zi(2))
  if (dabs(t) <= h) go to 70
  go to 80
   62 x = dsqrt(t)
  if (q > 0.d0) x = -x
!
   70 w(1) = zr(2)
  w(2) = zi(2)
  call dcsqrt (w, w)
  u = 2.d0*w(1)
  v = 2.d0*dabs(w(2))
  t =  x - b
  x1 = t + u
  x2 = t - u
  if (dabs(x1) <= dabs(x2)) go to 71
     t = x1
     x1 = x2
     x2 = t
   71 u = -x - b
  h = u*u + v*v
  if (x1*x1 < 1.d-2*dmin1(x2*x2,h)) x1 = e/(x2*h)
  zr(1) = x1
  zr(2) = x2
  zi(1) = 0.d0
  zi(2) = 0.d0
  zr(3) =  u
  zr(4) =  u
  zi(3) =  v
  zi(4) = -v
  return
!
   80 v = dsqrt(dabs(t))
  zr(1) = -b
  zr(2) = -b
  zr(3) = -b
  zr(4) = -b
  zi(1) =  v
  zi(2) = -v
  zi(3) =  v
  zi(4) = -v
  return
!
!                         case when a(1) = 0
!
  100 zr(1) = 0.d0
  zi(1) = 0.d0
  call dcbcrt(a(2), zr(2), zi(2))
  return
end
subroutine drcvl1 (x, y, errtol, rc, ierr)
!
!*******************************************************************************
!
!! DRCVL1 evaluates an elliptic integral.
!
!
!          this subroutine computes the integral
!
!          rc(x,y) = integral from zero to infinity of
!
!                              -1/2     -1
!                    (1/2)(t+x)    (t+y)  dt,
!
!          where x is nonnegative and y is positive.  the duplication
!          theorem is iterated until the variables are nearly equal,
!          and the function is then expanded in taylor series to fifth
!          order.  logarithmic, inverse circular, and inverse hyper-
!          bolic functions can be expressed in terms of rc.  reference.
!          b. c. carlson, computing elliptic integrals by duplication,
!          numer. math. 33 (1979), 1-16.  coded by b. c. carlson and
!          elaine m. notis, ames laboratory-doe, iowa state university,
!          ames, iowa 50011.  march 1, 1980. modified by a.h. morris
!          (nswc).
!
!
  integer ierr
  double precision rc,c1,c2,errtol,lamda,lolim
  double precision mu,s,sn,uplim,x,xn,y,yn
  double precision dpmpar
!
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the machine minimum multiplied by 5.
!          uplim is not greater than the machine maximum divided by 5.
!
                  lolim = 5.0d0 * dpmpar(2)
                  uplim = 0.2d0 * dpmpar(3)
!
!          input ...
!
!          x and y are the variables in the integral rc(x,y).
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          16 * errtol ** 6 / (1 - 2 * errtol).
!
!          output ...
!
!          rc is the value of the integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x or y is negative, or y = 0.
!               ierr = 2  x+y is too small.
!               ierr = 3  x or y is too large.
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (x < 0.d0  .or.  y <= 0.d0) go to 100
  if ((x + y) < lolim) go to 110
  if (dmax1(x,y) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
!
   10 mu = (xn + yn + yn) / 3.d0
  sn = (yn + mu) / mu - 2.d0
  if (dabs(sn) < errtol) go to 20
  lamda = 2.d0 * dsqrt(xn) * dsqrt(yn) + yn
  xn = (xn + lamda) * 0.25d0
  yn = (yn + lamda) * 0.25d0
  go to 10
!
   20 c1 = 1.d0 / 7.d0
  c2 = 9.d0 / 22.d0
  s = sn * sn * (0.3d0 + sn * (c1 + sn * (0.375d0 + sn * c2)))
  rc = (1.d0 + s) / dsqrt(mu)
  return
!
!                      error return
!
  100 rc = 0.d0
  ierr = 1
  return
  110 rc = 0.d0
  ierr = 2
  return
  120 rc = 0.d0
  ierr = 3
  return
end
subroutine drdval (x, y, z, rd, ierr)
!
!*******************************************************************************
!
!! DRDVAL computes the incomplete elliptic integral of the second kind
!
!          rd(x,y,z) = integral from zero to infinity of
!
!                                -1/2     -1/2     -3/2
!                      (3/2)(t+x)    (t+y)    (t+z)    dt,
!
!          where x and y are nonnegative, x + y is positive, and z is
!          positive.  if x or y is zero, the integral is complete.
!          the duplication theorem is iterated until the variables are
!          nearly equal, and the function is then expanded in taylor
!          series to fifth order.  reference. b. c. carlson, computing
!          elliptic integrals by duplication, numer. math. 33 (1979),
!          1-16.  coded by b. c. carlson and elaine m. notis, ames
!          laboratory-doe, iowa state university, ames, iowa 50011.
!          march 1, 1980. modified by a.h. morris (nswc).
!
!
  integer ierr
  double precision rd,c1,c2,c3,c4,ea,eb,ec,ed,ef,epslon,errtol,lamda
  double precision lolim,mu,power4,sigma,s1,s2,uplim,x,xn,xndev
  double precision xnroot,y,yn,yndev,ynroot,z,zn,zndev,znroot
  double precision dpmpar
!
!
!          input ...
!
!          x, y, and z are the variables in the integral rd(x,y,z).
!
!          output ...
!
!          rd is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, or z is negative.
!               ierr = 2  x+y or z is too small.
!               ierr = 3  x, y, or z is too large.
!
!
!
!          machine dependent parameters ...
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          3 * errtol ** 6 / (1 - errtol) ** 3/2.
!
          errtol = (.28 * sngl(dpmpar(1)))**(1.0/6.0)
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than 2 / (machine maximum) ** (2/3).
!          uplim is not greater than (0.1 * errtol / machine
!          minimum) ** (2/3).
!
          mu = -2.d0/3.d0
          lolim = 2.00000000001d0 * dpmpar(3) ** mu
          uplim = (10.d0 * dpmpar(2) / errtol) ** mu
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (dmin1(x,y,z) < 0.d0) go to 100
  if (dmin1(x+y,z) < lolim) go to 110
  if (dmax1(x,y,z) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
  sigma = 0.d0
  power4 = 1.d0
!
   10 mu = (xn + yn + 3.d0 * zn) * 0.2d0
  xndev = (mu - xn) / mu
  yndev = (mu - yn) / mu
  zndev = (mu - zn) / mu
  epslon = dmax1(dabs(xndev),dabs(yndev),dabs(zndev))
  if (epslon < errtol) go to 20
  xnroot = dsqrt(xn)
  ynroot = dsqrt(yn)
  znroot = dsqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  sigma = sigma + power4 / (znroot * (zn + lamda))
  power4 = power4 * 0.25d0
  xn = (xn + lamda) * 0.25d0
  yn = (yn + lamda) * 0.25d0
  zn = (zn + lamda) * 0.25d0
  go to 10
!
   20 c1 = 3.d0 / 14.d0
  c2 = 1.d0 / 6.d0
  c3 = 9.d0 / 22.d0
  c4 = 3.d0 / 26.d0
  ea = xndev * yndev
  eb = zndev * zndev
  ec = ea - eb
  ed = ea - 6.d0 * eb
  ef = ed + ec + ec
  s1 = ed * (- c1 + 0.25d0 * c3 * ed - 1.5d0 * c4 * zndev * ef)
  s2 = zndev * (c2 * ef + zndev * (- c3 * ec + zndev * c4 * ea))
  rd = 3.d0 * sigma + power4 * (1.d0 + s1 + s2) / (mu * dsqrt(mu))
  return
!
!                        error return
!
  100 rd = 0.d0
  ierr = 1
  return
  110 rd = 0.d0
  ierr = 2
  return
  120 rd = 0.d0
  ierr = 3
  return
end
function drexp (x)
!
!*******************************************************************************
!
!! DREXP: evaluation of the function exp(x) - 1
!
  double precision drexp
  double precision eps, n, t, x, w
  double precision dpmpar
!
!
!     ****** eps is a machine dependent constant. eps is the
!            smallest number such that 1.d0 + eps > 1.d0.
!
                  eps = epsilon ( eps )
!
!
  if (dabs(x) > 0.15d0) go to 20
!
  n = 2.d0
  t = 0.5d0*x
  w = t
   10    n = n + 1.d0
     t = t * (x/n)
     w = w + t
     if (dabs(t) > eps) go to 10
  drexp = x * (1.d0 + w)
  return
!
   20 w = dexp(x)
  if (x > 0.d0) go to 30
     drexp = (w - 0.5d0) - 0.5d0
     return
   30 drexp = w*(0.5d0 + (0.5d0 - 1.d0/w))
  return
end
subroutine drfval (x, y, z, rf, ierr)
!
!*******************************************************************************
!
!! DRFVAL: computes the incomplete elliptic integral of the first kind
!
!          rf(x,y,z) = integral from zero to infinity of
!
!                                -1/2     -1/2     -1/2
!                      (1/2)(t+x)    (t+y)    (t+z)    dt,
!
!          where x, y, and z are nonnegative and at most one of them
!          is zero.  if one of them is zero, the integral is complete.
!          the duplication theorem is iterated until the variables are
!          nearly equal, and the function is then expanded in taylor
!          series to fifth order.  reference. b. c. carlson, computing
!          elliptic integrals by duplication, numer. math. 33 (1979),
!          1-16.  coded by b. c. carlson and elaine m. notis, ames
!          laboratory-doe, iowa state university, ames, iowa 50011.
!          march 1, 1980. modified by a.h. morris (nswc).
!
!
  integer ierr
  double precision rf,c1,c2,c3,e2,e3,epslon,errtol,lamda
  double precision lolim,mu,s,uplim,x,xn,xndev,xnroot
  double precision y,yn,yndev,ynroot,z,zn,zndev,znroot
  double precision dpmpar
!
!
!          input ...
!
!          x, y, and z are the variables in the integral rf(x,y,z).
!
!          output ...
!
!          rf is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, or z is negative.
!               ierr = 2  x+y, x+z, or y+z is too small.
!               ierr = 3  x, y, or z is too large.
!
!
!
!          machine dependent parameters ...
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the machine minimum multiplied by 5.
!          uplim is not greater than the machine maximum divided by 5.
!
                  lolim = 5.0d0 * dpmpar(2)
                  uplim = 0.2d0 * dpmpar(3)
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          errtol ** 6 / (4 * (1 - errtol)).
!
         errtol = (3.6 * sngl(dpmpar(1)))**(1.0/6.0)
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (dmin1(x,y,z) < 0.d0) go to 100
  if (dmin1(x+y,x+z,y+z) < lolim) go to 110
  if (dmax1(x,y,z) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
!
   10 mu = (xn + yn + zn) / 3.d0
  xndev = 2.d0 - (mu + xn) / mu
  yndev = 2.d0 - (mu + yn) / mu
  zndev = 2.d0 - (mu + zn) / mu
  epslon = dmax1(dabs(xndev),dabs(yndev),dabs(zndev))
  if (epslon < errtol) go to 20
  xnroot = dsqrt(xn)
  ynroot = dsqrt(yn)
  znroot = dsqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  xn = (xn + lamda) * 0.25d0
  yn = (yn + lamda) * 0.25d0
  zn = (zn + lamda) * 0.25d0
  go to 10
!
   20 c1 = 1.d0 / 24.d0
  c2 = 3.d0 / 44.d0
  c3 = 1.d0 / 14.d0
  e2 = xndev * yndev - zndev * zndev
  e3 = xndev * yndev * zndev
  s = 1.d0 + (c1 * e2 - 0.1d0 - c2 * e3) * e2 + c3 * e3
  rf = s / dsqrt(mu)
  return
!
!                      error return
!
  100 rf = 0.d0
  ierr = 1
  return
  110 rf = 0.d0
  ierr = 2
  return
  120 rf = 0.d0
  ierr = 3
  return
end
subroutine drjval (x, y, z, p, rj, ierr)
!
!*******************************************************************************
!
!! DRJVAL computes the incomplete elliptic integral of the third kind
!
!          rj(x,y,z,p) = integral from zero to infinity of
!
!                                  -1/2     -1/2     -1/2     -1
!                        (3/2)(t+x)    (t+y)    (t+z)    (t+p)  dt,
!
!          where x, y, and z are nonnegative, at most one of them is
!          zero, and p is positive.  if x or y or z is zero, the
!          integral is complete.  the duplication theorem is iterated
!          until the variables are nearly equal, and the function is
!          then expanded in taylor series to fifth order.  reference.
!          b. c. carlson, computing elliptic integrals by duplication,
!          numer. math. 33 (1979), 1-16.  coded by b. c. carlson and
!          elaine m. notis, ames laboratory-doe, iowa state university,
!          ames, iowa 50011.  march 1, 1980. modified by a.h. morris
!          (nswc).
!
!
  integer ierr
  double precision rj,rc,alfa,beta,c1,c2,c3,c4,ea,eb,ec,e2,e3
  double precision epslon,errtol,etolrc,lamda,lolim,mu,p,pn,pndev
  double precision power4,sigma,s1,s2,s3,uplim,x,xn,xndev
  double precision xnroot,y,yn,yndev,ynroot,z,zn,zndev,znroot
  double precision dpmpar
!
!
!          input ...
!
!          x, y, z, and p are the variables in the integral rj(x,y,z,p).
!
!          output ...
!
!          rj is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, z, or p is negative.
!               ierr = 2  x+y, x+z, y+z, or p is too small.
!               ierr = 3  x, y, z, or p is too large.
!
!
!
!          machine dependent parameters ...
!
!          rc is a function computed by the subroutine drcvl1.
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the cube root of the value
!          of lolim used in the code for rc, and
!          uplim is not greater than 0.3 times the cube root of
!          the value of uplim used in the code for rc.
!
           mu = 1.d0/3.d0
           lolim = 1.00000000001d0 * (5.0d0 * dpmpar(2))**mu
           uplim = .299999999999d0 * (0.2d0 * dpmpar(3))**mu
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation of the series for rj
!          is less than 3 * errtol ** 6 / (1 - errtol) ** 3/2.
!          an error tolerance (etolrc) will be passed to the code for
!          rc to make the truncation error for rc less than for rj.
!
         errtol = (.28 * sngl(dpmpar(1)))**(1.0/6.0)
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (dmin1(x,y,z,p) < 0.d0) go to 100
  if (dmin1(x+y,x+z,y+z,p) < lolim) go to 110
  if (dmax1(x,y,z,p) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
  pn = p
  sigma = 0.d0
  power4 = 1.d0
  etolrc = 0.5d0 * errtol
!
   10 mu = (xn + yn + zn + pn + pn) * 0.2d0
  xndev = (mu - xn) / mu
  yndev = (mu - yn) / mu
  zndev = (mu - zn) / mu
  pndev = (mu - pn) / mu
  epslon = dmax1(dabs(xndev),dabs(yndev),dabs(zndev),dabs(pndev))
  if (epslon < errtol) go to 20
  xnroot = dsqrt(xn)
  ynroot = dsqrt(yn)
  znroot = dsqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  alfa = pn * (xnroot + ynroot + znroot) + xnroot * ynroot * znroot
  alfa = alfa * alfa
  beta = pn * (pn + lamda) * (pn + lamda)
  call drcvl1 (alfa, beta, etolrc, rc, ierr)
  if (ierr /= 0) return
  sigma = sigma + power4 * rc
  power4 = power4 * 0.25d0
  xn = (xn + lamda) * 0.25d0
  yn = (yn + lamda) * 0.25d0
  zn = (zn + lamda) * 0.25d0
  pn = (pn + lamda) * 0.25d0
  go to 10
!
   20 c1 = 3.d0 / 14.d0
  c2 = 1.d0 / 3.d0
  c3 = 3.d0 / 22.d0
  c4 = 3.d0 / 26.d0
  ea = xndev * (yndev + zndev) + yndev * zndev
  eb = xndev * yndev * zndev
  ec = pndev * pndev
  e2 = ea - 3.d0 * ec
  e3 = eb + 2.d0 * pndev * (ea - ec)
  s1 = 1.d0 + e2 * (- c1 + 0.75d0 * c3 * e2 - 1.5d0 * c4 * e3)
  s2 = eb * (0.5d0 * c2 + pndev * (- c3 - c3 + pndev * c4))
  s3 = pndev * ea * (c2 - pndev * c3) - c2 * pndev * ec
  rj = 3.d0 * sigma + power4 * (s1 + s2 + s3) / (mu * dsqrt(mu))
  return
!
!                        error return
!
  100 rj = 0.d0
  ierr = 1
  return
  110 rj = 0.d0
  ierr = 2
  return
  120 rj = 0.d0
  ierr = 3
  return
end
function drlog(x)
!
!*******************************************************************************
!
!! DRLOG: evaluation of the function x - 1 - ln(x)
!
  double precision drlog
  double precision c, eps, n, r, t, x, w, z
  double precision dpmpar
!
                  eps = epsilon ( eps )
!
!
  w = (x - 0.5d0) - 0.5d0
  if (x >= 0.61d0 .and. x <= 1.57d0) go to 10
     drlog = w - dlog(x)
     return
!
   10 r = w/(x + 1.d0)
  t = r*r
  n = 5.d0
  z = t
  w = 0.d0
   20    c = z/n
     if (c < eps) go to 30
     w = w + c
     n = n + 2.d0
     z = t*z
     go to 20
   30 w = 1.d0/3.d0 + w
  drlog = 2.d0*t*(1.d0/(1.d0 - r) - r*w)
  return
end
function drlog1(x)
!
!*******************************************************************************
!
!! DRLOG1: evaluation of the function x - ln(1 + x)
!
  double precision drlog1
  double precision c, eps, n, r, t, x, w, z
  double precision dpmpar
!
                  eps = epsilon ( eps )
!
!
  if (x >= -0.39d0 .and. x <= 0.57d0) go to 10
     w = (x + 0.5d0) + 0.5d0
     drlog1 = x - dlog(w)
     return
!
   10 r = x/(x + 2.d0)
  t = r*r
  n = 5.d0
  z = t
  w = 0.d0
   20    c = z/n
     if (c < eps) go to 30
     w = w + c
     n = n + 2.d0
     z = t*z
     go to 20
   30 w = 1.d0/3.d0 + w
  drlog1 = 2.d0*t*(1.d0/(1.d0 - r) - r*w)
  return
end
subroutine drot (n,dx,incx,dy,incy,c,s)
!
!*******************************************************************************
!
!! DROT applies a plane rotation.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dx(*),dy(*),dtemp,c,s
  integer i,incx,incy,ix,iy,n
!
  if(n <= 0)return
  if(incx==1.and.incy==1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    dtemp = c*dx(ix) + s*dy(iy)
    dy(iy) = c*dy(iy) - s*dx(ix)
    dx(ix) = dtemp
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!       code for both increments equal to 1
!
   20 do 30 i = 1,n
    dtemp = c*dx(i) + s*dy(i)
    dy(i) = c*dy(i) - s*dx(i)
    dx(i) = dtemp
   30 continue
  return
end
subroutine drotg(da,db,dc,ds)
!
!*******************************************************************************
!
!! DROTG constructs a givens rotation.
!
!
!     designed by c.l.lawson, jpl, 1977 sept 08
!
!
!     construct the givens transformation
!
!         ( dc  ds )
!     g = (        ) ,    dc**2 + ds**2 = 1 ,
!         (-ds  dc )
!
!     which zeros the second entry of the 2-vector  (da,db)**t .
!
!     the quantity r = (+/-)dsqrt(da**2 + db**2) overwrites da in
!     storage.  the value of db is overwritten by a value z which
!     allows dc and ds to be recovered by the following algorithm:
!           if z=1  set  dc=0.d0  and  ds=1.d0
!           if dabs(z) < 1  set  dc=dsqrt(1-z**2)  and  ds=z
!           if dabs(z) > 1  set  dc=1/z  and  ds=dsqrt(1-dc**2)
!
!     normally, the subprogram drot(n,dx,incx,dy,incy,dc,ds) will
!     next be called to apply the transformation to a 2 by n matrix.
!
!
!
  double precision  da, db, dc, ds, u, v, r
  if (dabs(da) <= dabs(db)) go to 10
!
!here dabs(da) > dabs(db) ***
!
  u = da + da
  v = db / u
!
!     note that u and r have the sign of da
!
  r = dsqrt(.25d0 + v**2) * u
!
!     note that dc is positive
!
  dc = da / r
  ds = v * (dc + dc)
  db = ds
  da = r
  return
!
!here dabs(da) <= dabs(db) ***
!
   10 if (db == 0.d0) go to 20
  u = db + db
  v = da / u
!
!     note that u and r have the sign of db
!     (r is immediately stored in da)
!
  da = dsqrt(.25d0 + v**2) * u
!
!     note that ds is positive
!
  ds = db / da
  dc = v * (ds + ds)
  if (dc == 0.d0) go to 15
  db = 1.d0 / dc
  return
   15 db = 1.d0
  return
!
! here da = db = 0.d0 ***
!
   20 dc = 1.d0
  ds = 0.d0
  return
end
subroutine drply1 (op,ideg,idp1,zeror,zeroi,p,qp,k,qk,svk, &
                     temp,pt,num)
!
!*******************************************************************************
!
!! DRPLY1 is called by drpoly.
!
  double precision op(idp1), zeror(ideg), zeroi(ideg), &
                   p(idp1), qp(idp1), k(idp1), qk(idp1), &
                   svk(idp1), temp(idp1)
  real pt(idp1)
!
  double precision  aa, bb, cc, factor, t
  real lo, max, min, xx, yy, cosr, sinr, x, xxx, sc, &
       bnd, xm, ff, df, dx, base, smalno, infin
  integer cnt
  logical zerok
!
  integer ipmpar
  double precision dpmpar
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
!     the following statements set the machine constants used
!     in the code. the meaning of the constants are ...
!
!     eta     the smallest positive number such that
!             1.d0 + eta is greater than 1.d0
!     smalno  the smallest positive floating point number.
!             if the exponent range differs in single and
!             double precision then smalno and infin
!             should indicate the smaller range.
!     infin   the largest positive floating point number.
!     base    the base of the floating point arithmetics
!             being used.
!
                   eta = dpmpar(1)
                   smalno = tiny ( smalno )
                   infin = huge ( infin )
                   base = ipmpar(4)
!
!
!     are and mre refer to the unit error in + and *
!     respectively. they are assumed to be the same as eta.
!
  are = eta
  mre = eta
  lo = smalno/eta
!
!     initialization of constants for shift rotation
!
  xx = .70710678
  yy = -xx
  cosr = -.069756474
  sinr = .99756405
  n = ideg
  nn = idp1
  num = 0
!
!     algorithm fails if the leading coefficient is zero.
!
  if (op(1) /= 0.d0) go to 10
     num = -1
     return
!
!     remove the zeros at the origin if any
!
   10 if (op(nn) /= 0.0d0) go to 20
     num = num + 1
     zeror(num) = 0.d0
     zeroi(num) = 0.d0
     nn = nn - 1
     n = n - 1
     go to 10
!
!     make a copy of the coefficients
!
   20 do 30 i = 1,nn
     p(i) = op(i)
   30 continue
!
!     start the algorithm for obtaining a zero
!
   40 if (n > 2) go to 60
  if (n < 1) return
!
!     calculate the final zero or pair of zeros
!
  num = ideg
  if (n == 2) go to 50
     zeror(ideg) = -p(2)/p(1)
     zeroi(ideg) = 0.0d0
     return
   50 call quadpl(p(1), p(2), p(3), zeror(ideg - 1), zeroi(ideg - 1), &
                    zeror(ideg), zeroi(ideg))
  return
!
!     find largest and smallest moduli of coefficients.
!
   60 max = 0.0
  min = infin
  do 70 i = 1,nn
     x = abs(sngl(p(i)))
     if (x > max) max = x
     if (x /= 0.0 .and. x < min) min = x
   70 continue
!
!     scale if there are large or very small coefficients.
!     computes a scale factor to multiply the
!     coefficients of the polynomial. the scaling is done
!     to avoid overflow and to avoid undetected underflow
!     interfering with the convergence criterion.
!     the factor is a power of the base.
!
  sc = lo/min
  if (sc > 1.0) go to 80
  if (max < 10.0) go to 110
  if (sc == 0.0) sc = smalno
  go to 90
   80 if (infin/sc < max) go to 110
   90 l = alog(sc)/alog(base) + 0.5
  factor = dble(base)**l
  if (factor == 1.d0) go to 110
  do 100 i = 1,nn
     p(i) = factor*p(i)
  100 continue
!
!     compute lower bound on moduli of zeros.
!
  110 do 120 i=1,nn
     pt(i) = abs(sngl(p(i)))
  120 continue
  pt(nn) = -pt(nn)
!
!     compute upper estimate of bound
!
  x = exp((alog(-pt(nn)) - alog(pt(1)))/real(n))
  if (pt(n) == 0.0) go to 130
!
!     if the newton step at the origin is better then use it.
!
  xm = -pt(nn)/pt(n)
  if (xm < x) x = xm
!
!     chop the interval (0,x) until ff <= 0.
!
  130 xm = x*.1
  ff = pt(1)
  do 140 i = 2,nn
     ff = ff*xm + pt(i)
  140 continue
  if (ff <= 0.0) go to 150
  x = xm
  go to 130
  150 dx = x
!
!     do newton iteration until x converges to two decimal places.
!
  160 if (abs(dx/x) <= 0.005) go to 180
  ff = pt(1)
  df = ff
  do 170 i = 2,n
     ff = ff*x + pt(i)
     df = df*x + ff
  170 continue
  ff = ff*x + pt(nn)
  dx = ff/df
  x = x - dx
  go to 160
  180 bnd = x
!
!     compute the derivative as the intial k polynomial
!     and do 5 steps with no shift.
!
  nm1 = n - 1
  do 190 i = 2,n
     k(i) = real(nn - i)*p(i)/float(n)
  190 continue
  k(1) = p(1)
  aa = p(nn)
  bb = p(n)
  zerok = k(n) == 0.d0
  do 230 jj = 1,5
     cc = k(n)
     if (zerok) go to 210
!
!     use scaled form of recurrence if value of k at 0 is nonzero.
!
     t = -aa/cc
     do 200 i = 1,nm1
        j = nn - i
        k(j) = t*k(j - 1) + p(j)
  200    continue
     k(1) = p(1)
     zerok = dabs(k(n)) <= dabs(bb)*eta*10.
     go to 230
!
!     use unscaled form of recurrence
!
  210    do 220 i = 1,nm1
        j = nn - i
        k(j) = k(j - 1)
  220    continue
     k(1) = 0.d0
     zerok = k(n)==0.d0
  230 continue
!
!     save k for restarts with new shifts
!
  do 240 i = 1,n
     temp(i) = k(i)
  240 continue
!
!     loop to select the quadratic  corresponding to each
!     new shift
!
  do 260 cnt = 1,20
!
!     quadratic corresponds to a double shift to a
!     non-real point and its complex conjugate. the point
!     has modulus bnd and amplitude rotated by 94 degrees
!     from the previous shift.
!
     xxx = cosr*xx - sinr*yy
     yy = sinr*xx + cosr*yy
     xx = xxx
     sr = bnd*xx
     si = bnd*yy
     u = -2.0d0*sr
     v = bnd
!
!     second stage calculation, fixed quadratic. the second stage
!     jumps directly to one of the third stage iterations.
!
     call fxshfr(20*cnt, nz, nn, p, qp, k, qk, svk)
     if (nz /= 0) go to 300
!
!     if the iteration is unsuccessful another quadratic
!     is chosen after restoring k.
!
     do 250 i = 1,n
        k(i) = temp(i)
  250    continue
  260 continue
!
!     convergence was not achieved after 20 shifts.
!
  return
!
!     store the zeros obtained and deflate the polynomial.
!
  300 num = num + 1
  zeror(num) = szr
  zeroi(num) = szi
  nn = nn - nz
  n = nn - 1
  do 310 i = 1,nn
     p(i) = qp(i)
  310 continue
  if (nz == 1) go to 40
  num = num + 1
  zeror(num) = lzr
  zeroi(num) = lzi
  go to 40
end
subroutine drpoly (op, ideg, zeror, zeroi, num, wk, dwk)
!
!*******************************************************************************
!
!! DRPOLY finds the zeros of a real polynomial.
!
!     op          - double precision array of length ideg + 1.
!                   on input this array contains the coefficients
!                   in order of decreasing powers.
!
!     ideg        - integer degree of the polynomial.
!
!     zeror,zeroi - double precision arrays if length ideg.
!                   on output these arrays contain the real and
!                   imaginary parts of the zeros.
!
!     num         - variable that reports the status of the results.
!                   if num = -1 then the leading coefficient of the
!                   polynomial is 0 or ideg < 1. otherwise, num
!                   is the number of zeros that were obtained. if
!                   num >= 1 then the real and imaginary parts of
!                   the zeros are stored in zeror(j) and zeroi(j)
!                   for j = 1,...,num.
!
!     wk          - real array of length ideg + 1. the array is
!                   a work space for the routine.
!
!     dwk         - double precision array of length 6*(ideg + 1).
!                   the array is a work space for the routine.
!
!     the subroutine uses single precision calculations for scaling,
!     bounds, and error calculations. all other calculations are done
!     in double precision.
!
  integer ideg, num
  double precision op(*), zeror(ideg), zeroi(ideg), dwk(*)
  real wk(*)
!
  integer p, qp, k, qk, svk, tmp
!
  if (ideg < 1) go to 10
!
!     partition the workspace dwk and obtain the zeros
!
  idp1 = ideg + 1
!
  p  = 1
  qp = p  + idp1
  k  = qp + idp1
  qk = k  + idp1
  svk = qk  + idp1
  tmp = svk + idp1
!
  call drply1 (op,ideg,idp1,zeror,zeroi,dwk(p),dwk(qp),dwk(k), &
               dwk(qk),dwk(svk),dwk(tmp),wk,num)
  return
!
!     error return
!
   10 num = -1
  return
end
subroutine drtrn1(n,low,igh,a,na,z,nz,ort)
!
!*******************************************************************************
!
!! DRTRN1 accumulates the orthogonal similarity transformations used
!  in the reduction of a real double
!     precision matrix to upper hessenberg form by dorth.
!
!     on input-
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if dbal has not been used then
!          set low=1, igh=n,
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction by dorth
!          in its strict lower triangle,
!
!        na must be set to the row dimension of the 2-dimensional
!          array parameter  a  as declared in the calling program
!          dimension statement,
!
!        nz must be set to the row dimension of the 2-dimensional
!          array parameter  z  as declared in the calling program
!          dimension statement,
!
!        ort contains further information about the trans-
!          formations used in the reduction by dorth.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by dorth,
!
!        ort has been altered.
!
!
  integer i,j,n,kl,mm,mp,na,igh,low,mp1,nz
  double precision a(na,igh),ort(igh),z(nz,n)
  double precision g
!
!
!    initialize z to identity matrix
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.d0
!
     z(i,i) = 1.d0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!    for mp=igh-1 step -1 until low+1 do --
  do 140 mm = 1, kl
     mp = igh - mm
     if (a(mp,mp-1) == 0.d0) go to 140
     mp1 = mp + 1
!
     do i = mp1, igh
       ort(i) = a(i,mp-1)
     end do
!
     do 130 j = mp, igh
        g = 0.d0
!
        do 110 i = mp, igh
  110       g = g + ort(i) * z(i,j)
!    divisor below is negative of h formed in orthes.
!                double division avoids possible underflow
        g = (g / ort(mp)) / a(mp,mp-1)
!
        do 120 i = mp, igh
  120       z(i,j) = z(i,j) + g * ort(i)
!
  130    continue
!
  140 continue
!
  200 return
end
subroutine dsadd (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! DSADD: addition of sparse double precision matrices
!
  double precision a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 j = 1,n
     wk(j) = 0.d0
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) + b(l)
        wk(j) = 0.d0
        if (t == 0.d0) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == 0.d0) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = 0.d0
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine dscal(n,da,dx,incx)
!
!*******************************************************************************
!
!! DSCAL scales a vector by a constant.
!     uses unrolled loops for increment equal to one.
!     jack dongarra, linpack, 3/11/78.
!
  double precision da,dx(*)
  integer i,incx,m,mp1,n,nincx
!
  if(n <= 0)return
  if(incx==1)go to 20
!
!        code for increment not equal to 1
!
  nincx = n*incx
  do 10 i = 1,nincx,incx
    dx(i) = da*dx(i)
   10 continue
  return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dx(i) = da*dx(i)
   30 continue
  if( n < 5 ) return
   40 mp1 = m + 1
  do 50 i = mp1,n,5
    dx(i) = da*dx(i)
    dx(i + 1) = da*dx(i + 1)
    dx(i + 2) = da*dx(i + 2)
    dx(i + 3) = da*dx(i + 3)
    dx(i + 4) = da*dx(i + 4)
   50 continue
  return
end
subroutine dscald(coord,npts,maxabs)
!
!*******************************************************************************
!
!! DSCALD carries out the data-scaling which is defined  by dscalp.
!
!     this subroutine is called by  dgnrtp .  it is not called by the
!     user.
!
!     the scaling which this routine carries out must  be  consistent
!     with the scaling in the subroutines dmfit and dmevl1.
!
  integer npts,p
  double precision maxabs
  double precision coord(npts)
!
  if ( maxabs == 0.0d+00 ) return
     do 10 p = 1,npts
   10       coord(p) = coord(p) / maxabs
     return
end
subroutine dscalp(coord,npts,maxabs)
!
!*******************************************************************************
!
!! DSCALP finds scaling parameter(s) for the problem.
!  if the scaling scheme
!     is changed, all four of the following would have to be changed
!
!     1)  dscalp  - find the scaling parameters
!     2)  dscald  - scale the problem data
!     3)  the scaling of the residuals in  dmfit
!     4)  the scaling performed in  dmevl1
!
!     this subroutine is called by  dgnrtp .  it is not called  by  the
!     user.
!
!     the scaling which  it  defines  must  be  coordinated  with  the
!     scaling  of residuals which is carried out toward the end of the
!     subroutine  dmfit.  the scaling must also be coordinated with the
!     scaling performed in the 10 loop  and  at statements 40 and 50
!     (with the scale factor maxabs(dimp1)) in  dmevl1.
!
  integer npts,p
  double precision maxabs,a
  double precision coord(npts)
!
!
  maxabs = 0.d0
  do 10 p = 1,npts
     a = dabs(coord(p))
   10    if ( a > maxabs ) maxabs = a
  return
end
subroutine dschur (n, low, igh, h, nh, z, nz, wr, wi, ierr)
!
!*******************************************************************************
!
!! DSCHUR transforms a hessenberg matrix into schur form.
!
!
!     it is assumed that h is an upper hessenberg matrix. dschur
!     obtains an orthogonal matrix q for which  transpose(q)*h*q
!     is in schur form. the eigenvalues of h are also computed.
!
!     on input-
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine dbal.  if  dbal  has not been used, set
!          low = 1, igh = n.
!
!        h contains the upper hessenberg matrix,
!
!        nh is the first dimension of h,
!
!        z contains a matrix of order n,
!
!        nz is the first dimension of z.
!
!     on output-
!
!        h contains the transformed matrix in upper schur form,
!
!        z contains the matrix z*q where q is the orthogonal
!          matrix which reduces h to upper schur form,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n.
!
!        ierr is set to
!          0          for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 50 iterations.
!
!
!     written by jack dongarra
!          argonne national laboratory
!          may 1961
!     modified by a.h. morris (nswc)
!
!     this subroutine is a modification of the eispack subroutine
!     hqr2,  which is based on the algol procedure hqr by peters
!     and wilkinson, num. math. 16 (1970), pp.181-204.
!
  integer i, j, k, l, m, n, en, ll, mm, na, nh, nz, igh, its, low, &
          mp2, enm2, ierr
  double precision h(nh,n), wr(n), wi(n), z(nz,n)
  double precision p, q, r, s, t, w, x, y, zz, norm, s1, s2
  logical notlas
!     double precision dsqrt, dabs
!     integer min0
!
  ierr = 0
  norm = 0.d0
  k = 1
!    store roots isolated by balanc
!                and compute matrix norm
  do 20 i = 1,n

    do j = k,n
      norm = norm + dabs(h(i,j))
    end do

    k = i
    if (i >= low .and. i <= igh) go to 20
    wr(i) = h(i,i)
    wi(i) = 0.d0
   20 continue
!
  en = igh
  t = 0.d0
!    search for next eigenvalues
   30 if (en < low) go to 300
  its = 0
  na = en - 1
  enm2 = na - 1
!    look for single small sub-diagonal element
!                for l=en step -1 until low do --
   40 do 50 ll = low,en
    l = en + low - ll
    if (l == low) go to 60
    s = dabs(h(l-1,l-1)) + dabs(h(l,l))
    if (s == 0.d0) s = norm
    s1 = s
    s2 = s1 + dabs(h(l,l-1))
    if (s1 == s2) go to 60
   50 continue
!    form shift
   60 x = h(en,en)
  if (l == en) go to 220
  y = h(na,na)
  w = h(en,na)*h(na,en)
  if (l  == na) go to 230
  if (its == 50) go to 290
  if (its /= 10 .and. its /= 20 .and. its /= 30) go to 80
!    form exceptional shift
  t = t + x
!
  do 70 i = low,en
    h(i,i) = h(i,i) - x
   70 continue
!
  s = dabs(h(en,na)) + dabs(h(na,enm2))
  x = 0.75d0*s
  y = x
  w = -0.4375d0*s*s
   80 its = its + 1
!    look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do --
  do 90 mm = l,enm2
    m = enm2 + l - mm
    zz = h(m,m)
    r = x - zz
    s = y - zz
    p = (r*s-w)/h(m+1,m) + h(m,m+1)
    q = h(m+1,m+1) - zz - r - s
    r = h(m+2,m+1)
    s = dabs(p) + dabs(q) + dabs(r)
    p = p/s
    q = q/s
    r = r/s
    if (m == l) go to 100
    s1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1)))
    s2 = s1 + dabs(h(m,m-1))*(dabs(q) + dabs(r))
    if (s1 == s2) go to 100
   90 continue
!
  100 mp2 = m + 2
!
  do 110 i = mp2,en
    h(i,i-2) = 0.d0
    if (i == mp2) go to 110
    h(i,i-3) = 0.d0
  110 continue
!    double qr step involving rows l to en and
!                columns m to en
  do 210 k = m,na
    notlas = k/=na
    if (k == m) go to 120
    p = h(k,k-1)
    q = h(k+1,k-1)
    r = 0.d0
    if (notlas) r = h(k+2,k-1)
    x = dabs(p) + dabs(q) + dabs(r)
    if (x == 0.d0) go to 210
    p = p/x
    q = q/x
    r = r/x
  120   s = dsqrt(p*p + q*q + r*r)
    if (p < 0.d0) s = -s
    if (k == m) go to 130
    h(k,k-1) = -s*x
    go to 140
  130   if (l /= m) h(k,k-1) = -h(k,k-1)
  140   p = p + s
    x = p/s
    y = q/s
    zz = r/s
    q = q/p
    r = r/p
!    row modification
    do 160 j = k,n
      p = h(k,j) + q*h(k+1,j)
      if (.not.notlas) go to 150
      p = p + r*h(k+2,j)
      h(k+2,j) = h(k+2,j) - p*zz
  150     h(k+1,j) = h(k+1,j) - p*y
      h(k,j) = h(k,j) - p*x
  160   continue
!
    j = min (en,k+3)
!    column modification
    do 180 i = 1,j
      p = x*h(i,k) + y*h(i,k+1)
      if (.not.notlas) go to 170
      p = p + zz*h(i,k+2)
      h(i,k+2) = h(i,k+2) - p*r
  170     h(i,k+1) = h(i,k+1) - p*q
      h(i,k) = h(i,k) - p
  180   continue
!    accumulate transformations
    do 200 i = low,igh
      p = x*z(i,k) + y*z(i,k+1)
      if (.not.notlas) go to 190
      p = p + zz*z(i,k+2)
      z(i,k+2) = z(i,k+2) - p*r
  190     z(i,k+1) = z(i,k+1) - p*q
      z(i,k) = z(i,k) - p
  200   continue
!
  210 continue
!
  go to 40
!    one root found
  220 h(en,en) = x + t
  wr(en) = h(en,en)
  wi(en) = 0.d0
  en = na
  go to 30
!    two roots found
  230 p = (y - x)/2.d0
  q = p*p + w
  zz = dsqrt(dabs(q))
  h(en,en) = x + t
  x = h(en,en)
  h(na,na) = y + t
  if (q < 0.d0) go to 270
!    real pair
  if (p < 0.d0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.d0) wr(en) = x - w/zz
  wi(na) = 0.d0
  wi(en) = 0.d0
  x = h(en,na)
  s = dabs(x) + dabs(zz)
  p = x/s
  q = zz/s
  r = dsqrt(p*p + q*q)
  p = p/r
  q = q/r
!    row modification
  do 240 j = na,n
    zz = h(na,j)
    h(na,j) = q*zz + p*h(en,j)
    h(en,j) = q*h(en,j) - p*zz
  240 continue
!    column modification
  do 250 i = 1,en
    zz = h(i,na)
    h(i,na) = q*zz + p*h(i,en)
    h(i,en) = q*h(i,en) - p*zz
  250 continue
!    accumulate transformations
  do 260 i = low,igh
    zz = z(i,na)
    z(i,na) = q*zz + p*z(i,en)
    z(i,en) = q*z(i,en) - p*zz
  260 continue
!
  go to 280
!    complex pair
  270 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  280 en = enm2
  go to 30
!    set error -- no convergence to an
!                eigenvalue after 50 iterations
  290 ierr = en
  return
  300 do 320 i = 1,n
    ip1 = i + 1
    if (dabs(wi(i)) /= 0.d0) ip1 = ip1 + 1
    if (ip1 > n) go to 320
    do 310 j = ip1,n
      h(j,i) = 0.d0
  310   continue
  320 continue
  return
end
subroutine dscopy (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! DSCOPY copies a sparse double precision matrix
!
  double precision a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        if (a(ip) == 0.d0) go to 10
        b(l) = a(ip)
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
subroutine dshslv (a,b,c,m,n,na,nb,nc,ierr)
!
!*******************************************************************************
!
!! DSHSLV solves the matrix equation ax + xb = c
!  where
!     a is in lower schur form and b in upper schur form.
!
  integer m,n,na,nb,nc,ierr
  double precision a(na,m), b(nb,n), c(nc,n)
  double precision sum, p(4), t(4,4)
  integer dk,dl,i,ib,j,ja,k,km1,kk,l,lm1,ll
!
  l = 1
   10    lm1 = l - 1
     dl = 1
     if (l == n) go to 15
     if (b(l+1,l) /= 0.d0) dl = 2
   15    ll = l + dl - 1
     if (l == 1) go to 30
!
     do 22 j = l,ll
        do 21 i = 1,m
        sum = c(i,j)
           do 20 ib = 1,lm1
   20          sum = sum - c(i,ib)*b(ib,j)
   21       c(i,j) = sum
   22    continue
!
   30    k = 1
   40       km1 = k - 1
        dk = 1
        if (k == m) go to 45
        if (a(k,k+1) /= 0.d0) dk = 2
   45       kk = k + dk - 1
        if (k == 1) go to 60
!
        do 52 i = k,kk
           do 51 j = l,ll
           sum = c(i,j)
              do 50 ja = 1,km1
   50             sum = sum - a(i,ja)*c(ja,j)
   51          c(i,j) = sum
   52       continue
!
   60       if (dl == 2) go to 80
        if (dk == 2) go to 70
        t(1,1) = a(k,k) + b(l,l)
        if (t(1,1) == 0.d0) go to 200
        c(k,l) = c(k,l)/t(1,1)
        ierr = 0
        go to 100
!
   70       t(1,1) = a(k,k) + b(l,l)
        t(1,2) = a(k,kk)
        t(2,1) = a(kk,k)
        t(2,2) = a(kk,kk) + b(l,l)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        call dpslv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        go to 100
!
   80       if (dk == 2) go to 90
        t(1,1) = a(k,k) + b(l,l)
        t(1,2) = b(ll,l)
        t(2,1) = b(l,ll)
        t(2,2) = a(k,k) + b(ll,ll)
        p(1) = c(k,l)
        p(2) = c(k,ll)
        call dpslv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(k,ll) = p(2)
        go to 100
!
   90       t(1,1) = a(k,k) + b(l,l)
        t(1,2) = a(k,kk)
        t(1,3) = b(ll,l)
        t(1,4) = 0.d0
        t(2,1) = a(kk,k)
        t(2,2) = a(kk,kk) + b(l,l)
        t(2,3) = 0.d0
        t(2,4) = t(1,3)
        t(3,1) = b(l,ll)
        t(3,2) = 0.d0
        t(3,3) = a(k,k) + b(ll,ll)
        t(3,4) = t(1,2)
        t(4,1) = 0.d0
        t(4,2) = t(3,1)
        t(4,3) = t(2,1)
        t(4,4) = a(kk,kk) + b(ll,ll)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        p(3) = c(k,ll)
        p(4) = c(kk,ll)
        call dpslv (4, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        c(k,ll) = p(3)
        c(kk,ll) = p(4)
!
  100    k = k + dk
     if (k <= m) go to 40
  l = l + dl
  if (l <= n) go to 10
  return
!
!     error return
!
  200 ierr = 1
  return
end
subroutine dslv (m0,n,a,ia,ja,b,r,c,max2,x,iwk,wk,ierr)
!
!*******************************************************************************
!
!! DSLV: solution of double precision sparse equations
!
!     dslv employs gaussian elimination with column interchanges to
!     solve the nxn linear system ax = b. the argument m0 specifies
!     if dslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to dslv.
!
!
!     input arguments when m0=0---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the double precision matrix a stored in sparse form.
!
!     b        double precision array of n entries containing the
!              right hand side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2     integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        double precision array of n entries containing the
!              solution. b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       double precision array of dimension 2*n + max2.
!
!
!     after an initial call to dslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to dslv
!     and solves the new equations ax = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  double precision a(*), b(n), x(n), wk(*)
  integer ia(*), ja(*), iwk(*)
  integer r(n), c(n), y, t, p
!
!     set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if (m0 /= 0) go to 20
!
!     compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return
  do 10 k = 1,n
     l = c(k)
     iwk(l) = k
   10 continue
!
!     obtain the lu decomposition of a
!
  call dsplu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
               iwk(iu),wk(y),iwk(p),ierr)
  if (ierr < 0) return
  ierr = max (1,ierr)
!
!     solve the system of equations
!
   20 call dslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                    b,x,wk(y))
  return
end
subroutine dslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! DSLV1 is called by DSLV.
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  double precision b(n), d(n), t(*), x(n), y(n), sum
!
!            solve ly = b by forward substitution
!
  do 11 k = 1,n
     lk = r(k)
     sum = b(lk)
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 11
     do 10 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   10    continue
   11 y(k) = sum/d(k)
!
!            solve ux = b by backward substitution
!             and reorder x to correspond with a
!
  k = n
  do 22 i = 1,n
     sum = y(k)
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   20    continue
   21    y(k) = sum
     lk = c(k)
     x(lk) = y(k)
     k = k - 1
   22 continue
  return
end
subroutine dsmslv(mo,n,m,a,b,kb,det,rcond,inert,ierr,ipvt,wk)
!
!*******************************************************************************
!
!! DSMSLV: matrix factorization and computation of rcond
!
  double precision a(*),b(*)
  double precision det(2),rcond,t,wk(n)
  integer inert(3),ipvt(n),onej
  ierr = 0
  call dspco(a,n,ipvt,rcond,wk)
  t = 1.d0 + rcond
  if (t == 1.d0) go to 30
!
!                  solution of the equation ax=b
!
  if (m < 1) go to 20
  onej = 1
  do 10 j=1,m
  call dspsl(a,n,ipvt,b(onej))
   10 onej = onej + kb
!
!             calculation of det and the inverse of a
!
   20 job = 110
  if (mo == 0) job = 111
  call dspdi(a,n,ipvt,det,inert,wk,job)
  return
!
!  The problem cannot be solved.
!
   30 ierr = 1
  return
end
subroutine dsort (a, n)
!
!*******************************************************************************
!
!! DSORT uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. it is assumed that n >= 1.
!
  double precision a(n), s
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31    a(ll) = s
!
   40 i = i - 1
  return
end
subroutine dspco(ap,n,kpvt,rcond,z)
!
!*******************************************************************************
!
!! DSPCO factors a double precision symmetric matrix stored in packed form
!  by elimination with symmetric pivoting and estimates
!     the condition of the matrix.
!
!     if  rcond  is not needed, dspfa is slightly faster.
!     to solve  a*x = b , follow dspco by dspsl.
!     to compute  inverse(a)*c , follow dspco by dspsl.
!     to compute  inverse(a) , follow dspco by dspdi.
!     to compute  determinant(a) , follow dspco by dspdi.
!     to compute  inertia(a), follow dspco by dspdi.
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     output
!
!        ap      a block diagonal matrix and the multipliers which
!                were used to obtain it stored in packed form.
!                the factorization can be written  a = u*d*trans(u)
!                where  u  is a product of permutation and unit
!                upper triangular matrices , trans(u) is the
!                transpose of  u , and  d  is block diagonal
!                with 1 by 1 and 2 by 2 blocks.
!
!        kpvt    integer(n)
!                an integer vector of pivot indices.
!
!        rcond   double precision
!                an estimate of the reciprocal condition of  a .
!                for the system  a*x = b , relative perturbations
!                in  a  and  b  of size  epsilon  may cause
!                relative perturbations in  x  of size  epsilon/rcond .
!                if  rcond  is so small that the logical expression
!                           1.0 + rcond == 1.0
!                is true, then  a  may be singular to working
!                precision.  in particular,  rcond  is zero  if
!                exact singularity is detected or the estimate
!                underflows.
!
!        z       double precision(n)
!                a work vector whose contents are usually unimportant.
!                if  a  is close to a singular matrix, then  z  is
!                an approximate null vector in the sense that
!                norm(a*z) = rcond*norm(a)*norm(z) .
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k) = a(i,j)
!             10    continue
!             20 continue
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     linpack dspfa
!     blas daxpy,ddot,dscal,dasum
!     fortran dabs,dmax1,iabs,dsign
!
!     internal variables
!
  integer n,kpvt(*)
  double precision ap(*),z(*)
  double precision rcond
!
  double precision ak,akm1,bk,bkm1,ddot,denom,ek,t
  double precision anorm,s,dasum,ynorm
  integer i,ij,ik,ikm1,ikp1,info,j,jm1,j1
  integer k,kk,km1k,km1km1,kp,kps,ks
!
!
!     find norm of a using only upper half
!
  j1 = 1
  do 30 j = 1, n
     z(j) = dasum(j,ap(j1),1)
     ij = j1
     j1 = j1 + j
     jm1 = j - 1
     if (jm1 < 1) go to 20
     do 10 i = 1, jm1
        z(i) = z(i) + dabs(ap(ij))
        ij = ij + 1
   10    continue
   20    continue
   30 continue
  anorm = 0.0d0
  do 40 j = 1, n
     anorm = dmax1(anorm,z(j))
   40 continue
!
!     factor
!
  call dspfa(ap,n,kpvt,info)
!
!     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
!     estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
!     the components of  e  are chosen to cause maximum local
!     growth in the elements of w  where  u*d*w = e .
!     the vectors are frequently rescaled to avoid overflow.
!
!     solve u*d*w = e
!
  ek = 1.0d0
  do 50 j = 1, n
     z(j) = 0.0d0
   50 continue
  k = n
  ik = (n*(n - 1))/2
   60 if (k == 0) go to 120
     kk = ik + k
     ikm1 = ik - (k - 1)
     ks = 1
     if (kpvt(k) < 0) ks = 2
     kp = iabs(kpvt(k))
     kps = k + 1 - ks
     if (kp == kps) go to 70
        t = z(kps)
        z(kps) = z(kp)
        z(kp) = t
   70    continue
     if (z(k) /= 0.0d0) ek = dsign(ek,z(k))
     z(k) = z(k) + ek
     call daxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
     if (ks == 1) go to 80
        if (z(k-1) /= 0.0d0) ek = dsign(ek,z(k-1))
        z(k-1) = z(k-1) + ek
        call daxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
   80    continue
     if (ks == 2) go to 100
        if (dabs(z(k)) <= dabs(ap(kk))) go to 90
           s = dabs(ap(kk))/dabs(z(k))
           call dscal(n,s,z,1)
           ek = s*ek
   90       continue
        if (ap(kk) /= 0.0d0) z(k) = z(k)/ap(kk)
        if (ap(kk) == 0.0d0) z(k) = 1.0d0
     go to 110
  100    continue
        km1k = ik + k - 1
        km1km1 = ikm1 + k - 1
        ak = ap(kk)/ap(km1k)
        akm1 = ap(km1km1)/ap(km1k)
        bk = z(k)/ap(km1k)
        bkm1 = z(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0d0
        z(k) = (akm1*bk - bkm1)/denom
        z(k-1) = (ak*bkm1 - bk)/denom
  110    continue
     k = k - ks
     ik = ik - k
     if (ks == 2) ik = ik - (k + 1)
  go to 60
  120 continue
  s = 1.0d0/dasum(n,z,1)
  call dscal(n,s,z,1)
!
!     solve trans(u)*y = w
!
  k = 1
  ik = 0
  130 if (k > n) go to 160
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == 1) go to 150
        z(k) = z(k) + ddot(k-1,ap(ik+1),1,z(1),1)
        ikp1 = ik + k
        if (ks == 2) &
           z(k+1) = z(k+1) + ddot(k-1,ap(ikp1+1),1,z(1),1)
        kp = iabs(kpvt(k))
        if (kp == k) go to 140
           t = z(k)
           z(k) = z(kp)
           z(kp) = t
  140       continue
  150    continue
     ik = ik + k
     if (ks == 2) ik = ik + (k + 1)
     k = k + ks
  go to 130
  160 continue
  s = 1.0d0/dasum(n,z,1)
  call dscal(n,s,z,1)
!
  ynorm = 1.0d0
!
!     solve u*d*v = y
!
  k = n
  ik = n*(n - 1)/2
  170 if (k == 0) go to 230
     kk = ik + k
     ikm1 = ik - (k - 1)
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == ks) go to 190
        kp = iabs(kpvt(k))
        kps = k + 1 - ks
        if (kp == kps) go to 180
           t = z(kps)
           z(kps) = z(kp)
           z(kp) = t
  180       continue
        call daxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
        if (ks == 2) call daxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
  190    continue
     if (ks == 2) go to 210
        if (dabs(z(k)) <= dabs(ap(kk))) go to 200
           s = dabs(ap(kk))/dabs(z(k))
           call dscal(n,s,z,1)
           ynorm = s*ynorm
  200       continue
        if (ap(kk) /= 0.0d0) z(k) = z(k)/ap(kk)
        if (ap(kk) == 0.0d0) z(k) = 1.0d0
     go to 220
  210    continue
        km1k = ik + k - 1
        km1km1 = ikm1 + k - 1
        ak = ap(kk)/ap(km1k)
        akm1 = ap(km1km1)/ap(km1k)
        bk = z(k)/ap(km1k)
        bkm1 = z(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0d0
        z(k) = (akm1*bk - bkm1)/denom
        z(k-1) = (ak*bkm1 - bk)/denom
  220    continue
     k = k - ks
     ik = ik - k
     if (ks == 2) ik = ik - (k + 1)
  go to 170
  230 continue
  s = 1.0d0/dasum(n,z,1)
  call dscal(n,s,z,1)
  ynorm = s*ynorm
!
!     solve trans(u)*z = v
!
  k = 1
  ik = 0
  240 if (k > n) go to 270
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == 1) go to 260
        z(k) = z(k) + ddot(k-1,ap(ik+1),1,z(1),1)
        ikp1 = ik + k
        if (ks == 2) &
           z(k+1) = z(k+1) + ddot(k-1,ap(ikp1+1),1,z(1),1)
        kp = iabs(kpvt(k))
        if (kp == k) go to 250
           t = z(k)
           z(k) = z(kp)
           z(kp) = t
  250       continue
  260    continue
     ik = ik + k
     if (ks == 2) ik = ik + (k + 1)
     k = k + ks
  go to 240
  270 continue
!     make znorm = 1.0
  s = 1.0d0/dasum(n,z,1)
  call dscal(n,s,z,1)
  ynorm = s*ynorm
!
  if (anorm /= 0.0d0) rcond = ynorm/anorm
  if (anorm == 0.0d0) rcond = 0.0d0
  return
end
subroutine dspdi(ap,n,kpvt,det,inert,work,job)
!
!*******************************************************************************
!
!! DSPDI computes the determinant, inertia and inverse of a symmetric matrix.
!
!  dspdi uses the factors from
!     dspfa, where the matrix is stored in packed form.
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the output from dspfa.
!
!        n       integer
!                the order of the matrix a.
!
!        kpvt    integer(n)
!                the pivot vector from dspfa.
!
!        work    double precision(n)
!                work vector.  contents ignored.
!
!        job     integer
!                job has the decimal expansion  abc  where
!                   if  c /= 0, the inverse is computed,
!                   if  b /= 0, the determinant is computed,
!                   if  a /= 0, the inertia is computed.
!
!                for example, job = 111  gives all three.
!
!     on return
!
!        variables not requested by job are not used.
!
!        ap     contains the upper triangle of the inverse of
!               the original matrix, stored in packed form.
!               the columns of the upper triangle are stored
!               sequentially in a one-dimensional array.
!
!        det    double precision(2)
!               determinant of original matrix.
!               determinant = det(1) * 10.0**det(2)
!               with 1.0 <= dabs(det(1)) < 10.0
!               or det(1) = 0.0.
!
!        inert  integer(3)
!               the inertia of the original matrix.
!               inert(1)  =  number of positive eigenvalues.
!               inert(2)  =  number of negative eigenvalues.
!               inert(3)  =  number of zero eigenvalues.
!
!     error condition
!
!        a division by zero will occur if the inverse is requested
!        and  dspco  has set rcond == 0.0
!        or  dspfa  has set  info /= 0 .
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas daxpy,dcopy,ddot,dswap
!     fortran dabs,iabs,mod
!
!     internal variables.
!
  integer n,job
  double precision ap(*),work(*)
  double precision det(2)
  integer kpvt(*),inert(3)
!
  double precision akkp1,ddot,temp
  double precision ten,d,t,ak,akp1
  integer ij,ik,ikp1,iks,j,jb,jk,jkp1
  integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep
  logical noinv,nodet,noert
!
  noinv = mod(job,10) == 0
  nodet = mod(job,100)/10 == 0
  noert = mod(job,1000)/100 == 0
!
  if (nodet .and. noert) go to 140
     if (noert) go to 10
        inert(1) = 0
        inert(2) = 0
        inert(3) = 0
   10    continue
     if (nodet) go to 20
        det(1) = 1.0d0
        det(2) = 0.0d0
        ten = 10.0d0
   20    continue
     t = 0.0d0
     ik = 0
     do 130 k = 1, n
        kk = ik + k
        d = ap(kk)
!
!           check if 1 by 1
!
        if (kpvt(k) > 0) go to 50
!
!              2 by 2 block
!              use det (d  s)  =  (d/t * c - t) * t  ,  t = dabs(s)
!                      (s  c)
!              to avoid underflow/overflow troubles.
!              take two passes through scaling.  use  t  for flag.
!
           if (t /= 0.0d0) go to 30
              ikp1 = ik + k
              kkp1 = ikp1 + k
              t = dabs(ap(kkp1))
              d = (d/t)*ap(kkp1+1) - t
           go to 40
   30          continue
              d = t
              t = 0.0d0
   40          continue
   50       continue

        if (noert) go to 60
           if (d > 0.0d0) inert(1) = inert(1) + 1
           if (d < 0.0d0) inert(2) = inert(2) + 1
           if (d == 0.0d0) inert(3) = inert(3) + 1
   60       continue
!
        if (nodet) go to 120
           det(1) = d*det(1)
           if (det(1) == 0.0d0) go to 110
   70             if (dabs(det(1)) >= 1.0d0) go to 80
                 det(1) = ten*det(1)
                 det(2) = det(2) - 1.0d0
              go to 70
   80             continue
   90             if (dabs(det(1)) < ten) go to 100
                 det(1) = det(1)/ten
                 det(2) = det(2) + 1.0d0
              go to 90
  100             continue
  110          continue
  120       continue
        ik = ik + k
  130    continue
  140 continue
!
!     compute inverse(a)
!
  if (noinv) go to 270
     k = 1
     ik = 0
  150    if (k > n) go to 260
        km1 = k - 1
        kk = ik + k
        ikp1 = ik + k
        kkp1 = ikp1 + k
        if (kpvt(k) < 0) go to 180
!
!              1 by 1
!
           ap(kk) = 1.0d0/ap(kk)
           if (km1 < 1) go to 170
              call dcopy(km1,ap(ik+1),1,work,1)
              ij = 0
              do 160 j = 1, km1
                 jk = ik + j
                 ap(jk) = ddot(j,ap(ij+1),1,work,1)
                 call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                 ij = ij + j
  160             continue
              ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  170          continue
           kstep = 1
        go to 220
  180       continue
!
!              2 by 2
!
           t = dabs(ap(kkp1))
           ak = ap(kk)/t
           akp1 = ap(kkp1+1)/t
           akkp1 = ap(kkp1)/t
           d = t*(ak*akp1 - 1.0d0)
           ap(kk) = akp1/d
           ap(kkp1+1) = ak/d
           ap(kkp1) = -akkp1/d
           if (km1 < 1) go to 210
              call dcopy(km1,ap(ikp1+1),1,work,1)
              ij = 0
              do 190 j = 1, km1
                 jkp1 = ikp1 + j
                 ap(jkp1) = ddot(j,ap(ij+1),1,work,1)
                 call daxpy(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1)
                 ij = ij + j
  190             continue
              ap(kkp1+1) = ap(kkp1+1) &
                           + ddot(km1,work,1,ap(ikp1+1),1)
              ap(kkp1) = ap(kkp1) &
                         + ddot(km1,ap(ik+1),1,ap(ikp1+1),1)
              call dcopy(km1,ap(ik+1),1,work,1)
              ij = 0
              do 200 j = 1, km1
                 jk = ik + j
                 ap(jk) = ddot(j,ap(ij+1),1,work,1)
                 call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                 ij = ij + j
  200             continue
              ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  210          continue
           kstep = 2
  220       continue
!
!           swap
!
        ks = iabs(kpvt(k))
        if (ks == k) go to 250
           iks = (ks*(ks - 1))/2
           call dswap(ks,ap(iks+1),1,ap(ik+1),1)
           ksj = ik + ks
           do 230 jb = ks, k
              j = k + ks - jb
              jk = ik + j
              temp = ap(jk)
              ap(jk) = ap(ksj)
              ap(ksj) = temp
              ksj = ksj - (j - 1)
  230          continue
           if (kstep == 1) go to 240
              kskp1 = ikp1 + ks
              temp = ap(kskp1)
              ap(kskp1) = ap(kkp1)
              ap(kkp1) = temp
  240          continue
  250       continue
        ik = ik + k
        if (kstep == 2) ik = ik + k + 1
        k = k + kstep
     go to 150
  260    continue
  270 continue
  return
end
subroutine dspfa(ap,n,kpvt,info)
!
!*******************************************************************************
!
!! DSPFA factors a double precision symmetric matrix stored in packed form
!  by elimination with symmetric pivoting.
!
!     to solve  a*x = b , follow dspfa by dspsl.
!     to compute  inverse(a)*c , follow dspfa by dspsl.
!     to compute  determinant(a) , follow dspfa by dspdi.
!     to compute  inertia(a) , follow dspfa by dspdi.
!     to compute  inverse(a) , follow dspfa by dspdi.
!
!     on entry
!
!        ap      double precision (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     output
!
!        ap      a block diagonal matrix and the multipliers which
!                were used to obtain it stored in packed form.
!                the factorization can be written  a = u*d*trans(u)
!                where  u  is a product of permutation and unit
!                upper triangular matrices , trans(u) is the
!                transpose of  u , and  d  is block diagonal
!                with 1 by 1 and 2 by 2 blocks.
!
!        kpvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if the k-th pivot block is singular. this is
!                     not an error condition for this subroutine,
!                     but it does indicate that dspsl or dspdi may
!                     divide by zero if called.
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k)  = a(i,j)
!             10    continue
!             20 continue
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas daxpy,dswap,idamax
!     fortran dabs,dmax1,dsqrt
!
!     internal variables
!
  integer n,kpvt(*),info
  double precision ap(*)
!
  double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
  double precision absakk,alpha,colmax,rowmax
  integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
  integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
  logical swap
!
!
!     initialize
!
!     alpha is used in choosing pivot block size.
  alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0
!
  info = 0
!
!     main loop on k, which goes from n to 1.
!
  k = n
  ik = (n*(n - 1))/2
   10 continue
!
!        leave the loop if k=0 or k=1.
!
!     ...exit
     if (k == 0) go to 200
     if (k > 1) go to 20
        kpvt(1) = 1
        if (ap(1) == 0.0d0) info = 1
!    ....exit
        go to 200
   20    continue
!
!        this section of code determines the kind of
!        elimination to be performed.  when it is completed,
!        kstep will be set to the size of the pivot block, and
!        swap will be set to .true. if an interchange is
!        required.
!
     km1 = k - 1
     kk = ik + k
     absakk = dabs(ap(kk))
!
!        determine the largest off-diagonal element in
!        column k.
!
     imax = idamax(k-1,ap(ik+1),1)
     imk = ik + imax
     colmax = dabs(ap(imk))
     if (absakk < alpha*colmax) go to 30
        kstep = 1
        swap = .false.
     go to 90
   30    continue
!
!           determine the largest off-diagonal element in
!           row imax.
!
        rowmax = 0.0d0
        imaxp1 = imax + 1
        im = imax*(imax - 1)/2
        imj = im + 2*imax
        do 40 j = imaxp1, k
           rowmax = dmax1(rowmax,dabs(ap(imj)))
           imj = imj + j
   40       continue
        if (imax == 1) go to 50
           jmax = idamax(imax-1,ap(im+1),1)
           jmim = jmax + im
           rowmax = dmax1(rowmax,dabs(ap(jmim)))
   50       continue
        imim = imax + im
        if (dabs(ap(imim)) < alpha*rowmax) go to 60
           kstep = 1
           swap = .true.
        go to 80
   60       continue
        if (absakk < alpha*colmax*(colmax/rowmax)) go to 70
           kstep = 1
           swap = .false.
        go to 80
   70       continue
           kstep = 2
           swap = imax /= km1
   80       continue
   90    continue
     if (dmax1(absakk,colmax) /= 0.0d0) go to 100
!
!           column k is zero.  set info and iterate the loop.
!
        kpvt(k) = k
        info = k
     go to 190
  100    continue
     if (kstep == 2) go to 140
!
!           1 x 1 pivot block.
!
        if (.not.swap) go to 120
!
!              perform an interchange.
!
           call dswap(imax,ap(im+1),1,ap(ik+1),1)
           imj = ik + imax
           do 110 jj = imax, k
              j = k + imax - jj
              jk = ik + j
              t = ap(jk)
              ap(jk) = ap(imj)
              ap(imj) = t
              imj = imj - (j - 1)
  110          continue
  120       continue
!
!           perform the elimination.
!
        ij = ik - (k - 1)
        do 130 jj = 1, km1
           j = k - jj
           jk = ik + j
           mulk = -ap(jk)/ap(kk)
           t = mulk
           call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
           ijj = ij + j
           ap(jk) = mulk
           ij = ij - (j - 1)
  130       continue
!
!           set the pivot array.
!
        kpvt(k) = k
        if (swap) kpvt(k) = imax
     go to 190
  140    continue
!
!           2 x 2 pivot block.
!
        km1k = ik + k - 1
        ikm1 = ik - (k - 1)
        if (.not.swap) go to 160
!
!              perform an interchange.
!
           call dswap(imax,ap(im+1),1,ap(ikm1+1),1)
           imj = ikm1 + imax
           do 150 jj = imax, km1
              j = km1 + imax - jj
              jkm1 = ikm1 + j
              t = ap(jkm1)
              ap(jkm1) = ap(imj)
              ap(imj) = t
              imj = imj - (j - 1)
  150          continue
           t = ap(km1k)
           ap(km1k) = ap(imk)
           ap(imk) = t
  160       continue
!
!           perform the elimination.
!
        km2 = k - 2
        if (km2 == 0) go to 180
           ak = ap(kk)/ap(km1k)
           km1km1 = ikm1 + k - 1
           akm1 = ap(km1km1)/ap(km1k)
           denom = 1.0d0 - ak*akm1
           ij = ik - (k - 1) - (k - 2)
           do 170 jj = 1, km2
              j = km1 - jj
              jk = ik + j
              bk = ap(jk)/ap(km1k)
              jkm1 = ikm1 + j
              bkm1 = ap(jkm1)/ap(km1k)
              mulk = (akm1*bk - bkm1)/denom
              mulkm1 = (ak*bkm1 - bk)/denom
              t = mulk
              call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
              t = mulkm1
              call daxpy(j,t,ap(ikm1+1),1,ap(ij+1),1)
              ap(jk) = mulk
              ap(jkm1) = mulkm1
              ijj = ij + j
              ij = ij - (j - 1)
  170          continue
  180       continue
!
!           set the pivot array.
!
        kpvt(k) = 1 - k
        if (swap) kpvt(k) = -imax
        kpvt(k-1) = kpvt(k)
  190    continue
     ik = ik - (k - 1)
     if (kstep == 2) ik = ik - (k - 2)
     k = k - kstep
  go to 10
  200 continue
  return
end
subroutine dsplu (a,ia,ja,r,c,ic,n,max,d,t,it,jt,iu,w,p,ierr)
!
!*******************************************************************************
!
!! DSPLU employs gaussian elimination with column interchanges
!     to perform the lu decomposition of a double precision sparse
!     matrix. u is a unit upper triangular matrix.
!
!
!     input arguments---
!
!     a,ia,ja  the sparse matrix to be decomposed.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     ic       integer array of n entries which is the inverse of c
!              (i.e., ic(c(i)) = i). ic is also an output argument.
!
!     n        order of the matrix a.
!
!     max      integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     ic       integer array of n entries which is the inverse of c.
!
!     d        double precision array containing the n diagonal
!              elements of l.
!
!     t,it,iu  t contains the off-diagonal nonzero elements of l and
!              u. for i = 1,...,n the off-diagonal nonzero elements
!              of the i-th row of l are stored in locations
!              it(i),...,iu(i)-1 of t, and the off-diagonal nonzero
!              elements of the i-th row of u are stored in locations
!              iu(i),...,it(i+1)-1 of t.
!
!     jt       integer array containing the column indices (according
!              to the orginal column ordering) of the elements of t
!              (i.e., for each l(i,j) and u(i,j) in t, c(j) is the
!              corresponding column index in jt).
!
!     ierr     integer specifying the status of the results. if the
!              lu decomposition is obtained then ierr = the number
!              of off-diagonal entries of l and u which were stored
!              in t. otherwise ierr is assigned a negative value.
!
!
!     work spaces---
!
!     w        double precision array of dimension n.
!
!     p        integer array of dimension n+1.
!
  double precision a(*), d(n), t(max), w(n)
  integer ia(*), ja(*)
  integer r(n), c(n), ic(n)
  integer it(*), jt(max), iu(n)
  integer p(*), pm
  double precision const, wi, wmax
!
  jptr = 0
  it(1) = 1
  do 10 j = 1,n
     w(j) = 0.d0
   10 continue
!
!     perform the lu factorization of the r(k)-th row of a
!
  do 100 k = 1,n
  lk = r(k)
  jmin = ia(lk)
  jmax = ia(lk+1) - 1
  if (jmin > jmax) go to 200
!
!     set p to the reordered row of a
!
  p(n+1) = n + 1
  jj = jmax
   20 lj = ja(jj)
  j = ic(lj)
  w(j) = a(jj)
  pm = n + 1
   21 m = pm
  pm = p(m)
  if (pm - j) 21,210,22
   22 p(m) = j
  p(j) = pm
  jj = jj - 1
  if (jj >= jmin) go to 20
!
!     process the entries in the lower triangle of a
!
  i = n + 1
   30 i = p(i)
  if (i >= k) go to 50
  if (w(i) == 0.d0) go to 30
!
!     l(k,i) is nonzero. therefore store it in l.
!
  jptr = jptr + 1
  if (jptr > max) go to 230
  const = w(i)
  t(jptr) = const
  jt(jptr) = c(i)
  w(i) = 0.d0
!
!     perform elimination using the i-th row of u
!
  jmin = iu(i)
  jmax = it(i+1) - 1
  if (jmin > jmax) go to 30
  pm = i
  do 43 jj = jmin,jmax
     lj = jt(jj)
     j = ic(lj)
     if (w(j) /= 0.d0) go to 43
     if (j - pm) 40,43,41
   40       pm = i
   41       m = pm
        pm = p(m)
        if (pm - j) 41,43,42
   42       p(m) = j
        p(j) = pm
        pm = j
   43 w(j) = w(j) - const*t(jj)
  go to 30
!
!     search for the k-th pivot element
!
   50 if (i > n) go to 220
  wmax = dabs(w(i))
  maxi = i
  pm = i
   51 m = pm
  pm = p(m)
  if (pm > n) go to 60
  wi = dabs(w(pm))
  if (wi <= wmax) go to 51
     wmax = wi
     maxi = pm
     maxil = m
     go to 51
!
!     store the pivot in d
!
   60 if (wmax == 0.d0) go to 220
  d(k) = w(maxi)
!
!     perform the column interchange
!
  if (i == k) go to 70
  if (i == maxi) go to 70
     p(maxil) = p(maxi)
     go to 80
   70 i = p(i)
!
   80 w(maxi) = w(k)
  w(k) = 0.d0
  lk = c(k)
  ll = c(maxi)
  c(k) = ll
  c(maxi) = lk
  ic(lk) = maxi
  ic(ll) = k
!
!     the remaining elements of p form the k-th row of u
!
  iu(k) = jptr + 1
   90 if (i > n) go to 100
  if (w(i) == 0.d0) go to 91
     jptr = jptr + 1
     if (jptr > max) go to 230
     t(jptr) = w(i)/d(k)
     jt(jptr) = c(i)
     w(i) = 0.d0
   91 i = p(i)
  go to 90
!
!     prepare for the next row
!
  100 it(k+1) = jptr + 1
!
  ierr = jptr
  return
!
! error return---
!
!     row r(k) is null
!
  200 ierr = -k
  return
!
!     row r(k) has a duplicate entry
!
  210 ierr = -(n + k)
  return
!
!     zero pivot in row r(k)
!
  220 ierr = -(2*n + k)
  return
!
!     storage for l and u exceeded on row r(k)
!
  230 ierr = -(3*n + k)
  return
end
subroutine dsprod (a,ia,ja,b,ib,jb,c,ic,jc,l,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! DSPROD: multiplication of sparse double precision matrices
!
  double precision a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 k = 1,n
     wk(k) = 0.d0
   10 continue
!
!                     compute the i-th row of c
!
  ip = 1
  do 31 i = 1,l
     ic(i) = ip
     jpmin = ia(i)
     jpmax = ia(i+1) - 1
     if (jpmin > jpmax) go to 31
!
     do 21 jp = jpmin,jpmax
        t = a(jp)
        if (t == 0.d0) go to 21
        j = ja(jp)
        kpmin = ib(j)
        kpmax = ib(j+1) - 1
        if (kpmin > kpmax) go to 21
        do 20 kp = kpmin,kpmax
           k = jb(kp)
           wk(k) = wk(k) + t*b(kp)
   20       continue
   21    continue
!
     do 30 k = 1,n
        if (wk(k) == 0.d0) go to 30
        if (ip > num) go to 40
        c(ip) = wk(k)
        wk(k) = 0.d0
        jc(ip) = k
        ip = ip + 1
   30    continue
   31 continue
  ic(l + 1) = ip
  ierr = 0
  return
!
!                           error return
!
   40 ierr = i
  return
end
subroutine dspsl(ap,n,kpvt,b)
!
!*******************************************************************************
!
!! DSPSL solves the double precision symmetric system a * x = b
!     using the factors computed by dspfa.
!
!     on entry
!
!        ap      double precision(n*(n+1)/2)
!                the output from dspfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        kpvt    integer(n)
!                the pivot vector from dspfa.
!
!        b       double precision(n)
!                the right hand side vector.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero may occur if  dspco  has set rcond == 0.0
!        or  dspfa  has set info /= 0  .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call dspfa(ap,n,kpvt,info)
!           if (info /= 0) go to ...
!           do 10 j = 1, p
!              call dspsl(ap,n,kpvt,c(1,j))
!        10 continue
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas daxpy,ddot
!     fortran iabs
!
!     internal variables.
!
  integer n,kpvt(*)
  double precision ap(*),b(*)
!
  double precision ak,akm1,bk,bkm1,ddot,denom,temp
  integer ik,ikm1,ikp1,k,kk,km1k,km1km1,kp
!
!     loop backward applying the transformations and
!     d inverse to b.
!
  k = n
  ik = (n*(n - 1))/2
   10 if (k == 0) go to 80
     kk = ik + k
     if (kpvt(k) < 0) go to 40
!
!           1 x 1 pivot block.
!
        if (k == 1) go to 30
           kp = kpvt(k)
           if (kp == k) go to 20
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
   20          continue
!
!              apply the transformation.
!
           call daxpy(k-1,b(k),ap(ik+1),1,b(1),1)
   30       continue
!
!           apply d inverse.
!
        b(k) = b(k)/ap(kk)
        k = k - 1
        ik = ik - k
     go to 70
   40    continue
!
!           2 x 2 pivot block.
!
        ikm1 = ik - (k - 1)
        if (k == 2) go to 60
           kp = iabs(kpvt(k))
           if (kp == k - 1) go to 50
!
!                 interchange.
!
              temp = b(k-1)
              b(k-1) = b(kp)
              b(kp) = temp
   50          continue
!
!              apply the transformation.
!
           call daxpy(k-2,b(k),ap(ik+1),1,b(1),1)
           call daxpy(k-2,b(k-1),ap(ikm1+1),1,b(1),1)
   60       continue
!
!           apply d inverse.
!
        km1k = ik + k - 1
        kk = ik + k
        ak = ap(kk)/ap(km1k)
        km1km1 = ikm1 + k - 1
        akm1 = ap(km1km1)/ap(km1k)
        bk = b(k)/ap(km1k)
        bkm1 = b(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0d0
        b(k) = (akm1*bk - bkm1)/denom
        b(k-1) = (ak*bkm1 - bk)/denom
        k = k - 2
        ik = ik - (k + 1) - k
   70    continue
  go to 10
   80 continue
!
!     loop forward applying the transformations.
!
  k = 1
  ik = 0
   90 if (k > n) go to 160
     if (kpvt(k) < 0) go to 120
!
!           1 x 1 pivot block.
!
        if (k == 1) go to 110
!
!              apply the transformation.
!
           b(k) = b(k) + ddot(k-1,ap(ik+1),1,b(1),1)
           kp = kpvt(k)
           if (kp == k) go to 100
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
  100          continue
  110       continue
        ik = ik + k
        k = k + 1
     go to 150
  120    continue
!
!           2 x 2 pivot block.
!
        if (k == 1) go to 140
!
!              apply the transformation.
!
           b(k) = b(k) + ddot(k-1,ap(ik+1),1,b(1),1)
           ikp1 = ik + k
           b(k+1) = b(k+1) + ddot(k-1,ap(ikp1+1),1,b(1),1)
           kp = iabs(kpvt(k))
           if (kp == k) go to 130
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
  130          continue
  140       continue
        ik = ik + k + k + 1
        k = k + 2
  150    continue
  go to 90
  160 continue
  return
end
subroutine dspslv (n,a,ia,ja,b,r,c,max2,x,itemp,rtemp,ierr)
!
!*******************************************************************************
!
!! DSPSLV: solution of double precision sparse equations
!
!  dspslv calls dnspiv which uses sparse gaussian elimination with
!  column interchanges to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!  input arguments---
!
!  n      integer number of equations and unknowns
!
!  a      double precision array with one entry per nonzero in a,
!         containing the actual nonzeros. (see the matrix storage
!         description below)
!
!  ia     integer array of n+1 entries containing row pointers to a
!         (see matrix storage description below)
!
!  ja     integer array with one entry per nonzero in a, containing
!         column numbers of the nonzeros of a.  (see matrix storage
!         description below)
!
!  b      double precision array of n entries containing the right
!         hand side data
!
!  r      integer array of n entries specifying the order of the
!         rows of a (i.e., the elimination order for the equations)
!
!  c      integer array of n entries specifying the order of the
!         columns of a.  c is also an output argument
!
!  max2   integer number specifying maximum number of off-diagonal
!         nonzero entries of u which may be stored
!
!  itemp  integer array of 3*n + max2 + 2 entries, for internal use
!
!  rtemp  double precision array of n + max2 entries for internal use
!
!
!  output arguments---
!
!  c      integer array of n entries specifying the order of the
!         columns of u.  c is also an input argument
!
!  x      double precision array of n entries containing the
!         solution vector
!
!  ierr   integer number which indicates error conditions or
!         the actual number of off-diagonal entries in u (for
!         successful completion)
!
!         ierr values are---
!
!         0 lt ierr             successful completion. ierr=max(1,m)
!                               where m is the number of off-diagonal
!                               nonzero entries of u.
!
!         ierr = 0              error.  n is less than or equal to 0
!
!         -n le ierr lt 0       error.  row number iabs(ierr) of a is
!                               is null
!
!         -2*n le ierr lt -n    error.  row number iabs(ierr+n) has a
!                               duplicate entry
!
!         -3*n le ierr lt -2*n  error.  row number iabs(ierr+2*n)
!                               has a zero pivot
!
!         -4*n le ierr lt -3*n  error.  row number iabs(ierr+3*n)
!                               exceeds storage
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzero
!  elements in a.
!
  double precision a(*), b(n), x(n), rtemp(*)
  integer ia(*), ja(*), r(n), c(n), itemp(*)
  integer iu, ju, u, y, p
!
  ierr = 0
  if (n <= 0) return
!
!  set indices to divide temporary storage for dnspiv
!
  y = 1
  u = y + n
  p = n + 1
  iu = p + n + 1
  ju = iu + n + 1
!
!  compute the inverse permutation of c
!
  do 10 k = 1,n
     l = c(k)
     itemp(l) = k
   10 continue
!
!  call dnspiv to perform computations
!
  call dnspiv (n,ia,ja,a,b,max2,r,c,itemp(1),x,rtemp(y),itemp(p), &
               itemp(iu),itemp(ju),rtemp(u),ierr)
  if (ierr == 0) ierr = 1
  return
end
subroutine dssubt (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! DSSUBT: subtraction of sparse double precision matrices
!
  double precision a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 j = 1,n
     wk(j) = 0.d0
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) - b(l)
        wk(j) = 0.d0
        if (t == 0.d0) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == 0.d0) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = 0.d0
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine dstor2 (a, b)
!
!*******************************************************************************
!
!! DSTOR2: storage of double precision information into memory
!
  double precision a, b, d1, d2
  common /dpdata/ d1, d2
  d1 = a
  d2 = b
  return
end
subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
!
!*******************************************************************************
!
!! DSVDC computes the singular value decomposition of a matrix.
!
!
!     dsvdc is a subroutine to reduce a double precision nxp matrix x
!     by orthogonal transformations u and v to diagonal form.  the
!     diagonal elements s(i) are the singular values of x.  the
!     columns of u are the corresponding left singular vectors,
!     and the columns of v the right singular vectors.
!
!     on entry
!
!         x         double precision(ldx,p), where ldx >= n.
!                   x contains the matrix whose singular value
!                   decomposition is to be computed.  x is
!                   destroyed by dsvdc.
!
!         ldx       integer.
!                   ldx is the leading dimension of the array x.
!
!         n         integer.
!                   n is the number of rows of the matrix x.
!
!         p         integer.
!                   p is the number of columns of the matrix x.
!
!         ldu       integer.
!                   ldu is the leading dimension of the array u.
!                   (see below).
!
!         ldv       integer.
!                   ldv is the leading dimension of the array v.
!                   (see below).
!
!         work      double precision(n).
!                   work is a scratch array.
!
!         job       integer.
!                   job controls the computation of the singular
!                   vectors.  it has the decimal expansion ab
!                   with the following meaning
!
!                        a==0    do not compute the left singular
!                                  vectors.
!                        a==1    return the n left singular vectors
!                                  in u.
!                        a >= 2    return the first min(n,p) singular
!                                  vectors in u.
!                        b==0    do not compute the right singular
!                                  vectors.
!                        b==1    return the right singular vectors
!                                  in v.
!
!     on return
!
!         s         double precision(mm), where mm=min(n+1,p).
!                   the first min(n,p) entries of s contain the
!                   singular values of x arranged in descending
!                   order of magnitude.
!
!         e         double precision(p).
!                   e ordinarily contains zeros.  however see the
!                   discussion of info for exceptions.
!
!         u         double precision(ldu,k), where ldu >= n.  if
!                                   joba==1 then k==n, if joba >= 2
!                                   then k==min(n,p).
!                   u contains the matrix of left singular vectors.
!                   u is not referenced if joba==0.  if n <= p
!                   or if joba==2, then u may be identified with x
!                   in the subroutine call.
!
!         v         double precision(ldv,p), where ldv >= p.
!                   v contains the matrix of right singular vectors.
!                   v is not referenced if job==0.  if p <= n,
!                   then v may be identified with x in the
!                   subroutine call.
!
!         info      integer.
!                   the singular values (and their corresponding
!                   singular vectors) s(info+1),s(info+2),...,s(m)
!                   are correct (here m=min(n,p)).  thus if
!                   info==0, all the singular values and their
!                   vectors are correct.  in any event, the matrix
!                   b = trans(u)*x*v is the bidiagonal matrix
!                   with the elements of s on its diagonal and the
!                   elements of e on its super-diagonal (trans(u)
!                   is the transpose of u).  thus the singular
!                   values of x and b are the same.
!
!     linpack. this version dated 03/19/79 .
!     g.w. stewart, university of maryland, argonne national lab.
!
!     dsvdc uses the following functions and subprograms.
!
!     external drot
!     blas daxpy,ddot,dscal,dswap,dnrm2,drotg
!     fortran dabs,dmax1,max0,min0,mod,dsqrt
!
!     internal variables
!
  integer ldx,n,p,ldu,ldv,job,info
  double precision x(ldx,*),s(*),e(*),u(ldu,*),v(ldv,*),work(*)
!
!
  integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, &
          mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
  double precision ddot,t
  double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn, &
                   smm1,t1,test,ztest
  logical wantu,wantv
!
!
!     set the maximum number of iterations.
!
  maxit = 30
!
!     determine what is to be computed.
!
  wantu = .false.
  wantv = .false.
  jobu = mod(job,100)/10
  ncu = n
  if (jobu > 1) ncu = min (n,p)
  if (jobu /= 0) wantu = .true.
  if (mod(job,10) /= 0) wantv = .true.
!
!     reduce x to bidiagonal form, storing the diagonal elements
!     in s and the super-diagonal elements in e.
!
  info = 0
  nct = min (n-1,p)
  nrt = max (0,min (p-2,n))
  lu = max (nct,nrt)
  if (lu < 1) go to 170
  do 160 l = 1, lu
     lp1 = l + 1
     if (l > nct) go to 20
!
!           compute the transformation for the l-th column and
!           place the l-th diagonal in s(l).
!
        s(l) = dnrm2(n-l+1,x(l,l),1)
        if (s(l) == 0.0d0) go to 10
           if (x(l,l) /= 0.0d0) s(l) = dsign(s(l),x(l,l))
           call dscal(n-l+1,1.0d0/s(l),x(l,l),1)
           x(l,l) = 1.0d0 + x(l,l)
   10       continue
        s(l) = -s(l)
   20    continue
     if (p < lp1) go to 50
     do 40 j = lp1, p
        if (l > nct) go to 30
        if (s(l) == 0.0d0) go to 30
!
!              apply the transformation.
!
           t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
           call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
   30       continue
!
!           place the l-th row of x into  e for the
!           subsequent calculation of the row transformation.
!
        e(j) = x(l,j)
   40    continue
   50    continue
     if (.not.wantu .or. l > nct) go to 70
!
!           place the transformation in u for subsequent back
!           multiplication.
!
        do 60 i = l, n
           u(i,l) = x(i,l)
   60       continue
   70    continue
     if (l > nrt) go to 150
!
!           compute the l-th row transformation and place the
!           l-th super-diagonal in e(l).
!
        e(l) = dnrm2(p-l,e(lp1),1)
        if (e(l) == 0.0d0) go to 80
           if (e(lp1) /= 0.0d0) e(l) = dsign(e(l),e(lp1))
           call dscal(p-l,1.0d0/e(l),e(lp1),1)
           e(lp1) = 1.0d0 + e(lp1)
   80       continue
        e(l) = -e(l)
        if (lp1 > n .or. e(l) == 0.0d0) go to 120
!
!              apply the transformation.
!
           do 90 i = lp1, n
              work(i) = 0.0d0
   90          continue
           do 100 j = lp1, p
              call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
  100          continue
           do 110 j = lp1, p
              call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1)
  110          continue
  120       continue
        if (.not.wantv) go to 140
!
!              place the transformation in v for subsequent
!              back multiplication.
!
           do 130 i = lp1, p
              v(i,l) = e(i)
  130          continue
  140       continue
  150    continue
  160 continue
  170 continue
!
!     set up the final bidiagonal matrix of order m.
!
  m = min (p,n+1)
  nctp1 = nct + 1
  nrtp1 = nrt + 1
  if (nct < p) s(nctp1) = x(nctp1,nctp1)
  if (n < m) s(m) = 0.0d0
  if (nrtp1 < m) e(nrtp1) = x(nrtp1,m)
  e(m) = 0.0d0
!
!     if required, generate u.
!
  if (.not.wantu) go to 300
     if (ncu < nctp1) go to 200
     do 190 j = nctp1, ncu
        do 180 i = 1, n
           u(i,j) = 0.0d0
  180       continue
        u(j,j) = 1.0d0
  190    continue
  200    continue
     if (nct < 1) go to 290
     do 280 ll = 1, nct
        l = nct - ll + 1
        if (s(l) == 0.0d0) go to 250
           lp1 = l + 1
           if (ncu < lp1) go to 220
           do 210 j = lp1, ncu
              t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
              call daxpy(n-l+1,t,u(l,l),1,u(l,j),1)
  210          continue
  220          continue
           call dscal(n-l+1,-1.0d0,u(l,l),1)
           u(l,l) = 1.0d0 + u(l,l)
           lm1 = l - 1
           if (lm1 < 1) go to 240
           do 230 i = 1, lm1
              u(i,l) = 0.0d0
  230          continue
  240          continue
        go to 270
  250       continue
           do 260 i = 1, n
              u(i,l) = 0.0d0
  260          continue
           u(l,l) = 1.0d0
  270       continue
  280    continue
  290    continue
  300 continue
!
!     if it is required, generate v.
!
  if (.not.wantv) go to 350
     do 340 ll = 1, p
        l = p - ll + 1
        lp1 = l + 1
        if (l > nrt) go to 320
        if (e(l) == 0.0d0) go to 320
           do 310 j = lp1, p
              t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
              call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
  310          continue
  320       continue
        do 330 i = 1, p
           v(i,l) = 0.0d0
  330       continue
        v(l,l) = 1.0d0
  340    continue
  350 continue
!
!     main iteration loop for the singular values.
!
  mm = m
  iter = 0
  360 continue
!
!        quit if all the singular values have been found.
!
!     ...exit
     if (m == 0) go to 620
!
!        if too many iterations have been performed, set
!        flag and return.
!
     if (iter < maxit) go to 370
        info = m
!    ....exit
        go to 620
  370    continue
!
!        this section of the program inspects for
!        negligible elements in the s and e arrays.  on
!        completion the variables kase and l are set as follows.
!
!           kase = 1     if s(m) and e(l-1) are negligible and l < m
!           kase = 2     if s(l) is negligible and l < m
!           kase = 3     if e(l-1) is negligible, l < m, and
!                        s(l), ..., s(m) are not negligible (qr step).
!           kase = 4     if e(m-1) is negligible (convergence).
!
     do 390 ll = 1, m
        l = m - ll
!        ...exit
        if (l == 0) go to 400
        test = dabs(s(l)) + dabs(s(l+1))
        ztest = test + dabs(e(l))
        if (ztest /= test) go to 380
           e(l) = 0.0d0
!       ....exit
           go to 400
  380       continue
  390    continue
  400    continue
     if (l /= m - 1) go to 410
        kase = 4
     go to 480
  410    continue
        lp1 = l + 1
        mp1 = m + 1
        do 430 lls = lp1, mp1
           ls = m - lls + lp1
!           ...exit
           if (ls == l) go to 440
           test = 0.0d0
           if (ls /= m) test = test + dabs(e(ls))
           if (ls /= l + 1) test = test + dabs(e(ls-1))
           ztest = test + dabs(s(ls))
           if (ztest /= test) go to 420
              s(ls) = 0.0d0
!          exit
              go to 440
  420          continue
  430       continue
  440       continue
        if (ls /= l) go to 450
           kase = 3
        go to 470
  450       continue
        if (ls /= m) go to 460
           kase = 1
        go to 470
  460       continue
           kase = 2
           l = ls
  470       continue
  480    continue
     l = l + 1
!
!        perform the task indicated by kase.
!
     go to (490,520,540,570), kase
!
!        deflate negligible s(m).
!
  490    continue
        mm1 = m - 1
        f = e(m-1)
        e(m-1) = 0.0d0
        do 510 kk = l, mm1
           k = mm1 - kk + l
           t1 = s(k)
           call drotg(t1,f,cs,sn)
           s(k) = t1
           if (k == l) go to 500
              f = -sn*e(k-1)
              e(k-1) = cs*e(k-1)
  500          continue
           if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn)
  510       continue
     go to 610
!
!        split at negligible s(l).
!
  520    continue
        f = e(l-1)
        e(l-1) = 0.0d0
        do 530 k = l, m
           t1 = s(k)
           call drotg(t1,f,cs,sn)
           s(k) = t1
           f = -sn*e(k)
           e(k) = cs*e(k)
           if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn)
  530       continue
     go to 610
!
!        perform one qr step.
!
  540    continue
!
!           calculate the shift.
!
        scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)), &
                      dabs(s(l)),dabs(e(l)))
        sm = s(m)/scale
        smm1 = s(m-1)/scale
        emm1 = e(m-1)/scale
        sl = s(l)/scale
        el = e(l)/scale
        b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0d0
        c = (sm*emm1)**2
        shift = 0.0d0
        if (b == 0.0d0 .and. c == 0.0d0) go to 550
           shift = dsqrt(b**2+c)
           if (b < 0.0d0) shift = -shift
           shift = c/(b + shift)
  550       continue
        f = (sl + sm)*(sl - sm) - shift
        g = sl*el
!
!           chase zeros.
!
        mm1 = m - 1
        do 560 k = l, mm1
           call drotg(f,g,cs,sn)
           if (k /= l) e(k-1) = f
           f = cs*s(k) + sn*e(k)
           e(k) = cs*e(k) - sn*s(k)
           g = sn*s(k+1)
           s(k+1) = cs*s(k+1)
           if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn)
           call drotg(f,g,cs,sn)
           s(k) = f
           f = cs*e(k) + sn*s(k+1)
           s(k+1) = -sn*e(k) + cs*s(k+1)
           g = sn*e(k+1)
           e(k+1) = cs*e(k+1)
           if (wantu .and. k < n) &
              call drot(n,u(1,k),1,u(1,k+1),1,cs,sn)
  560       continue
        e(m-1) = f
        iter = iter + 1
     go to 610
!
!        convergence.
!
  570    continue
!
!           make the singular value  positive.
!
        if (s(l) >= 0.0d0) go to 580
           s(l) = -s(l)
           if (wantv) call dscal(p,-1.0d0,v(1,l),1)
  580       continue
!
!           order the singular value.
!
  590       if (l == mm) go to 600
!           ...exit
           if (s(l) >= s(l+1)) go to 600
           t = s(l)
           s(l) = s(l+1)
           s(l+1) = t
           if (wantv .and. l < p) &
              call dswap(p,v(1,l),1,v(1,l+1),1)
           if (wantu .and. l < n) &
              call dswap(n,u(1,l),1,u(1,l+1),1)
           l = l + 1
        go to 590
  600       continue
        iter = 0
        m = m - 1
  610    continue
  go to 360
  620 continue
  return
end
subroutine dsvprd(a,n,x,y)
!
!*******************************************************************************
!
!! DSVPRD: ???
!
  double precision a(*),x(n),y(n)
  double precision xk,yk
  y(1) = a(1)*x(1)
  if (n == 1) return
!
  l = 1
  do 20 k = 2,n
  km1 = k - 1
  xk = x(k)
  yk = 0.d0
!
  do 10 i = 1,km1
  l = l + 1
  y(i) = y(i) + a(l)*xk
   10 yk = yk + a(l)*x(i)
!
  l = l + 1
   20 y(k) = yk + a(l)*xk
  return
end
subroutine dswap (n,dx,incx,dy,incy)
!
!*******************************************************************************
!
!! DSWAP interchanges two vectors.
!     uses unrolled loops for increments equal one.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dx(*),dy(*),dtemp
  integer i,incx,incy,ix,iy,m,mp1,n
!
  if(n <= 0)return
  if(incx==1.and.incy==1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
  ix = 1
  iy = 1
  if(incx < 0)ix = (-n+1)*incx + 1
  if(incy < 0)iy = (-n+1)*incy + 1
  do 10 i = 1,n
    dtemp = dx(ix)
    dx(ix) = dy(iy)
    dy(iy) = dtemp
    ix = ix + incx
    iy = iy + incy
   10 continue
  return
!
!       code for both increments equal to 1
!
!
!       clean-up loop
!
   20 m = mod(n,3)
  if( m == 0 ) go to 40
  do 30 i = 1,m
    dtemp = dx(i)
    dx(i) = dy(i)
    dy(i) = dtemp
   30 continue
  if( n < 3 ) return
   40 mp1 = m + 1
  do 50 i = mp1,n,3
    dtemp = dx(i)
    dx(i) = dy(i)
    dy(i) = dtemp
    dtemp = dx(i + 1)
    dx(i + 1) = dy(i + 1)
    dy(i + 1) = dtemp
    dtemp = dx(i + 2)
    dx(i + 2) = dy(i + 2)
    dy(i + 2) = dtemp
   50 continue
  return
end
subroutine dsymsv (a,c,n,na,nc,ierr)
!
!*******************************************************************************
!
!! DSYMSV solves the matrix equation transpose(a)*x + x*a = c
!     where a is in upper schur form and c is symmetric.
!
  integer n,na,nc,ierr
  double precision a(na,n), c(nc,n), sum, p(4), t(4,4)
  integer dk,dl,i,ia,j,k,kk,km1,l,ll,ldl
!
  l = 1
   10    dl = 1
     if (l == n) go to 20
     if (a(l+1,l) /= 0.d0) dl = 2
   20    ll = l + dl - 1
!
     k = l
   30       km1 = k - 1
        dk = 1
        if (k == n) go to 35
        if (a(k+1,k) /= 0.d0) dk = 2
   35       kk = k + dk - 1
        if (k == l) go to 45
!
        do 42 i = k,kk
           do 41 j = l,ll
           sum = c(i,j)
              do 40 ia = l,km1
   40             sum = sum - a(ia,i)*c(ia,j)
   41          c(i,j) = sum
   42       continue
!
   45       if (dl == 2) go to 60
        if (dk == 2 ) go to 50
        t(1,1) = a(k,k) + a(l,l)
        if (t(1,1) == 0.d0) go to 200
        c(k,l) = c(k,l)/t(1,1)
        ierr = 0
        go to 90
!
   50       t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(kk,k)
        t(2,1) = a(k,kk)
        t(2,2) = a(kk,kk) + a(l,l)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        call dpslv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        go to 90
!
   60       if (dk == 2) go to 70
        t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(ll,l)
        t(2,1) = a(l,ll)
        t(2,2) = a(k,k) + a(ll,ll)
        p(1) = c(k,l)
        p(2) = c(k,ll)
        call dpslv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(k,ll) = p(2)
        go to 90
!
   70       if (k /= l) go to 80
        t(1,1) = a(l,l)
        t(1,2) = a(ll,l)
        t(1,3) = 0.d0
        t(2,1) = a(l,ll)
        t(2,2) = a(l,l) + a(ll,ll)
        t(2,3) = t(1,2)
        t(3,1) = 0.d0
        t(3,2) = t(2,1)
        t(3,3) = a(ll,ll)
        p(1) = c(l,l)/2.d0
        p(2) = c(ll,l)
        p(3) = c(ll,ll)/2.d0
        call dpslv (3, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(l,l) = p(1)
        c(ll,l) = p(2)
        c(l,ll) = p(2)
        c(ll,ll) = p(3)
        go to 90
!
   80       t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(kk,k)
        t(1,3) = a(ll,l)
        t(1,4) = 0.d0
        t(2,1) = a(k,kk)
        t(2,2) = a(kk,kk) + a(l,l)
        t(2,3) = 0.d0
        t(2,4) = t(1,3)
        t(3,1) = a(l,ll)
        t(3,2) = 0.d0
        t(3,3) = a(k,k) + a(ll,ll)
        t(3,4) = t(1,2)
        t(4,1) = 0.d0
        t(4,2) = t(3,1)
        t(4,3) = t(2,1)
        t(4,4) = a(kk,kk) + a(ll,ll)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        p(3) = c(k,ll)
        p(4) = c(kk,ll)
        call dpslv (4, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        c(k,ll) = p(3)
        c(kk,ll) = p(4)
!
   90    k = k + dk
     if (k <= n) go to 30
  ldl = l + dl
  if (ldl > n) return
!
  do 121 j = ldl,n
     do 100 i = l,ll
        c(i,j) = c(j,i)
  100    continue
     do 120 i = j,n
        do 110 k = l,ll
  110       c(i,j) = c(i,j) - c(i,k)*a(k,j) - a(k,i)*c(k,j)
  120    c(j,i) = c(i,j)
  121 continue
  l = ldl
  go to 10
!
!     error return
!
  200 ierr = 1
  return
end
subroutine dtaslv (mo,n,a,na,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! DTASLV solves the real matrix equation transpose(a)*x + x*a = c
!     where c is a symmetric matrix. a is reduced to upper schur form
!     and the transformed system is solved.
!
!        mo is an input argument which specifies if the routine is
!     being called for the first time. on an initial call mo = 0 and
!     we have the following setup.
!
!        a(na,n)
!           a is a matrix of order n. it is assumed that
!           na >= n >= 1.
!
!        c(nc,n)
!           c is a symmetric matrix of order n. it is
!           assumed that nc >= n.
!
!        wk(---)
!           wk is an array of dimension n**2 + 2n that
!           is a general storage area for the routine.
!
!     ierr is a variable that reports the status of the results. when
!     the routine terminates, ierr has one of the following values...
!
!        ierr =  0  the solution was obtained and stored in c.
!        ierr =  1  the equations are inconsistent for a. the
!                   problem cannot be solved.
!        ierr = -1  a could not be reducedto upper schur form.
!                   the problem cannot be solved.
!
!     when ierr = 0, a contains the upper schur form of the matrix
!     a and wk contains the orthogonal matrix involved in the schur
!     decomposition of a. this information can be reused to solve a
!     new set of equations transpose(a)*x + x*a = c without having
!     to redecompose a. in this case, the input argument mo may be
!     set to any nonzero value. when mo /= 0, it is assumed that
!     only c has been modified. on output the solution for the new
!     set of equations is stored in c.
!
!     this subroutine is a modification by
!        Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!     of the subroutine atxpxa written by
!        r.h. bartels and g.w. stewart
!        university of texas at austin.
!
!     reference. bartels, r.h. and stewart, g.w., algorithm 432,
!        solution of the matrix equation ax + xb = c, comm. acm
!        15 (1972), pp. 820-826.
!
  double precision a(na,n), c(nc,n), wk(*)
!
  iw = n*n + 1
  call dtasv1 (mo,n,a,na,wk(1),n,c,nc,wk(iw),ierr)
  return
end
subroutine dtasv1 (mo,n,a,na,u,nu,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! DTASV1 solves the real matrix equation transpose(a)*x + x*a = c
!     where c is a symmetric matrix. a is reduced to upper schur form
!     and the transformed system is solved.
!
  double precision a(na,n), u(nu,n), c(nc,n), wk(*)
!
!    if required, reduce a to upper real schur form
!
  if (mo /= 0) go to 10
  call dorth (na,n,1,n,a,wk)
  call drtrn1 (n,1,n,a,na,u,nu,wk)
  call dschur (n,1,n,a,na,u,nu,wk(1),wk(n+1),ierr)
  if (ierr /= 0) go to 200
!
!     transform c
!
   10 do 20 i = 1,n
     c(i,i) = c(i,i)/2.d0
   20 continue
!
  do 41 i = 1,n
     do 31 j = 1,n
        wk(j) = 0.d0
        do k = i,n
           wk(j) = wk(j) + c(i,k)*u(k,j)
        end do
   31    continue
     do 40 j = 1,n
        c(i,j) = wk(j)
   40    continue
   41 continue
!
  do 61 j = 1,n
     do 51 i = 1,n
        wk(i) = 0.d0
        do 50 k = 1,n
           wk(i) = wk(i) + u(k,i)*c(k,j)
   50       continue
   51    continue
     do 60 i = 1,n
        c(i,j) = wk(i)
   60    continue
   61 continue
!
  do 71 i = 1,n
     do 70 j = i,n
        c(i,j) = c(i,j) + c(j,i)
        c(j,i) = c(i,j)
   70    continue
   71 continue
!
!     solve the transformed system
!
  call dsymsv (a,c,n,na,nc,ierr)
  if (ierr /= 0) go to 210
!
!     transform c back to the solution
!
  do 80 i = 1,n
     c(i,i) = c(i,i)/2.d0
   80 continue
!
  do 101 i = 1,n
     do 91 j = 1,n
        wk(j) = 0.d0
        do 90 k = i,n
           wk(j) = wk(j) + c(i,k)*u(j,k)
   90       continue
   91    continue
     do 100 j = 1,n
        c(i,j) = wk(j)
  100    continue
  101 continue
!
  do 121 j = 1,n
     do 111 i = 1,n
        wk(i) = 0.d0
        do 110 k = 1,n
           wk(i) = wk(i) + u(i,k)*c(k,j)
  110       continue
  111    continue
     do 120 i = 1,n
        c(i,j) = wk(i)
  120    continue
  121 continue
!
  do 131 i = 1,n
     do 130 j = i,n
        c(i,j) = c(i,j) + c(j,i)
        c(j,i) = c(i,j)
  130    continue
  131 continue
  return
!
!     error return
!
  200 ierr = -1
  return
  210 ierr = 1
  return
end
subroutine dtip (a, n1, n2, moved, nwork, ndim)
!
!*******************************************************************************
!
!! DTIP: transposition of a rectangular matrix in situ.
!
!
! by norman brenner, mit, 1/72.  cf. alg. 380, cacm, 5/70.
! transposition of the n1 by n2 matrix a amounts to
! replacing the element at vector position i (0-origin)
! with the element at position n1*i (mod n1*n2-1).
! each subcycle of this permutation is completed in order.
!
  double precision a(*)
  double precision atemp, btemp
  integer moved(nwork)
  integer ifact(8), ipower(8), nexp(8), iexp(8)
  if (n1 < 2 .or. n2 < 2) go to 200
  n12 = n1*n2
  n = n1
  m = n12 - 1
  if (n1/=n2) go to 30
! square matrices are done separately for speed
  i1min = 2
  do 20 i1max=n,m,n
    i2 = i1min + n - 1
    do 10 i1=i1min,i1max
      atemp = a(i1)
      a(i1) = a(i2)
      a(i2) = atemp
      i2 = i2 + n
   10   continue
    i1min = i1min + n + 1
   20 continue
  return
! modulus m is factored into prime powers.  eight factors
! suffice up to m = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 ndim = 0
  call infctr(m, ifact, ipower, nexp, npower)
  do 40 ip=1,npower
    iexp(ip) = 0
   40 continue
! generate every divisor of m less than m/2
  idiv = 1
  mhalf = m/2
   50 if (idiv >= mhalf) return
! the number of elements whose index is divisible by idiv
! and by no other divisor of m is the euler totient
! function, phi(m/idiv).
  ncount = m/idiv
  do 60 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 60
    ncount = (ncount/ifact(ip))*(ifact(ip)-1)
   60 continue
  if (nwork <= 0) go to 75
  do 70 i=1,nwork
    moved(i) = 0
   70 continue
   75 istart = idiv
! the starting point of a subcycle is divisible only by idiv
! and must not appear in any other subcycle.
   80 mmist = m - istart
  if (istart==idiv) go to 120
  ndim = max (ndim,istart)
  if (istart > nwork) go to 90
  if (moved(istart)/=0) go to 160
   90 isoid = istart/idiv
  do 100 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 100
    if (mod(isoid,ifact(ip))==0) go to 160
  100 continue
  if (istart <= nwork) go to 120
  itest = istart
  110 itest = mod(n*itest,m)
  if (itest < istart .or. itest > mmist) go to 160
  if (itest > istart .and. itest < mmist) go to 110
  120 atemp = a(istart+1)
  btemp = a(mmist+1)
  ia1 = istart
  130 ia2 = mod(n*ia1,m)
  mmia1 = m - ia1
  mmia2 = m - ia2
  if (ia1 <= nwork) moved(ia1) = 1
  if (mmia1 <= nwork) moved(mmia1) = 1
  ncount = ncount - 2
! move two elements, the second from the negative
! subcycle.  check first for subcycle closure.
  if (ia2==istart) go to 140
  if (mmia2==istart) go to 150
  a(ia1+1) = a(ia2+1)
  a(mmia1+1) = a(mmia2+1)
  ia1 = ia2
  go to 130
  140 a(ia1+1) = atemp
  a(mmia1+1) = btemp
  go to 160
  150 a(ia1+1) = btemp
  a(mmia1+1) = atemp
  160 istart = istart + idiv
  if (ncount > 0) go to 80
  do 180 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 170
    iexp(ip) = iexp(ip) + 1
    idiv = idiv*ifact(ip)
    go to 50
  170   iexp(ip) = 0
    idiv = idiv/ipower(ip)
  180 continue
  return
  200 if (n1/=n2) ndim = 0
  return
end
subroutine dtoplx (a, b, x, n, g, h, ierr)
!
!*******************************************************************************
!
!! DTOPLX: solution of the toeplitz system of equations
!
!               sum(j = 1,...,n) a(n+i-j)*x(j) = b(i)
!
!     for i = 1,...,n.
!
!     double precision a(2*n - 1)
!
  double precision a(*), b(n), x(n), g(n), h(n)
  double precision c, c1, c2, gd, gj, gk, gn, hj, hk, hn, xd, xn
!
  if (a(n) == 0.d0) go to 100
  ierr = 0
  x(1) = b(1)/a(n)
  if (n == 1) return
  g(1) = a(n - 1)/a(n)
  h(1) = a(n + 1)/a(n)
  mp1 = 1
!
!     compute numerator and denominator of x(m+1)
!
   10 m = mp1
  mp1 = m + 1
  xn = -b(mp1)
  xd = -a(n)
  do 20 j = 1,m
     l = mp1 - j
     npl = n + l
     xn = xn + a(npl)*x(j)
   20    xd = xd + a(npl)*g(l)
  if (xd == 0.d0) go to 100
  x(mp1) = xn/xd
!
!        compute x
!
  c = x(mp1)
  do 30 j = 1,m
     l = mp1 - j
   30    x(j) = x(j) - c*g(l)
  if (mp1 == n) return
!
!     compute numerator and denominator of g(m+1) and h(m+1)
!
  l = n - mp1
  gn = -a(l)
  gd = -a(n)
  l = n + mp1
  hn = -a(l)
  do 40 j = 1,m
     l = mp1 - j
     nml = n - l
     npl = n + l
     gn = gn + a(nml)*g(j)
     gd = gd + a(nml)*h(l)
   40    hn = hn + a(npl)*h(j)
  if (gd == 0.d0) go to 100
  g(mp1) = gn/gd
  h(mp1) = hn/xd
!
!     compute g and h
!
  c1 = g(mp1)
  c2 = h(mp1)
  max = mp1/2
  k = m
  do 50 j = 1,max
     gj = g(j)
     gk = g(k)
     hj = h(j)
     hk = h(k)
     g(j) = gj - c1*hk
     g(k) = gk - c1*hj
     h(j) = hj - c2*gk
     h(k) = hk - c2*gj
   50    k = k - 1
  go to 10
!
!     error return
!
  100 ierr = 1
  return
end
subroutine dtpose(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! DTPOSE makes a transposed copy of a double precision matrix.
!
  double precision a(ka,n),b(kb,m)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(j,i) = a(i,j)
   20 continue
  return
end
subroutine dtprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! DTPRD: product of a vector and a sparse matrix
!
  double precision a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 10 j = 1,n
     y(j) = 0.d0
   10 continue
!
  do 21 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 21
     do 20 l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
   20    continue
   21 continue
  return
end
subroutine dtprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! DTPRD1: set y = x*a + y where a is a sparse matrix and x,y are vectors
!
  double precision a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
   10    continue
   11 continue
  return
end
subroutine dtslv (m0,n,a,ia,ja,b,r,c,max2,x,iwk,wk,ierr)
!
!*******************************************************************************
!
!! DTSLV: solution of double precision sparse equations
!
!     dtslv employs gaussian elimination with column interchanges to
!     solve the nxn linear system xa = b. the argument m0 specifies
!     if dtslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to dtslv.
!
!
!     input arguments when m0=0---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the double precision matrix a stored in sparse form.
!
!     b        double precision array of n entries containing the
!              right hand side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2     integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        double precision array of n entries containing the
!              solution. b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       double precision array of dimension 2*n + max2.
!
!
!     after an initial call to dtslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to dtslv
!     and solves the new equations xa = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  double precision a(*), b(n), x(n), wk(*)
  integer ia(*), ja(*), iwk(*)
  integer r(n), c(n), y, t, p
!
!     set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if (m0 /= 0) go to 20
!
!     compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return
  do 10 k = 1,n
     l = c(k)
     iwk(l) = k
   10 continue
!
!     obtain the lu decomposition of a
!
  call dsplu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
               iwk(iu),wk(y),iwk(p),ierr)
  if (ierr < 0) return
  ierr = max (1,ierr)
!
!     solve the system of equations
!
   20 call dtslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                    b,x,wk(y))
  return
end
subroutine dtslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! DTSLV1: solve yu = b by forward substitution
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  double precision b(n), d(n), t(*), x(n), y(n)
!
  do 10 k = 1,n
     lk = c(k)
     y(k) = b(lk)
   10 continue
!
  do 21 k = 1,n
     if (y(k) == 0.d0) go to 21
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   20    continue
   21 continue
!
!            solve xl = y by backward substitution
!
  x(n) = y(n)/d(n)
  if (n == 1) return
!
  k = n
  y(n) = x(n)
  do 32 i = 2,n
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 31
     do 30 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   30    continue
   31    k = k - 1
     y(k) = y(k)/d(k)
   32 continue
!
  do 40 k = 1,n
     lk = r(k)
     x(lk) = y(k)
   40 continue
  return
end
subroutine dvprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! DVPRD: product of a sparse matrix and a vector
!
  double precision a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = 0.d0
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
   10    continue
   11 y(i) = sum
  return
end
subroutine dvprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! DVPRD1: set y = a*x + y where a is a sparse matrix and x,y are vectors
!
  double precision a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = y(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
   10    continue
   11 y(i) = sum
  return
end
subroutine dxfn (u,idmn,i,j,uxxx,uxxxx)
!
!*******************************************************************************
!
!! DXFN approximates the third and fourth x derivatives of u at a mesh point.
!
!
!     this program computes second order finite difference
!     approximations to the third and fourth x
!     partial derivatives of u at the (i,j) mesh point
!
  dimension       u(idmn,*)
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
  if (i > 2 .and. i < (k-1)) go to  50
  if (i == 1) go to  10
  if (i == 2) go to  30
  if (i == k-1) go to  60
  if (i == k) go to  80
!
!     compute partial derivative approximations at x=a
!
   10 if (kswx == 1) go to  20
  uxxx = (-5.0*u(1,j)+18.0*u(2,j)-24.0*u(3,j)+14.0*u(4,j)- &
                                                 3.0*u(5,j))/(tdlx3)
  uxxxx = (3.0*u(1,j)-14.0*u(2,j)+26.0*u(3,j)-24.0*u(4,j)+ &
                                        11.0*u(5,j)-2.0*u(6,j))/dlx4
  return
!
!     periodic at x=a
!
   20 uxxx = (-u(k-2,j)+2.0*u(k-1,j)-2.0*u(2,j)+u(3,j))/(tdlx3)
  uxxxx = (u(k-2,j)-4.0*u(k-1,j)+6.0*u(1,j)-4.0*u(2,j)+u(3,j))/dlx4
  return
!
!     compute partial derivative approximations at x=a+dlx
!
   30 if (kswx == 1) go to  40
  uxxx = (-3.0*u(1,j)+10.0*u(2,j)-12.0*u(3,j)+6.0*u(4,j)-u(5,j))/ &
         tdlx3
  uxxxx = (2.0*u(1,j)-9.0*u(2,j)+16.0*u(3,j)-14.0*u(4,j)+6.0*u(5,j)- &
                                                        u(6,j))/dlx4
  return
!
!     periodic at x=a+dlx
!
   40 uxxx = (-u(k-1,j)+2.0*u(1,j)-2.0*u(3,j)+u(4,j))/(tdlx3)
  uxxxx = (u(k-1,j)-4.0*u(1,j)+6.0*u(2,j)-4.0*u(3,j)+u(4,j))/dlx4
  return
!
!     compute partial derivative approximations on the interior
!
   50 continue
  uxxx = (-u(i-2,j)+2.0*u(i-1,j)-2.0*u(i+1,j)+u(i+2,j))/tdlx3
  uxxxx = (u(i-2,j)-4.0*u(i-1,j)+6.0*u(i,j)-4.0*u(i+1,j)+u(i+2,j))/ &
          dlx4
  return
!
!     compute partial derivative approximations at x=b-dlx
!
   60 if (kswx == 1) go to  70
  uxxx = (u(k-4,j)-6.0*u(k-3,j)+12.0*u(k-2,j)-10.0*u(k-1,j)+ &
                                                   3.0*u(k,j))/tdlx3
  uxxxx = (-u(k-5,j)+6.0*u(k-4,j)-14.0*u(k-3,j)+16.0*u(k-2,j)- &
                                       9.0*u(k-1,j)+2.0*u(k,j))/dlx4
  return
!
!     periodic at x=b-dlx
!
   70 uxxx = (-u(k-3,j)+2.0*u(k-2,j)-2.0*u(1,j)+u(2,j))/tdlx3
  uxxxx = (u(k-3,j)-4.0*u(k-2,j)+6.0*u(k-1,j)-4.0*u(1,j)+u(2,j))/ &
          dlx4
  return
!
!     compute partial derivative approximations at x=b
!
   80 uxxx = -(3.0*u(k-4,j)-14.0*u(k-3,j)+24.0*u(k-2,j)-18.0*u(k-1,j)+ &
                                                   5.0*u(k,j))/tdlx3
  uxxxx = (-2.0*u(k-5,j)+11.0*u(k-4,j)-24.0*u(k-3,j)+26.0*u(k-2,j)- &
                                      14.0*u(k-1,j)+3.0*u(k,j))/dlx4
  return
end
function dxparg (l)
!
!*******************************************************************************
!
!! DXPARG estimates the largest possible exponent for dexp.
!
!
!     if l = 0 then  dxparg(l) = the largest positive w for which
!     dexp(w) can be computed.
!
!     if l is nonzero then  dxparg(l) = the largest negative w for
!     which the computed value of dexp(w) is nonzero.
!
!     note... only an approximate value for dxparg(l) is needed.
!
  integer b
  double precision db
  double precision dxparg 
  double precision lnb
!
  b = ipmpar(4)
  if (b /= 2) go to 10
     lnb = .693147180559945309417232121458d+00
     go to 50
   10 if (b /= 8) go to 20
     lnb = 2.07944154167983592825169636437d+00
     go to 50
   20 if (b /= 16) go to 30
     lnb = 2.77258872223978123766892848583d+00
     go to 50
   30 db = b
  lnb = dlog(db)
!
   50 if (l == 0) go to 60
     m = ipmpar(9) - 1
     dxparg = 0.999999999999d+00 * (m * lnb)
     return
   60 m = ipmpar(10)
  dxparg = 0.999999999999d+00 * (m * lnb)
  return
end
subroutine dychg (x, y, yold)
!
!*******************************************************************************
!
!! DYCHG: ???
!
  double precision x(*), y(*), yold
!
  y(1) = 0.d0
  if (yold == 0.d0) y(1) = 1.d0
  return
end
subroutine dyfn (u,idmn,i,j,uyyy,uyyyy)
!
!*******************************************************************************
!
!! DYFN approximates the third and fourth y partial derivatives of u
!  at the (i,j) mesh point
!
  dimension       u(idmn,*)
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
  if (j > 2 .and. j < (l-1)) go to  50
  if (j == 1) go to  10
  if (j == 2) go to  30
  if (j == l-1) go to  60
  if (j == l) go to  80
!
!     compute partial derivative approximations at y=c
!
   10 if (kswy == 1) go to  20
  uyyy = (-5.0*u(i,1)+18.0*u(i,2)-24.0*u(i,3)+14.0*u(i,4)- &
                                                   3.0*u(i,5))/tdly3
  uyyyy = (3.0*u(i,1)-14.0*u(i,2)+26.0*u(i,3)-24.0*u(i,4)+ &
                                        11.0*u(i,5)-2.0*u(i,6))/dly4
  return
!
!     periodic at x=a
!
   20 uyyy = (-u(i,l-2)+2.0*u(i,l-1)-2.0*u(i,2)+u(i,3))/tdly3
  uyyyy = (u(i,l-2)-4.0*u(i,l-1)+6.0*u(i,1)-4.0*u(i,2)+u(i,3))/dly4
  return
!
!     compute partial derivative approximations at y=c+dly
!
   30 if (kswy == 1) go to  40
  uyyy = (-3.0*u(i,1)+10.0*u(i,2)-12.0*u(i,3)+6.0*u(i,4)-u(i,5))/ &
         tdly3
  uyyyy = (2.0*u(i,1)-9.0*u(i,2)+16.0*u(i,3)-14.0*u(i,4)+6.0*u(i,5)- &
                                                        u(i,6))/dly4
  return
!
!     periodic at y=c+dly
!
   40 uyyy = (-u(i,l-1)+2.0*u(i,1)-2.0*u(i,3)+u(i,4))/tdly3
  uyyyy = (u(i,l-1)-4.0*u(i,1)+6.0*u(i,2)-4.0*u(i,3)+u(i,4))/dly4
  return
!
!     compute partial derivative approximations on the interior
!
   50 continue
  uyyy = (-u(i,j-2)+2.0*u(i,j-1)-2.0*u(i,j+1)+u(i,j+2))/tdly3
  uyyyy = (u(i,j-2)-4.0*u(i,j-1)+6.0*u(i,j)-4.0*u(i,j+1)+u(i,j+2))/ &
          dly4
  return
!
!     compute partial derivative approximations at y=d-dly
!
   60 if (kswy == 1) go to  70
  uyyy = (u(i,l-4)-6.0*u(i,l-3)+12.0*u(i,l-2)-10.0*u(i,l-1)+ &
                                                   3.0*u(i,l))/tdly3
  uyyyy = (-u(i,l-5)+6.0*u(i,l-4)-14.0*u(i,l-3)+16.0*u(i,l-2)- &
                                       9.0*u(i,l-1)+2.0*u(i,l))/dly4
  return
!
!     periodic at y=d-dly
!
   70 continue
  uyyy = (-u(i,l-3)+2.0*u(i,l-2)-2.0*u(i,1)+u(i,2))/tdly3
  uyyyy = (u(i,l-3)-4.0*u(i,l-2)+6.0*u(i,l-1)-4.0*u(i,1)+u(i,2))/ &
          dly4
  return
!
!     compute partial derivative approximations at y=d
!
   80 uyyy = -(3.0*u(i,l-4)-14.0*u(i,l-3)+24.0*u(i,l-2)-18.0*u(i,l-1)+ &
                                                   5.0*u(i,l))/tdly3
  uyyyy = (-2.0*u(i,l-5)+11.0*u(i,l-4)-24.0*u(i,l-3)+26.0*u(i,l-2)- &
                                      14.0*u(i,l-1)+3.0*u(i,l))/dly4
  return
end
subroutine e1_values ( n, x, fx )
!
!*******************************************************************************
!
!! E1_VALUES returns some values of the exponential integral function EI(X).
!
!
!  Definition:
!
!    E1(X) = integral ( X <= T <= Infinity ) e-T / T dT
!
!  Modified:
!
!    22 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.559773595E+00, 0.454379503E+00, 0.373768843E+00, 0.310596579E+00, &
    0.260183939E+00, 0.219383934E+00, 0.185990905E+00, 0.158408437E+00, &
    0.135450958E+00, 0.116219313E+00, 0.100019582E+00, 0.086308334E+00, &
    0.074654644E+00, 0.064713129E+00, 0.056204378E+00, 0.048900511E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.5E+00,  0.6E+00,  0.7E+00,  0.8E+00, &
     0.9E+00,  1.0E+00,  1.1E+00,  1.2E+00, &
     1.3E+00,  1.4E+00,  1.5E+00,  1.6E+00, &
     1.7E+00,  1.8E+00,  1.9E+00,  2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine ei_values ( n, x, fx )
!
!*******************************************************************************
!
!! EI_VALUES returns some values of the exponential integral function EI(X).
!
!
!  Modified:
!
!    29 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.454219905E+00, 0.769881290E+00, 1.064907195E+00, 1.347396548E+00, &
    1.622811714E+00, 1.895117816E+00, 2.167378280E+00, 2.442092285E+00, &
    2.721398880E+00, 3.007207464E+00, 3.301285449E+00, 3.605319949E+00, &
    3.920963201E+00, 4.249867557E+00, 4.593713687E+00, 4.954234356E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.5E+00,  0.6E+00,  0.7E+00,  0.8E+00, &
     0.9E+00,  1.0E+00,  1.1E+00,  1.2E+00, &
     1.3E+00,  1.4E+00,  1.5E+00,  1.6E+00, &
     1.7E+00,  1.8E+00,  1.9E+00,  2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine eig (ibal,a,ka,n,wr,wi,ierr)
!
!*******************************************************************************
!
!! EIG computes the eigenvalues of a real matrix.
!
  real a(ka,n), wr(n), wi(n)
!
  low = 1
  igh = n
  if (ibal /= 0) call balanc (ka,n,a,low,igh,wr)
  call elmhs0 (ka,n,low,igh,a,wr)
  call hqr (ka,n,low,igh,a,wr,wi,ierr)
  return
end
subroutine eig1 (ibal,a,ka,n,wr,wi,ierr)
!
!*******************************************************************************
!
!! EIG1: eigenvalues of real matrices
!
  real a(ka,n), wr(n), wi(n)
!
  low = 1
  igh = n
  if (ibal /= 0) call balanc (ka,n,a,low,igh,wr)
  call orthes (ka,n,low,igh,a,wr)
  call hqr (ka,n,low,igh,a,wr,wi,ierr)
  return
end
subroutine eigv (ibal,a,ka,n,wr,wi,zr,zi,ierr)
!
!*******************************************************************************
!
!! EIGV: eigenvalues and eigenvectors of real matrices
!
  real a(ka,n), wr(n), wi(n), zr(ka,n), zi(ka,n)
!
  low = 1
  igh = n
  if (ibal /= 0) call balanc (ka,n,a,low,igh,zi)
  call elmhs0 (ka,n,low,igh,a,wr)
  call eltrn0 (ka,n,low,igh,a,wr,zr)
  call hqr2 (ka,n,low,igh,a,wr,wi,zr,ierr)
  if (ierr /= 0) return
  if (ibal /= 0) call balbak (ka,n,low,igh,zi,n,zr)
!
  do 30 k = 1,n
     if (wi(k)) 30,10,20
   10    do 11 j = 1,n
   11       zi(j,k) = 0.0
     go to 30
   20    kp1 = k + 1
     do 21 j = 1,n
        zi(j,k) = zr(j,kp1)
        zr(j,kp1) = zr(j,k)
   21       zi(j,kp1) = -zi(j,k)
   30 continue
  return
end
subroutine eigv1 (ibal,a,ka,n,wr,wi,zr,zi,ierr)
!
!*******************************************************************************
!
!! EIGV1: eigenvalues and eigenvectors of real matrices
!
  real a(ka,n), wr(n), wi(n), zr(ka,n), zi(ka,n)
!
  low = 1
  igh = n
  if (ibal /= 0) call balanc (ka,n,a,low,igh,zi)
  call orthes (ka,n,low,igh,a,wr)
  call ortran (ka,n,low,igh,a,wr,zr)
  call hqr2 (ka,n,low,igh,a,wr,wi,zr,ierr)
  if (ierr /= 0) return
  if (ibal /= 0) call balbak (ka,n,low,igh,zi,n,zr)
!
  do 30 k = 1,n
     if (wi(k)) 30,10,20
   10    do 11 j = 1,n
   11       zi(j,k) = 0.0
     go to 30
   20    kp1 = k + 1
     do 21 j = 1,n
        zi(j,k) = zr(j,kp1)
        zr(j,kp1) = zr(j,k)
   21       zi(j,kp1) = -zi(j,k)
   30 continue
  return
end
subroutine ekl ( l, fk, fl, ek, el, gk, gl )
!
!*******************************************************************************
!
!! EKL computes the complete elliptic integrals f(k), f(l), e(k), e(l)
!  for a given value of l2, where l2 = l**2 and k**2 + l**2 = 1.
!
!     it is assumed that -pi < arg(l2) <= pi for the resulting
!     value for f(k) to be meaningful.  
!
!  The combinations of functions
!     g(k) = e(k) - l**2*f(k)
!     g(l) = e(l) - k**2*f(l) 
!  are also calculated.
!
  complex l,l2,fk,fl,ek,el,gk,gl
!
  complex an,cn,en,s1,s2,s3,s4,s5,s6,s7,w
  real ln4
!
  data hpi /1.5707963267949/
  data ln4 /1.3862943611199/
!
  eps = epsilon ( eps )
!
!            the logarithmic expansions are used for f(k) and e(k)
!            and the maclaurin expansions for f(l) and e(l)
!
  tol = max ( eps,1.e-14)
  l2 = l*l
  s1 = (0.0, 0.0)
  s2 = (0.0, 0.0)
  s3 = (0.0, 0.0)
  s4 = (0.0, 0.0)
  s5 = (0.0, 0.0)
  s6 = (0.0, 0.0)
  s7 = (0.0, 0.0)
  an = (1.0, 0.0)
  bn = 0.0
  do 10 i = 1,300
     ri = i
     c = ((ri - 0.5)/ri)**2
     an = c*(an*l2)
     bn = bn + 1.0/(ri*(2.0*ri - 1.0))
     cn = an/(2.0*ri - 1.0)
     dn = bn*ri/(ri - 0.5)
     en = cn/(2.0*ri - 1.0)
     fn = ri/(ri - 0.5)
     gn = 0.5/(ri + 1.0)
     s1 = s1 + an
     s2 = s2 + an*bn
     s3 = s3 - cn
     s4 = s4 + an*dn
     s5 = s5 + en
     s6 = s6 + an*fn
     s7 = s7 + an*gn
     if (abs(real(an)) + abs(aimag(an)) < tol) go to 20
   10 continue
   20 s1 = s1 + (1.0, 0.0)
  s3 = s3 + (1.0, 0.0)
  s5 = s5 + (1.0, 0.0)
  s7 = s7 + (0.5, 0.0)
!
!              set w = 0.5*clog(16.0/l2)
!
  x = real(l)
  y = aimag(l)
  if (x /= 0.0) go to 30
     w = cmplx(ln4 - alog(abs(y)), hpi)
     go to 50
!
   30 if (abs(x) > abs(y)) go to 31
     u = (ln4 - 0.5*alnrel((x/y)**2)) - alog(abs(y))
     go to 40
   31 u = (ln4 - 0.5*alnrel((y/x)**2)) - alog(abs(x))
!
   40 if (x > 0.0) go to 41
     w = cmplx(u, -atan2(-y,-x))
     go to 50
   41 w = cmplx(u, -atan2(y,x))
!
!              final assembly
!
   50 fk = w*s1 - s2
  fl = hpi*s1
  ek = w*s6 - s4 + s5
  el = hpi*s3
  gk = -w*s7*l2 -s4 + s5 + s2*l2
  gl = hpi*s7*l2
  return
end
subroutine ekm ( k2, fk, ek )
!
!*******************************************************************************
!
!! EKM computes the complete elliptic integrals f(k) and e(k)
!  for a given value of k2 = k**2 by use of the maclaurin expansions.
!
  complex k2,fk,ek
  complex an,cn,s1,s2
!
  data hpi /1.5707963267949/
!
  eps = epsilon ( eps )
  tol = max ( eps, 1.0e-14 )
  s1 = (1.0, 0.0)
  s2 = (1.0, 0.0)
  an = (1.0, 0.0)

  do i = 1, 50

    ri = i
    c = ((ri - 0.5)/ri)**2
    an = c*(an*k2)
    cn = an/(2.0*ri - 1.0)
    s1 = s1 + an
    s2 = s2 - cn

    if ( abs(real(an)) + abs(aimag(an)) < tol )  then
      exit
    end if

  end do

  fk = hpi*s1
  ek = hpi*s2

  return
end
subroutine ellpf ( u, k, l, s, c, d, ierr )
!
!*******************************************************************************
!
!! ELLPF calculates the Jacobi elliptic functions sn(u,k), cn(u,k), and dn(u,k).
!
!
!  for real u and real modulus k.  it is assumed that
!     abs(k) <= 1. and k**2 + l**2 = 1.
!
  integer imax
  real k
  real l
!
  data pihalf /1.5707963267949/
!
  imax = huge ( imax )
  eps = epsilon ( eps )
!
!     calculation for l = 0.0
!
  if (l /= 0.0) go to 10
  s = tanh(u)
  e = exp(-abs(u))
  c = 2.0*e/(1.0 + e*e)
  d = c
  ierr = 0
  return
!
!     check that k**2 + l**2 = 1
!
   10 tol = 2.0*eps
  z = dble(k*k) + (dble(l*l) - 1.d0)
  if (abs(z) > tol) go to 100
!
  f = pihalf
  if (k /= 0.0) call ellpi(pihalf,0.0,k,l,f,e,ierr)
  f2 = 2.0*f
!
!                   argument reduction
!
  u1 = abs(u)
  r = u1/f2
  if (r >= amin1(real(imax),1.0/eps)) go to 110
  n = int(r)
  u1 = u1 - real(n)*f2
  sg = 1.0
  if (mod(n,2) /= 0) sg = -1.0
!
  if (u1 <= 0.0) go to 30
  if (u1 <= f) go to 20
  u1 = u1 - f2
  sg = -sg
  if (u1 >= 0.0) go to 30
!
!     calculation of elliptic functions for 0.0 <= u2 <= f(k)
!
   20 u2 = abs(u1)
  call scd (u2,abs(k),abs(l),f,s,c,d)
  ierr = 0
  if (u1 < 0.0) s = -s
!
!     final assembly
!
  s = sg*s
  c = sg*c
  if (u < 0.0) s = -s
  return
!
!             u is an integer multiple of f2
!
   30 s = 0.0
  c = sg
  d = 1.0
  ierr = 0
  return
!
!                      error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
end
subroutine ellpi ( phi, cphi, k, l, f, e, ierr )
!
!*******************************************************************************
!
!! ELLPI: real elliptic integrals of the first and second kinds
!
!
!     phi = argument                    (0.0 <= phi  <= pi/2)
!     cphi = pi/2 - phi                 (0.0 <= cphi <= pi/2)
!     k = modulus                       (abs(k) <= 1.0)
!     l = comodulus = sqrt (1 - k*k)    (abs(l) <= 1.0)
!     f = elliptic integral of first kind = f(phi, k)
!     e = elliptic integral of second kind = e(phi, k)
!     ierr = error indicator (ierr = 0  if no errors)
!
  real k, l, k2, l2, ln4
!
!     ln4 = ln(4)
!     th1 = tanh(1)
!
  data ln4/1.3862943611199/
  data th1/.76159415595576/
!
  if (phi < 0.0 .or. cphi  <  0.0) go to 100
  if (abs(k) > 1.0 .or. abs(l)  >  1.0) go to 110
  ierr = 0
  if (phi /= 0.0) go to 10
     f = 0.0
     e = 0.0
     return
!
   10 if (phi < 0.79) go to 11
     sn = cos(cphi)
     cn = sin(cphi)
     go to 20
   11 sn = sin(phi)
  cn = cos(phi)
!
   20 k2 = k*k
  l2 = l*l
  ss = sn*sn
  px = abs(k*sn)
  qx = abs(k*cn)
  if (px >= th1) go to 50
!
!     series expansion for abs(k*sin(phi)) <= tanh(1)
!
  pn = 1.0
  qn = 2.0
  an = phi
  hn = 1.0
  s1 = 0.0
  s2 = 0.0
  tr = phi*ss
  ts = sn*cn
!
   30 an = (pn*an - ts)/qn
  r  = k2*hn/qn
  s2 = s2 + r*an
  hn = pn*r
  s0 = s1
  s1 = s1 + hn*an
  if (abs(tr) < abs(an)) go to 40
  if (abs(s1) <= abs(s0)) go to 40
  pn = qn + 1.0
  qn = pn + 1.0
  tr = ss*tr
  ts = ss*ts
  go to 30
!
   40 f = phi + s1
  e = phi - s2
  return
!
!     series expansion for abs(k*sin(phi)) > tanh(1)
!
   50 r = cpabs(l,qx)
  if (r == 0.0) go to 120
  r2 = r*r
  si = 1.0
  sj = 1.0
  sk = 0.0
  rm = 0.0
  rn = 0.0
  s1 = 0.0
  s2 = 0.0
  s3 = 0.0
  s4 = 0.0
  td = qx*r
  dn = 2.0
  go to 70
!
   60 si = ri
  sj = rj
  sk = rk
  dn = dn + 2.0
  td = r2*td
   70 pn = (dn - 1.0)/dn
  qn = (dn + 1.0)/(dn + 2.0)
  ri = pn*si
  rj = pn*pn*l2*sj
  rk = sk + 2.0/(dn*(dn - 1.0))
  r0 = td/dn
  rm = qn*qn*l2*(rm - r0*ri)
  rn = pn*qn*l2*(rn - r0*si)
  d1 = rj
  d2 = qn*rj
  d3 = rm - rj*rk
  d4 = rn - pn*l2*sj*rk + l2*sj/(dn*dn)
  r0 = s3
  s1 = s1 + d1
  s2 = s2 + d2
  s3 = s3 + d3
  s4 = s4 + d4
  if (s3 < r0) go to 60
!
  w = 1.0 + px
  p = ln4 - alog(r + qx)
  t1 = (1.0 + s1)*p + qx/r*alnrel(-0.5*r2/w)
  t2 = (0.5 + s2)*l2*p + (1.0 - qx*r/w)
  f = t1 + s3
  e = t2 + s4
  return
!
!     error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
  120 ierr = 3
  return
end
subroutine elmhes ( nm, n, low, igh, a, ind )
!
!*******************************************************************************
!
!! ELMHES transforms a real general matrix to upper Hessenberg form.
!
!
!  Discussion:
!
!    Given a real general matrix, this subroutine reduces a submatrix
!    situated in rows and columns LOW through IGH to upper Hessenberg
!    form by stabilized elementary similarity transformations.
!
!  Reference:
!
!    Martin and Wilkinson,
!    ELMHES,
!    Numerische Mathematik,
!    Volume 12, pages 349-368, 1968.
!
!    J H Wilkinson and C Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer NM, the leading dimension of the array A.
!    NM must be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer LOW, IGH, are determined by the balancing routine
!    BALANC.  If BALANC has not been used, set LOW = 1, IGH = N.
!
!    Input/output, real A(NM,N).  On input, the matrix to be reduced.
!    On output, the Hessenberg matrix.  The multipliers
!    which were used in the reduction are stored in the
!    remaining triangle under the Hessenberg matrix.
!
!    Output, integer IND(N), contains information on the rows and columns
!    interchanged in the reduction.  Only elements LOW through IGH are used.
!
  integer igh
  integer n
  integer nm
!
  real a(nm,n)
  integer i
  integer ind(igh)
  integer j
  integer la
  integer low
  integer m
  real x
  real y
!
  la = igh - 1

  do m = low + 1, la

    x = 0.0E+00
    i = m

    do j = m, igh
      if ( abs ( a(j,m-1) ) > abs ( x ) ) then
        x = a(j,m-1)
        i = j
      end if
    end do

    ind(m) = i
!
!  Interchange rows and columns of the matrix.
!
    if ( i /= m ) then

      do j = m-1, n
        call r_swap ( a(i,j), a(m,j) )
      end do

      do j = 1, igh
        call r_swap ( a(j,i), a(j,m) )
      end do

    end if

    if ( x /= 0.0E+00 ) then

      do i = m+1, igh

        y = a(i,m-1)

        if ( y /= 0.0E+00 ) then

          y = y / x
          a(i,m-1) = y

          do j = m, n
            a(i,j) = a(i,j) - y * a(m,j)
          end do

          do j = 1, igh
            a(j,m) = a(j,m) + y * a(j,i)
          end do

        end if

      end do

    end if

  end do

  return
end
subroutine elmhs0(nm,n,low,igh,a,int)
!
!*******************************************************************************
!
!! ELMHS0 reduces a matrix to upper hessenberg form.
!
!  The routine uses stabilized elementary transforms.
!
!     given a real general matrix, this subroutine
!     reduces a submatrix situated in rows and columns
!     low through igh to upper hessenberg form by
!     stabilized elementary similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains the input matrix.
!
!     on output-
!
!        a contains the hessenberg matrix.  the multipliers
!          which were used in the reduction are stored in the
!          remaining triangle under the hessenberg matrix,
!
!        int contains information on the rows and columns
!          interchanged in the reduction.
!          only elements low through igh are used.
!
  integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1
  real a(nm,n)
  real x,y
!     real abs
  real int(igh)
!
  la = igh - 1
  kp1 = low + 1
  if (la < kp1) go to 200
!
  do 180 m = kp1, la
     mm1 = m - 1
     x = 0.0
     i = m
!
     do 100 j = m, igh
        if (abs(a(j,mm1)) <= abs(x)) go to 100
        x = a(j,mm1)
        i = j
  100    continue
!
     int(m) = i
     if (i == m) go to 130
!    ********** interchange rows and columns of a.
     do 110 j = mm1, n
        y = a(i,j)
        a(i,j) = a(m,j)
        a(m,j) = y
  110    continue
!
     do 120 j = 1, igh
        y = a(j,i)
        a(j,i) = a(j,m)
        a(j,m) = y
  120    continue
!  end interchange.
  130    if (x == 0.0) go to 180
     mp1 = m + 1
!
     do 160 i = mp1, igh
        y = a(i,mm1)
        if (y == 0.0) go to 160
        y = y / x
        a(i,mm1) = y
!
        do 140 j = m, n
  140       a(i,j) = a(i,j) - y * a(m,j)
!
        do 150 j = 1, igh
  150       a(j,m) = a(j,m) + y * a(j,i)
!
  160    continue
!
  180 continue
!
  200 return
end
subroutine elpfc1 (u,k,l,s,c,d,ierr)
!
!*******************************************************************************
!
!! ELPFC1 calculates the elliptic functions sn(u,k), cn(u,k), dn(u,k)
!  for complex u and real modulus k.  it is assumed that
!     abs(k) <= 1. and k**2 + l**2 = 1.
!
  complex u, s, c, d
  real k, l, k2
!
  u1 = real(u)
  u2 = aimag(u)
  k2 = k*k
  if (u1 == 0.0) go to 10
  if (u2 /= 0.0) go to 20
!
!     calculation for u2 = 0.
!
  call ellpf (u1,k,l,s1,c1,d1,ierr)
  if (ierr /= 0) return
  s2 = 0.0
  c2 = 0.0
  d2 = 0.0
  go to 40
!
!     calculation for u1 = 0.
!
   10 call ellpf (u2,l,k,s2,c2,d2,ierr)
  if  (ierr /= 0) return
  if (c2 == 0.0) go to 50
  s1 = 0.0
  s2 = s2/c2
  d1 = d2/c2
  d2 = 0.0
  c1 = 1.0/c2
  c2 = 0.0
  go to 40
!
!     calculation for u1 and u2 /= 0.
!
   20 call ellpf (u1,k,l,sk,ck,dk,ierr)
  if (ierr /= 0) return
  call ellpf (u2,l,k,sl,cl,dl,ierr)
  if (ierr /= 0) return
  coef = abs(k)*sl
  t1 = cl
  t2 = coef*sk
  td1 = coef*t1
  td2 = coef*t2
  if (abs(t2) <= abs(t1)) go to 30
  if (t2 == 0.0) go to 50
  if (td2 == 0.0) go to 50
  t = t1/t2
  r = 1.0/(1.0 + t*t)
  s1 = dl*r/td2
  s2 = ck*dk*sl*t*r/t2
  c1 = ck*t*r/t2
  c2 = -dk*sl*dl*r/td2
  d1 = dk*dl*t*r/t2
  d2 = -k2*ck*sl*r/td2
  go to 40
   30 if (t1 == 0.0) go to 50
  if (td1 == 0.0) go to 50
  t = t2/t1
  r = 1.0/(1.0 + t*t)
  s1 = dl*t*r/td1
  s2 = ck*dk*sl*r/t1
  c1 = ck*r/t1
  c2 = -dk*sl*dl*t*r/td1
  d1 = dk*dl*r/t1
  d2 = -k2*ck*sl*t*r/td1
!
!     final assembly
!
   40 s = cmplx (s1, s2)
  c = cmplx (c1, c2)
  d = cmplx (d1, d2)
  return
!
!     error return
!
   50 ierr = 3
  return
end
subroutine eltran(nm,n,low,igh,a,int,z)
!
!*******************************************************************************
!
!! ELTRAN accumulates the stabilized elementary similarity transformations used
!  in the reduction of a
!     real general matrix to upper hessenberg form by  elmhes.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains the multipliers which were used in the
!          reduction by  elmhes  in its lower triangle
!          below the subdiagonal,
!
!        int contains information on the rows and columns
!          interchanged in the reduction by  elmhes.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by  elmhes.
!
!
  integer i,j,n,kl,mm,mp,nm,igh,low,mp1
  real a(nm,igh),z(nm,n)
  integer int(igh)
!
!     ********** initialize z to identity matrix.
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.0
!
     z(i,i) = 1.0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!     ********** for mp=igh-1 step -1 until low+1 do
  do 140 mm = 1, kl
     mp = igh - mm
     mp1 = mp + 1
!
     do 100 i = mp1, igh
  100    z(i,mp) = a(i,mp-1)
!
     i = int(mp)
     if (i == mp) go to 140
!
     do 130 j = mp, igh
        z(mp,j) = z(i,j)
        z(i,j) = 0.0
  130    continue
!
     z(i,mp) = 1.0
  140 continue
!
  200 return
end
subroutine eltrn0(nm,n,low,igh,a,int,z)
!
!*******************************************************************************
!
!! ELTRN0 accumulates the stabilized elementary similarity transformations
!  used in the reduction of a
!     real general matrix to upper hessenberg form by  elmhs0.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains the multipliers which were used in the
!          reduction by  elmhs0  in its lower triangle
!          below the subdiagonal,
!
!        int contains information on the rows and columns
!          interchanged in the reduction by  elmhs0.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by  elmhs0.
!
  integer i,j,n,kl,mm,mp,nm,igh,low,mp1
  real a(nm,igh),z(nm,n)
  real int(igh)
!
!
!     ********** initialize z to identity matrix.
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.0
!
     z(i,i) = 1.0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!     ********** for mp=igh-1 step -1 until low+1 do
  do 140 mm = 1, kl
     mp = igh - mm
     mp1 = mp + 1
!
     do 100 i = mp1, igh
  100    z(i,mp) = a(i,mp-1)
!
     i = int(mp)
     if (i == mp) go to 140
!
     do 130 j = mp, igh
        z(mp,j) = z(i,j)
        z(i,j) = 0.0
  130    continue
!
     z(i,mp) = 1.0
  140 continue
!
  200 return
end
function enorm ( n, x )
!
!*******************************************************************************
!
!! ENORM computes the Euclidean norm of a vector.
!
!
!  Discussion:
!
!    The Euclidean norm is computed by accumulating the sum of
!    squares in three different sums.  The sums of squares for the
!    small and large components are scaled so that no overflows
!    occur.  Non-destructive underflows are permitted.  Underflows
!    and overflows do not occur in the computation of the unscaled
!    sum of squares for the intermediate components.
!
!    The definitions of small, intermediate and large components
!    depend on two constants, RDWARF and RGIANT.  The main
!    restrictions on these constants are that RDWARF**2 not
!    underflow and RGIANT**2 not overflow.
!
!  Reference:
!
!    More, Garbow and Hillstrom,
!    User Guide for MINPACK-1
!    Argonne National Laboratory,
!    Argonne, Illinois.
!
!  Parameters:
!
!    Input, integer N, is the length of the vector.
!
!    Input, real X(N), the vector whose norm is desired.
!
!    Output, real ENORM, the Euclidean norm of the vector.
!
  integer n
!
  real agiant
  real enorm
  integer i
  real rdwarf
  real rgiant
  real s1
  real s2
  real s3
  real x(n)
  real xabs
  real x1max
  real x3max
!
  rdwarf = sqrt ( tiny ( rdwarf ) )
  rgiant = sqrt ( huge ( rgiant ) )

  s1 = 0.0E+00
  s2 = 0.0E+00
  s3 = 0.0E+00
  x1max = 0.0E+00
  x3max = 0.0E+00
  agiant = rgiant / real ( n )

  do i = 1, n

    xabs = abs ( x(i) )

    if ( xabs <= rdwarf ) then

      if ( xabs > x3max ) then
        s3 = 1.0E+00 + s3 * ( x3max / xabs )**2
        x3max = xabs
      else if ( xabs /= 0.0E+00 ) then
        s3 = s3 + ( xabs / x3max )**2
      end if

    else if ( xabs >= agiant ) then

      if ( xabs > x1max ) then
        s1 = 1.0E+00 + s1 * ( x1max / xabs )**2
        x1max = xabs
      else
        s1 = s1 + ( xabs / x1max )**2
      end if

    else

      s2 = s2 + xabs**2

    end if

  end do
!
!  Calculation of norm.
!
  if ( s1 /= 0.0E+00 ) then

    enorm = x1max * sqrt ( s1 + ( s2 / x1max ) / x1max )

  else if ( s2 /= 0.0E+00 ) then

    if ( s2 >= x3max ) then
      enorm = sqrt ( s2 * ( 1.0E+00 + ( x3max / s2 ) * ( x3max * s3 ) ) )
    else
      enorm = sqrt ( x3max * ( ( s2 / x3max ) + ( x3max * s3 ) ) )
    end if

  else

    enorm = x3max * sqrt ( s3 )

  end if

  return
end
subroutine epi (phi, cphi, k2, l2, n, m, p, ierr)
!
!*******************************************************************************
!
!! EPI: real elliptic integral of the third kind
!
  real phi, cphi, k2, l2, n, m, p
  real a, b, c, eps, pihalf, r, rf, s, s2, tol
!
  data pihalf /1.5707963267948966192/
!
  eps = epsilon ( eps )
  tol = 4.0 * eps
  if (amin1(phi,cphi) < 0.0) go to 100
  if (abs((phi + cphi) - pihalf) > tol * pihalf) go to 100
  if (abs(n) > 1.0) go to 110
  if (k2 < 0.0 .or. l2  <  0.0) go to 120
  if (abs((k2 + l2) - 1.0) > tol) go to 120
!
  if (phi < 0.79) go to 10
      s = cos(cphi)
      c = sin(cphi)
      go to 11
   10 s = sin(phi)
  c = cos(phi)
   11 a = c*c
  b = l2 + k2*a
  s2 = s*s
!
  if (n > 0.0) go to 20
      r = 1.0 - n*s2
      go to 30
   20 if (m < 0.0 .or. m > 1.0) go to 110
  if (abs((m + n) - 1.0) > tol) go to 110
  r = m + n*a
!
   30 call rjval (a, b, 1.0, r, p, ierr)
  if (ierr /= 0) go to 130
  p = p * (s * s2) * n/3.0
  call rfval (a, b, 1.0, rf, ierr)
  p = p + s * rf
  return
!
!     error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
  120 ierr = 3
  return
  130 ierr = 4
  return
end
function erf ( x )
!
!*******************************************************************************
!
!! ERF: evaluation of the real error function
!
  real a(4),b(4)
  real erf
  real p(8),q(8),r(5),s(5)
!
  data c/.564189583547756/
!
  data a(1)/-1.65581836870402e-4/, a(2)/3.25324098357738e-2/, &
       a(3)/1.02201136918406e-1/,  a(4)/1.12837916709552e00/
  data b(1)/4.64988945913179e-3/,  b(2)/7.01333417158511e-2/, &
       b(3)/4.23906732683201e-1/,  b(4)/1.00000000000000e00/
  data p(1)/-1.36864857382717e-7/, p(2)/5.64195517478974e-1/, &
       p(3)/7.21175825088309e00/,  p(4)/4.31622272220567e01/, &
       p(5)/1.52989285046940e02/,  p(6)/3.39320816734344e02/, &
       p(7)/4.51918953711873e02/,  p(8)/3.00459261020162e02/
  data q(1)/1.00000000000000e00/,  q(2)/1.27827273196294e01/, &
       q(3)/7.70001529352295e01/,  q(4)/2.77585444743988e02/, &
       q(5)/6.38980264465631e02/,  q(6)/9.31354094850610e02/, &
       q(7)/7.90950925327898e02/,  q(8)/3.00459260956983e02/
  data r(1)/2.10144126479064e00/,  r(2)/2.62370141675169e01/, &
       r(3)/2.13688200555087e01/,  r(4)/4.65807828718470e00/, &
       r(5)/2.82094791773523e-1/
  data s(1)/9.41537750555460e01/,  s(2)/1.87114811799590e02/, &
       s(3)/9.90191814623914e01/,  s(4)/1.80124575948747e01/, &
       s(5)/1.00000000000000e00/
!
  ax = abs(x)
  if (ax >= 0.5) go to 10
  t = x*x
  top = ((a(1)*t + a(2))*t + a(3))*t + a(4)
  bot = ((b(1)*t + b(2))*t + b(3))*t + b(4)
  erf = x*top/bot
  return
!
   10 if (ax > 4.0) go to 20
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax &
                      + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax &
                      + q(6))*ax + q(7))*ax + q(8)
  erf = 0.5 + (0.5 - exp(-x*x)*top/bot)
  if (x < 0.0) erf = -erf
  return
!
   20 erf = 1.0
  if (ax >= 5.6) go to 21
  x2 = x*x
  t = 1.0/x2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + s(5)
  erf = (c - top/(x2*bot)) / ax
  erf = 0.5 + (0.5 - exp(-x2)*erf)
   21 if (x < 0.0) erf = -erf
  return
end
subroutine erf_values ( n, x, fx )
!
!*******************************************************************************
!
!! ERF_VALUES returns some values of the ERF or "error" function for testing.
!
!
!  Modified:
!
!    17 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 21
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.0000000000E+00, 0.1124629160E+00, 0.2227025892E+00, 0.3286267595E+00, &
    0.4283923550E+00, 0.5204998778E+00, 0.6038560908E+00, 0.6778011938E+00, &
    0.7421009647E+00, 0.7969082124E+00, 0.8427007929E+00, 0.8802050696E+00, &
    0.9103139782E+00, 0.9340079449E+00, 0.9522851198E+00, 0.9661051465E+00, &
    0.9763483833E+00, 0.9837904586E+00, 0.9890905016E+00, 0.9927904292E+00, &
    0.9953222650E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00, &
    0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00, &
    0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00, &
    1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00, &
    1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00, &
    2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
function erf0(a)
!
!*******************************************************************************
!
!! ERF0: evaluation of erf(a) for 0 <= a <= 4
!
  data p0/2.13853322378e+01/, p1/1.72227577039e+00/, &
       p2/3.16652890658e-01/
  data q0/1.89522572415e+01/, q1/7.84374570830e+00/
!
  data r0/7.3738883116e+00/, r1/6.8650184849e+00/, &
       r2/3.0317993362e+00/, r3/5.6316961891e-01/, &
       r4/4.3187787405e-05/
  data s0/7.3739608908e+00/, s1/1.5184908190e+01/, &
       s2/1.2795529509e+01/, s3/5.3542167949e+00/
!
  t = a*a
  if (a > 0.5) go to 10
      erf0 = a*((p2*t + p1)*t + p0)/((t + q1)*t + q0)
      return
   10 w = ((((r4*a + r3)*a + r2)*a + r1)*a + r0)/ &
         ((((a + s3)*a + s2)*a + s1)*a + s0)
  erf0 = 1.0 - exp(-t)*w
  return
end
function erfc (x)
!
!*******************************************************************************
!
!! ERFC: evaluation of the complementary error function
!
  real a(4)
  real b(4)
  real erfc
  real p(8),q(8),r(5),s(5)
  double precision w
!
  data c/.564189583547756/
!
  data a(1)/-1.65581836870402e-4/, a(2)/3.25324098357738e-2/, &
       a(3)/1.02201136918406e-1/,  a(4)/1.12837916709552e00/
  data b(1)/4.64988945913179e-3/,  b(2)/7.01333417158511e-2/, &
       b(3)/4.23906732683201e-1/,  b(4)/1.00000000000000e00/
  data p(1)/-1.36864857382717e-7/, p(2)/5.64195517478974e-1/, &
       p(3)/7.21175825088309e00/,  p(4)/4.31622272220567e01/, &
       p(5)/1.52989285046940e02/,  p(6)/3.39320816734344e02/, &
       p(7)/4.51918953711873e02/,  p(8)/3.00459261020162e02/
  data q(1)/1.00000000000000e00/,  q(2)/1.27827273196294e01/, &
       q(3)/7.70001529352295e01/,  q(4)/2.77585444743988e02/, &
       q(5)/6.38980264465631e02/,  q(6)/9.31354094850610e02/, &
       q(7)/7.90950925327898e02/,  q(8)/3.00459260956983e02/
  data r(1)/2.10144126479064e00/,  r(2)/2.62370141675169e01/, &
       r(3)/2.13688200555087e01/,  r(4)/4.65807828718470e00/, &
       r(5)/2.82094791773523e-1/
  data s(1)/9.41537750555460e01/,  s(2)/1.87114811799590e02/, &
       s(3)/9.90191814623914e01/,  s(4)/1.80124575948747e01/, &
       s(5)/1.00000000000000e00/
!
!
!                     abs(x) < 0.47
!
  ax = abs(x)
  if (ax >= 0.47) go to 10
  t = x*x
  top = ((a(1)*t + a(2))*t + a(3))*t + a(4)
  bot = ((b(1)*t + b(2))*t + b(3))*t + b(4)
  erfc = 0.5 + (0.5 - x*top/bot)
  return
!
!                  0.47 <= abs(x) <= 4
!
   10 if (ax > 4.0) go to 20
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax &
                      + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax &
                      + q(6))*ax + q(7))*ax + q(8)
  erfc = top/bot
   11 w = dble(x)*dble(x)
  t = w
  e = w - dble(t)
  erfc = ((0.5 + (0.5 - e)) * exp(-t)) * erfc
  if (x < 0.0) erfc = 2.0 - erfc
  return
!
!                       abs(x) > 4
!
   20 if (x <= -5.5) go to 30
  if (x > 50.0) go to 40
  t = (1.0/x)**2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + s(5)
  erfc = (c - t*top/bot) / ax
  go to 11
!
!             limit value for large negative x
!
   30 erfc = 2.0
  return
!
!             limit value for large positive x
!
   40 erfc = 0.0
  return
end
function erfc0(a,t,e)
!
!*******************************************************************************
!
!! ERFC0: evaluation of erfc(a) for 0 <= a <= 4.
!  it is assumed that t = a*a and e = exp(-t).
!
  data p0/2.13853322378e+01/, p1/1.72227577039e+00/, &
       p2/3.16652890658e-01/
  data q0/1.89522572415e+01/, q1/7.84374570830e+00/
!
  data r0/7.3738883116e+00/, r1/6.8650184849e+00/, &
       r2/3.0317993362e+00/, r3/5.6316961891e-01/, &
       r4/4.3187787405e-05/
  data s0/7.3739608908e+00/, s1/1.5184908190e+01/, &
       s2/1.2795529509e+01/, s3/5.3542167949e+00/
!
  if (a > 0.5) go to 10
      erfc0 = 1.0 - a*((p2*t + p1)*t + p0)/((t + q1)*t + q0)
      return
   10 w = ((((r4*a + r3)*a + r2)*a + r1)*a + r0)/ &
         ((((a + s3)*a + s2)*a + s1)*a + s0)
  erfc0 = e*w
  return
end
function erfc1 (ind, x)
!
!*******************************************************************************
!
!! ERFC1: evaluation of the complementary error function
!
!          erfc1(ind,x) = erfc(x)            if ind = 0
!          erfc1(ind,x) = exp(x*x)*erfc(x)   otherwise
!
  real a(4),b(4)
  real erfc1
  real p(8),q(8),r(5),s(5)
  double precision w
!
  data c/.564189583547756/
!
  data a(1)/-1.65581836870402e-4/, a(2)/3.25324098357738e-2/, &
       a(3)/1.02201136918406e-1/,  a(4)/1.12837916709552e00/
  data b(1)/4.64988945913179e-3/,  b(2)/7.01333417158511e-2/, &
       b(3)/4.23906732683201e-1/,  b(4)/1.00000000000000e00/
  data p(1)/-1.36864857382717e-7/, p(2)/5.64195517478974e-1/, &
       p(3)/7.21175825088309e00/,  p(4)/4.31622272220567e01/, &
       p(5)/1.52989285046940e02/,  p(6)/3.39320816734344e02/, &
       p(7)/4.51918953711873e02/,  p(8)/3.00459261020162e02/
  data q(1)/1.00000000000000e00/,  q(2)/1.27827273196294e01/, &
       q(3)/7.70001529352295e01/,  q(4)/2.77585444743988e02/, &
       q(5)/6.38980264465631e02/,  q(6)/9.31354094850610e02/, &
       q(7)/7.90950925327898e02/,  q(8)/3.00459260956983e02/
  data r(1)/2.10144126479064e00/,  r(2)/2.62370141675169e01/, &
       r(3)/2.13688200555087e01/,  r(4)/4.65807828718470e00/, &
       r(5)/2.82094791773523e-1/
  data s(1)/9.41537750555460e01/,  s(2)/1.87114811799590e02/, &
       s(3)/9.90191814623914e01/,  s(4)/1.80124575948747e01/, &
       s(5)/1.00000000000000e00/
!
!
!                     abs(x) < 0.47
!
  ax = abs(x)
  if (ax >= 0.47) go to 10
  t = x*x
  top = ((a(1)*t + a(2))*t + a(3))*t + a(4)
  bot = ((b(1)*t + b(2))*t + b(3))*t + b(4)
  erfc1 = 0.5 + (0.5 - x*top/bot)
  if (ind /= 0) erfc1 = exp(t) * erfc1
  return
!
!                  0.47 <= abs(x) <= 4
!
   10 if (ax > 4.0) go to 30
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax &
                      + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax &
                      + q(6))*ax + q(7))*ax + q(8)
  erfc1 = top/bot
!
   20 if (ind == 0) go to 21
     if (x < 0.0) erfc1 = 2.0*exp(x*x) - erfc1
     return
   21 w = dble(x)*dble(x)
  t = w
  e = w - dble(t)
  erfc1 = ((0.5 + (0.5 - e)) * exp(-t)) * erfc1
  if (x < 0.0) erfc1 = 2.0 - erfc1
  return
!
!                      abs(x) > 4
!
   30 if (x <= -5.5) go to 40
  if (ind == 0 .and. x > 50.0) go to 50
  t = (1.0/x)**2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + s(5)
  erfc1 = (c - t*top/bot) / ax
  go to 20
!
!             limit value for large negative x
!
   40 erfc1 = 2.0
  if (ind /= 0) erfc1 = 2.0*exp(x*x)
  return
!
!             limit value for large positive x
!                       when ind = 0
!
   50 erfc1 = 0.0
  return
end
function erfc2(x)
!
!*******************************************************************************
!
!! ERFC2: evaluation of erfc(x) for abs(x) <= 4.0
!
  data p0/2.13853322378e+01/, p1/1.72227577039e+00/, &
       p2/3.16652890658e-01/
  data q0/1.89522572415e+01/, q1/7.84374570830e+00/
!
  data r0/7.3738883116e+00/, r1/6.8650184849e+00/, &
       r2/3.0317993362e+00/, r3/5.6316961891e-01/, &
       r4/4.3187787405e-05/
  data s0/7.3739608908e+00/, s1/1.5184908190e+01/, &
       s2/1.2795529509e+01/, s3/5.3542167949e+00/
!
  a = abs(x)
  t = a*a
  if (a >= 0.5) go to 10
      erfc2 = 1.0 - x*((p2*t + p1)*t + p0)/((t + q1)*t + q0)
      return
   10 w = ((((r4*a + r3)*a + r2)*a + r1)*a + r0)/ &
         ((((a + s3)*a + s2)*a + s1)*a + s0)
  erfc2 = exp(-t)*w
  if (x < 0.0) erfc2 = 2.0 - erfc2
  return
end
subroutine erfcm2 (mo, z, w)
!
!*******************************************************************************
!
!! ERFCM2: calculation of erfc(z) using the taylor series
!                          around z0 = 2
!
  double precision z(2), w(2)
  double precision a(63), c, e, eps, h(2), t(2), tol, x, y
  double precision anorm, dpmpar
!
  anorm(x,y) = dmax1(dabs(x),dabs(y))
!
!     c = (2/sqrt(pi))*exp(-4)
!     e = erfc(2)
!
  data c /.20666985354092053857068941306585476d-01/
  data e /.46777349810472658379307436327470714d-02/
!
  data a(1)  / .20000000000000000000000000000000000d+01/, &
       a(2)  / .23333333333333333333333333333333333d+01/, &
       a(3)  / .16666666666666666666666666666666667d+01/, &
       a(4)  / .63333333333333333333333333333333333d+00/, &
       a(5)  /-.22222222222222222222222222222222222d-01/, &
       a(6)  /-.16349206349206349206349206349206349d+00/, &
       a(7)  /-.76984126984126984126984126984126984d-01/, &
       a(8)  /-.24250440917107583774250440917107584d-02/, &
       a(9)  / .12716049382716049382716049382716049d-01/, &
       a(10) / .50208433541766875100208433541766875d-02/
  data a(11) /-.25305969750414194858639303083747528d-03/, &
       a(12) /-.78593217482106370995259884148773038d-03/, &
       a(13) /-.19118154038788959423880058800693721d-03/, &
       a(14) / .46324144207742091339974937858535742d-04/, &
       a(15) / .33885549097189308829520469732109944d-04/, &
       a(16) / .28637897646612243562134629672756034d-05/, &
       a(17) /-.29071891082127275370004560446169188d-05/, &
       a(18) /-.89674405786490646425523560263096103d-06/, &
       a(19) / .96069103941908684338469767911200105d-07/, &
       a(20) / .99432863129093191401848891268744113d-07/
  data a(21) / .97610310501460621303387795457283579d-08/, &
       a(22) /-.65557500375673133822289344530892436d-08/, &
       a(23) /-.18706782059105426900361744016236561d-08/, &
       a(24) / .20329898993447386223176373714372370d-09/, &
       a(25) / .16941915827254374668448114614201210d-09/, &
       a(26) / .10619149520827430973786114446699534d-10/, &
       a(27) /-.10136148256511788733365237088810952d-10/, &
       a(28) /-.21042890133669970575386166675721692d-11/, &
       a(29) / .37186985840699828780916522245407087d-12/, &
       a(30) / .17921843632701679986488128324051002d-12/
  data a(31) /-.89823991804248069863542565948598397d-16/, &
       a(32) /-.10533182313660970970232171410372199d-13/, &
       a(33) /-.12340742690978398320850088252659714d-14/, &
       a(34) / .44315624546581333350568244777175883d-15/, &
       a(35) / .11584041639989442481950487524296214d-15/, &
       a(36) /-.10765703619385988116658460442219647d-16/, &
       a(37) /-.70653158723054941879586082239984222d-17/, &
       a(38) /-.18708903154917138727191793341667090d-18/, &
       a(39) / .32549879318817103966053527398133297d-18/, &
       a(40) / .40654116689599228385911733319215613d-19/
  data a(41) /-.11250074516817311101947327325293424d-19/, &
       a(42) /-.28923865378584966737386008432031980d-20/, &
       a(43) / .23653053641701517160704870522922706d-21/, &
       a(44) / .14665384680061888088099002254334292d-21/, &
       a(45) / .26971039707314316218154193225264469d-23/, &
       a(46) /-.58753834789274356433279671015522650d-23/, &
       a(47) /-.59960357240498652932299485494869633d-24/, &
       a(48) / .18586826578121663981412155416486531d-24/, &
       a(49) / .38364131854692721721867481914852428d-25/, &
       a(50) /-.41342210492630142578080062451711039d-26/
  data a(51) /-.17646283105274988992381528904600860d-26/, &
       a(52) / .19828685934364181151988692232131608d-28/, &
       a(53) / .65592252170840353572672782446212733d-28/, &
       a(54) / .40626551379996340638338449938639730d-29/, &
       a(55) /-.20097984104191034713653294173834095d-29/, &
       a(56) /-.28104226475997460044096389060743131d-30/, &
       a(57) / .48705319298749358709127987806547949d-31/, &
       a(58) / .12664655832830787747161769929972617d-31/, &
       a(59) /-.75168312488894341862391776330113688d-33/, &
       a(60) /-.45760473722605993842481669806804415d-33/
  data a(61) /-.56725491529575395930156379514718000d-35/, &
       a(62) / .13932664042920082608489441616061541d-34/, &
       a(63) / .10452448992516358449586503951463322d-35/
!
  eps = epsilon ( eps )
  tol = eps*1.d+12
  h(1) = 1.d0 + (1.d0 - z(1))
  h(2) = - z(2)
!
  x = 1.d0
  y = 0.d0
  w(1) = a(30)
  w(2) = 0.d0
  do 10 n = 31,63
     t(1) = x*h(1) - y*h(2)
     t(2) = x*h(2) + y*h(1)
     x = t(1)
     y = t(2)
     t(1) = a(n)*x
     t(2) = a(n)*y
     w(1) = w(1) + t(1)
     w(2) = w(2) + t(2)
     if (anorm(t(1),t(2)) <= tol*anorm(w(1),w(2))) go to 20
   10 continue
!
   20 do 21 j = 1,29
     n = 30 - j
     x = h(1)*w(1) - h(2)*w(2)
     w(2) = h(1)*w(2) + h(2)*w(1)
     w(1) = a(n) + x
   21 continue
  x = h(1)*w(1) - h(2)*w(2)
  w(2) = h(1)*w(2) + h(2)*w(1)
  w(1) = 1.d0 + x
!
  x = c*(h(1)*w(1) - h(2)*w(2))
  w(2) = c*(h(1)*w(2) + h(2)*w(1))
  w(1) = e + x
  if (mo == 0) return
!
!                     compute exp(z*z)*erfc(z)
!
  x = z(1)*z(1) - z(2)*z(2)
  y = 2.d0*z(1)*z(2)
  x = dexp(x)
  t(1) = x*dcos(y)
  t(2) = x*dsin(y)
  x = t(1)*w(1) - t(2)*w(2)
  y = t(1)*w(2) + t(2)*w(1)
  w(1) = x
  w(2) = y
  return
end
function erfinv (p, q)
!
!*******************************************************************************
!
!! ERFINV: evaluation of the inverse error function
!
!     for 0 <= p <= 1,  w = erfinv(p,q) where erf(w) = p. it is
!     assumed that q = 1 - p. if either inequality on p is violated
!     or p + q /= 1, then erfinv(p,q) is set to a negative value.
!
!
!     reference. mathematics of computation,oct.1976,pp.827-830.
!                  j.m.blair,c.a.edwards,j.h.johnson
!
  real a(6),b(6),a1(7),b1(7),a2(9),b2(8),a3(9),b3(6)
  real erfinv
!
!     c2 = ln(1.e-100)
!
  data c /.5625/, c1 /.87890625/
  data c2 /-.2302585092994046e+03/
!
!                            table no.16
!
  data a(1)/.1400216916161353e+03/,  a(2)/-.7204275515686407e+03/, &
       a(3)/.1296708621660511e+04/,  a(4)/-.9697932901514031e+03/, &
       a(5)/.2762427049269425e+03/,  a(6)/-.2012940180552054e+02/
  data b(1)/.1291046303114685e+03/,  b(2)/-.7312308064260973e+03/, &
       b(3)/.1494970492915789e+04/,  b(4)/-.1337793793683419e+04/, &
       b(5)/.5033747142783567e+03/,  b(6)/-.6220205554529216e+02/
!
!                            table no.36
!
  data a1(1)/-.1690478046781745e+00/, a1(2)/.3524374318100228e+01/, &
       a1(3)/-.2698143370550352e+02/, a1(4)/.9340783041018743e+02/, &
       a1(5)/-.1455364428646732e+03/, a1(6)/.8805852004723659e+02/, &
       a1(7)/-.1349018591231947e+02/
  data b1(1)/-.1203221171313429e+00/, b1(2)/.2684812231556632e+01/, &
       b1(3)/-.2242485268704865e+02/, b1(4)/.8723495028643494e+02/, &
       b1(5)/-.1604352408444319e+03/, b1(6)/.1259117982101525e+03/, &
       b1(7)/-.3184861786248824e+02/
!
!                            table no.56
!
  data a2(1)/.3100808562552958e-04/, a2(2)/.4097487603011940e-02/, &
       a2(3)/.1214902662897276e+00/, a2(4)/.1109167694639028e+01/, &
       a2(5)/.3228379855663924e+01/, a2(6)/.2881691815651599e+01/, &
       a2(7)/.2047972087262996e+01/, a2(8)/.8545922081972148e+00/, &
       a2(9)/.3551095884622383e-02/
  data b2(1)/.3100809298564522e-04/, b2(2)/.4097528678663915e-02/, &
       b2(3)/.1215907800748757e+00/, b2(4)/.1118627167631696e+01/, &
       b2(5)/.3432363984305290e+01/, b2(6)/.4140284677116202e+01/, &
       b2(7)/.4119797271272204e+01/, b2(8)/.2162961962641435e+01/
!
!                            table no.79
!
  data a3(1)/.3205405422062050e-08/, a3(2)/.1899479322632128e-05/, &
       a3(3)/.2814223189858532e-03/, a3(4)/.1370504879067817e-01/, &
       a3(5)/.2268143542005976e+00/, a3(6)/.1098421959892340e+01/, &
       a3(7)/.6791143397056208e+00/, a3(8)/-.834334189167721e+00/, &
       a3(9)/.3421951267240343e+00/
  data b3(1)/.3205405053282398e-08/, b3(2)/.1899480592260143e-05/, &
       b3(3)/.2814349691098940e-03/, b3(4)/.1371092249602266e-01/, &
       b3(5)/.2275172815174473e+00/, b3(6)/.1125348514036959e+01/
!
  if (p < 0.0 .or. q  <  0.0) go to 100
  eps = max ( epsilon ( eps ),1.0e-15)
  t = 0.5 + (0.5 - (p + q))
  if (abs(t) > 2.0*eps) go to 100
  if (q == 0.0) go to 50
!
!                      0 <= p <= 0.75
!
  if (p > 0.75) go to 10
  v = p*p - c
  t = p *  (((((a(6)*v + a(5))*v + a(4))*v + a(3))*v &
                       + a(2))*v + a(1))
  s = (((((v + b(6))*v + b(5))*v + b(4))*v + b(3))*v &
                       + b(2))*v + b(1)
  go to 40
!
!                    0.75 < p <= 0.9375
!
   10 if (p > 0.9375) go to 20
  v = p*p - c1
  t = p *  ((((((a1(7)*v + a1(6))*v + a1(5))*v + a1(4))*v &
                         + a1(3))*v + a1(2))*v + a1(1))
  s = ((((((v + b1(7))*v + b1(6))*v + b1(5))*v + b1(4))*v &
              + b1(3))*v + b1(2))*v + b1(1)
  go to 40
!
!                  1.e-100 <= q < 0.0625
!
   20 v1 = alog(q)
  v = 1.0/sqrt(-v1)
  if (v1 < c2) go to 30
  t = (((((((a2(9)*v + a2(8))*v + a2(7))*v + a2(6))*v + a2(5))*v &
                     + a2(4))*v + a2(3))*v + a2(2))*v + a2(1)
  s = v *  ((((((((v + b2(8))*v + b2(7))*v + b2(6))*v + b2(5))*v &
                     + b2(4))*v + b2(3))*v + b2(2))*v + b2(1))
  go to 40
!
!                 1.e-10000 <= q < 1.e-100
!
   30 t = (((((((a3(9)*v + a3(8))*v + a3(7))*v + a3(6))*v + a3(5))*v &
                     + a3(4))*v + a3(3))*v + a3(2))*v + a3(1)
  s = v * ((((((v + b3(6))*v + b3(5))*v + b3(4))*v + b3(3))*v &
                  + b3(2))*v + b3(1))
   40 erfinv = t/s
  return
!
!                    0 <= q < 1.e-10000
!
   50 erfinv = huge ( erfinv )
  return
!
!                         error return
!
  100 erfinv = - huge ( erfinv )
  return
end
function errev ( nn,qr,qi,ms,mp,are,mre)
!
!*******************************************************************************
!
!! ERREV: bounds the error in evaluating the polynomial by the horner
!     recurrence algorithm.
!
!     qr,qi   - the partial sums
!     ms      - modulus of the point
!     mp      - modulus of the polynomial value
!     are,mre - error bounds on complex addition and multiplication
!
  double precision errev
  double precision qr(nn),qi(nn),ms,mp,are,mre,e,dcpabs
!
  e = dcpabs(qr(1),qi(1))*mre/(are + mre)
  do i = 1,nn
     e = e*ms + dcpabs(qr(i),qi(i))
  end do
  errev = e*(are + mre) - mp*mre

  return
end
function errint(f, fit, aaa, bbb, points, weight)
!
!*******************************************************************************
!
!! ERRINT does a four point integration rule for the
!     absolute value of the difference of two functions( f and fit )
!                   abs( f(x) - fit(x) )**norm
!     the integration uses the points and weights given and scaled
!     from (-1,1) to (aaa,bbb)
!
  double precision errint
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision aaa, abmid, ba, bbb, fdumb, fit, p, pj, points, &
   weight, er, f1, f2, two, three
  dimension fdumb(9), points(*), weight(*)
  double precision f
  external f, fit
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  data two,three/2.0d0,3.0d0/
!
!         compute midpoint = abmid and half length = ba of interval
  abmid = (aaa+bbb)/two
  ba = (bbb-aaa)/two
  pj = abmid + ba*points(1)
!
!         test for tchebycheff (minimax) norm which uses special code
  if (norm==three) go to 20
!
!         have general lp norm or least squares or least deviations
  p = dabs(norm)
!              initialize the quadrature rule
  errint = dabs(f(pj,fdumb)-fit(pj))**p*weight(1)
!
!              loop through remaining points
!
  do j=2,4
    pj = abmid + ba*points(j)
    f1 = f(pj,fdumb)
    f2 = fit(pj)
    er = dabs(f1-f2)**p
    errint = errint + dabs(f(pj,fdumb)-fit(pj))**p*weight(j)
  end do

  errint = errint*ba
  go to 40
!
!         tchebycheff norm
   20 continue
!             find max error on points
!               initialize
  errint = dabs(f(pj,fdumb)-fit(pj))
!              loop through the remaining points
  do 30 j=2,4
    pj = abmid + ba*points(j)
    errint = dmax1(errint,dabs(f(pj,fdumb)-fit(pj)))
   30 continue
   40 continue
  return
end
function esum (mu, x)
!
!*******************************************************************************
!
!! ESUM: evaluation of exp(mu + x)
!
  real esum
!
  if (x > 0.0) go to 10
!
  if (mu < 0) go to 20
     w = mu + x
     if (w > 0.0) go to 20
     esum = exp(w)
     return
!
   10 if (mu > 0) go to 20
     w = mu + x
     if (w < 0.0) go to 20
     esum = exp(w)
     return
!
   20 w = mu
  esum = exp(w)*exp(x)
  return
end
function euler_constant ( )
!
!*******************************************************************************
!
!! EULER_CONSTANT returns the value of the Euler-Mascheroni constant.
!
!
!  Discussion:
!
!    The Euler-Mascheroni constant is often denoted by a lower-case
!    Gamma.  Gamma is defined as
!
!      Gamma = limit ( M -> Infinity ) ( Sum ( 1 <= N <= M ) 1 / N ) - Log ( M )
!
!  Modified:
!
!    27 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real EULER_CONSTANT, the value of the Euler-Mascheroni constant.
!
  real euler_constant
!
  euler_constant = 0.577215664901532860606512090082402431042E+00

  return
end
function exparg ( l )
!
!*******************************************************************************
!
!! EXPARG returns the largest "safe" argument of the exponential function.
!
!
!     if l = 0 then  exparg(l) = the largest positive w for which
!     exp(w) can be computed.
!
!     if l is nonzero then  exparg(l) = the largest negative w for
!     which the computed value of exp(w) is nonzero.
!
!     note... only an approximate value for exparg(l) is needed.
!
  integer b
  real exparg
  real lnb
!
  b = ipmpar(4)
  if (b /= 2) go to 10
     lnb = .69314718055995
     go to 50
   10 if (b /= 8) go to 20
     lnb = 2.0794415416798
     go to 50
   20 if (b /= 16) go to 30
     lnb = 2.7725887222398
     go to 50
   30 lnb = alog(real(b))
!
   50 if (l == 0) go to 60
     m = ipmpar(6) - 1
     exparg = 0.99999 * (m * lnb)
     return
   60 m = ipmpar(7)
  exparg = 0.99999 * (m * lnb)
  return
end
subroutine expli ( int, arg, result, ierr )
!
!*******************************************************************************
!
!! EXPLI computes the exponential integrals
!
!            ei(x),  e-sub-1(x) = -ei(-x),  and  exp(-x)*ei(x)
!
!     where
!
!             integral (from t=-infinity to t=x) (exp(t)/t),  x > 0,
!     ei(x) =
!             -integral (from t=-x to t=infinity) (exp(-t)/t),
!                                                         x < 0,
!
!     and where the first integral is a principal value integral. the
!     arguments int, arg, and result have the following usage ...
!
!            int              arg             result
!             1            x /= 0          ei(x)
!             2            x > 0          e-sub-1(x)
!             3            x /= 0          exp(-x)*ei(x)
!
!     the expansion for 4 <= x <= 8 is due to wayne fullerton (los
!     alamos). the remaining expansions are from math. comp. 22, 641-649
!     (1968), and math. comp. 23, 289-303(1969) by cody and thacher.
!
!
!
!     error monitoring
!
!        the parameter ierr is a variable that is set by the routine.
!     if no errors are detected then ierr is set to 0. the following
!     table indicates the types of errors that may be encountered in
!     the routine and the function values supplied in each case.
!
!     ierr    error     argument          function values for
!                        range        ei(x)  exp(-x)*ei(x)  e-sub-1(x)
!      1    underflow   x < xmin     0          -          0
!      2    overflow    x > xmax     t          -          -
!      3    illegal x     x = 0         t          t          t
!      4    illegal x    x < 0       -          -          t
!
!     t indicates that the routine terminates without assigning a value
!     to the function.
!
!
!
!     this subroutine was written at argonne national laboratory for
!     the funpack package of special function subroutines. the routine
!     was modified by by a.h. morris (nswc).
!
!
!
!     xmax and xmin are machine dependent constants for detecting
!     underflow and overflow. xmax and xmin are given approximate
!     values in statements 240 and 340.
!
!
  real a(6),b(5),c(7),d(7),e(7),f(7),p1(8),q1(8),p2(8),q2(7), &
          p3(8),q3(7),p4(8),q4(7),r(20),px(9),qx(9), &
          frac,sump,sumq,t,w,x,x0,xx0,xmx0,y,dexp40,xmax, &
          xmin,ei,arg,result,exparg
  integer i,int,ierr
  double precision dx0
!
!     value of exp(40.0)
!
!
  data dexp40/.235385266837020e+18/
!
!
!     zero of ei(x)
!
!
  data x0/.372507410781366/,dx0/.37250741078136663446199186658d0/
!
!
!     coefficients for r(5,4) approximation,
!     used for -1.0 <= x < 0.0
!
!
  data a(1)/-.577215664901531e+00/, a(2) /.758833087029943e+00/, &
       a(3) /.125660818982053e+00/, a(4) /.204158408934305e-01/, &
       a(5) /.825035122466538e-03/, a(6) /.962949813453924e-05/
  data b(1) /.100000000000000e+01/, b(2) /.417810755380398e+00/, &
       b(3) /.730228560396799e-01/, b(4) /.642720224671078e-02/, &
       b(5) /.245134203588369e-03/
!
!
!     coefficients for r(6,6) approximation,
!     used for -4.0 <= x < -1.0
!
!
  data c(1) /.465627107975096e-06/, c(2) /.999979577051595e+00/, &
       c(3) /.904161556946328e+01/, c(4) /.243784088791317e+02/, &
       c(5) /.230192559391334e+02/, c(6) /.690522522784443e+01/, &
       c(7) /.430967839469389e+00/
  data d(1) /.100000000000000e+01/, d(2) /.100411643829054e+02/, &
       d(3) /.324264210695138e+02/, d(4) /.412807841891424e+02/, &
       d(5) /.204494785013794e+02/, d(6) /.331909213593302e+01/, &
       d(7) /.103400130404874e+00/
!
!
!     coefficients for r(6,6) approximation,
!     used for x < -4.0
!
!
  data e(1)/-.999999999998447e+00/, e(2)/-.266271060431811e+02/, &
       e(3)/-.241055827097015e+03/, e(4)/-.895927957772937e+03/, &
       e(5)/-.129885688746484e+04/, e(6)/-.545374158883133e+03/, &
       e(7)/-.566575206533869e+01/
  data f(1) /.100000000000000e+01/, f(2) /.286271060422192e+02/, &
       f(3) /.292310039388533e+03/, f(4) /.133278537748257e+04/, &
       f(5) /.277761949509163e+04/, f(6) /.240401713225909e+04/, &
       f(7) /.631657483280800e+03/
!
!
!     coefficients for r(7,7) approximation,
!     in chebyshev polynomial form, used for
!     0.0 < x  <  4.0
!
!
  data p1(1)/-.866937339951070e+01/, p1(2)/-.549142265521085e+03/, &
       p1(3)/-.421001615357070e+04/, p1(4)/-.249301393458648e+06/, &
       p1(5)/-.119623669349247e+06/, p1(6)/-.221744627758845e+08/, &
       p1(7) /.389280421311201e+07/, p1(8)/-.195773036904548e+09/
  data q1(1) /.341718750000000e+02/, q1(2)/-.160708926587221e+04/, &
       q1(3) /.357300298058508e+05/, q1(4)/-.483547436162164e+06/, &
       q1(5) /.428559624611749e+07/, q1(6)/-.249033375740540e+08/, &
       q1(7) /.891925767575612e+08/, q1(8)/-.826271498626055e+08/
!
!
!     coefficients for chebyshev expansion for
!     4.0 <= x <= 8.0
!
!
  data r(1) / .636295897967470e+00/, r(2) /-.130811686750676e+00/, &
       r(3) /-.843674102130539e-02/, r(4) / .265684915310067e-02/, &
       r(5) / .328227217816581e-03/, r(6) /-.237834477714302e-04/, &
       r(7) /-.114398043081001e-04/, r(8) /-.144059434332383e-05/, &
       r(9) / .524159566511488e-08/, r(10)/ .384073064078443e-07/, &
       r(11)/ .858802448602672e-08/, r(12)/ .102192266258550e-08/, &
       r(13)/ .217491323232897e-10/, r(14)/-.220902381426231e-10/, &
       r(15)/-.634575335449288e-11/, r(16)/-.108377465668577e-11/, &
       r(17)/-.119098228722226e-12/, r(18)/-.284386823892656e-14/, &
       r(19)/ .250803270266868e-14/, r(20)/ .787296415285598e-15/
!
!     coefficients for r(7,7) approximation,
!     in j-fraction form, used for
!     8.0 < x  <  12.0
!
!
  data p2(1)/-.218086381520723e+01/, p2(2)/-.219010233854881e+02/, &
       p2(3)/ .930816385662165e+01/, p2(4) /.250762811293560e+02/, &
       p2(5)/-.331842531997221e+02/, p2(6) /.601217990830080e+02/, &
       p2(7)/-.432531132878135e+02/, p2(8) /.100443109228078e+01/
  data q2(1)/ .393707701852715e+01/, q2(2) /.300892648372915e+03/, &
       q2(3)/-.625041161671876e+01/, q2(4) /.100367439516726e+04/, &
       q2(5)/ .143256738121938e+02/, q2(6) /.273624119889328e+04/, &
       q2(7)/ .527468851962908e+00/
!
!
!     coefficients for r(7,7) approximation,
!     in j-fraction form, used for
!     12.0 <= x < 24.0
!
!
  data p3(1)/-.348334653602852e+01/, p3(2)/-.186545454883399e+02/, &
       p3(3)/-.828561994140641e+01/, p3(4)/-.323467330305403e+02/, &
       p3(5)/ .179601688769252e+02/, p3(6) /.175656315469614e+01/, &
       p3(7)/-.195022321289660e+01/, p3(8) /.999994296074708e+00/
  data q3(1) /.695000655887434e+02/, q3(2) /.572837193837324e+02/, &
       q3(3) /.257776384238440e+02/, q3(4) /.760761148007735e+03/, &
       q3(5) /.289516727925135e+02/, q3(6)/-.343942266899870e+01/, &
       q3(7) /.100083867402639e+01/
!
!
!     coefficients for r(7.7) approximation,
!     in j-fraction form, used for x >= 24.0
!
!
  data p4(1)/-.531686623494482e+02/, p4(2)/ .891263822573708e+01/, &
       p4(3)/-.139381360364405e+01/, p4(4)/-.308336269051763e+02/, &
       p4(5)/-.749289167792884e+01/, p4(6)/-.500140345515924e+01/, &
       p4(7)/-.300000016782086e+01/, p4(8)/ .100000000000058e+01/
  data q4(1)/ .104745362652468e+04/, q4(2)/-.674704580465832e+01/, &
       q4(3)/ .295999399486831e+03/, q4(4)/-.431325836146628e+01/, &
       q4(5)/-.790404992298926e+01/, q4(6)/-.299996432944446e+01/, &
       q4(7)/ .199999999924131e+01/
!
!
  x = arg
  ierr = 0
  if (int == 2) go to 450
  if (x) 280, 640, 110
  110 if (x >= 12.e0) go to 200
  if (x > 8.e0) go to 160
  if (x >= 4.e0) go to 150
! 0.0 < x  <  4.0.
!                rational approximation used is expressed
!                in terms of chebyshev polynomials to
!                improve conditioning----------
  t = x + x
  t = t / 3.0e0 - 2.0e0
  px(1) = 0.0e0
  qx(1) = 0.0e0
  px(2) = p1(1)
  qx(2) = q1(1)

  do i = 2, 7
     px(i+1) = t * px(i) - px(i-1) + p1(i)
     qx(i+1) = t * qx(i) - qx(i-1) + q1(i)
  end do

  sump = .5e0 * t * px(8) - px(7) + p1(8)
  sumq = .5e0 * t * qx(8) - qx(7) + q1(8)
  frac = sump / sumq
  xmx0 = dble(x) - dx0
  if (abs(xmx0) < 0.07e0) go to 140
  xx0 = x / x0
  ei = alog(xx0) + xmx0 * frac
  if (int == 3) ei = exp(-x) * ei
  go to 410
! evaluate approximation for ln(x/x0)
!                for x close to x0----------
  140 y = xmx0 / x0
  ei = alnrel(y) + xmx0 * frac
  if (int == 3) ei = exp(-x) * ei
  go to 410
! 4.0 <= x <= 8.0
  150 m = 20
  ei = (1.0 + csevl (3.0 - 16.0/x, r, m)) / x
  if (int == 3) go to 410
  ei = ei * exp(x)
  go to 410
! 8.0 < x  <  12.0----------
  160 frac = 0.0e0
!
  do 180 i = 1, 7
  180 frac = q2(i) / (p2(i) + x + frac)
!
  ei = (p2(8) + frac) / x
  if (int == 3) go to 410
  ei = ei * exp(x)
  go to 410
! 12.0 <= x < 24.0----------
  200 if (x >= 24.e0) go to 240
  frac = 0.0e0
!
  do 220 i = 1, 7
  220 frac = q3(i) / (p3(i) + x + frac)
!
  ei = (p3(8) + frac) / x
  if (int == 3) go to 410
  ei = ei * exp(x)
  go to 410
! 24.0 <= x----------
  240 xmax = exparg(0)
  if ((x > xmax) .and. (int < 3)) go to 620
  y = 1.0e0 / x
  frac = 0.0e0
!
  do 260 i = 1, 7
  260 frac = q4(i) / (p4(i) + x + frac)
!
  frac = p4(8) + frac
  ei = y + y * y * frac
  if (int == 3) go to 410
  if (x > 150.0e0) go to 270
  ei = ei * exp(x)
  go to 410
! calculation reformulated to avoid
!                premature overflow----------
  270 ei = (ei * exp(x-40.0e0)) * dexp40
  go to 410
! original x was negative.  calculation of
!                e-sub-1 joins at label 300----------
  280 y = -x
  300 w = 1.0e0 / y
  if (y > 4.0e0) go to 340
  if (y > 1.0e0) go to 320
! 0.0 < -x <= 1.0----------
  ei = alog(y) - (((((a(6) * y + a(5)) * y + a(4)) &
              * y + a(3)) * y + a(2)) * y + a(1)) / &
         ((((b(5) * y + b(4)) * y + b(3)) &
              * y + b(2)) * y + b(1))
  if (int == 3) ei = ei * exp(y)
  go to 400
! 1.0 < -x <= 4.0----------
  320 ei = -((((((c(7) * w + c(6)) * w + c(5)) * w + c(4)) &
            * w + c(3)) * w + c(2)) * w + c(1))  / &
         ((((((d(7) * w + d(6)) * w + d(5)) * w + d(4)) &
            * w + d(3)) * w + d(2)) * w + d(1))
  if  (int == 3) go to 410
  ei = ei * exp(-y)
  go to 400
! 4.0 < -x----------
  340 xmin = exparg(1)
  if ((-abs(x) < xmin) .and. (int  <  3)) go to 600
  ei = -w * (1.0e0 + w * ((((((e(7) &
          * w + e(6)) * w + e(5)) * w + e(4)) &
            * w + e(3)) * w + e(2)) * w + e(1)) / &
         ((((((f(7) * w + f(6)) * w + f(5)) &
            * w + f(4)) * w + f(3)) * w + f(2)) * w + f(1)))
  if (int == 3) go to 410
  ei = ei * exp(-y)
  t = 0.5e0 * ei
  if (t == 0.0e0) go to 600
  400 if (int == 2) ei = -ei
  410 result = ei
  return
  450 y = x
  if (y) 660, 640, 300
! error return for x < xmin,
!                causing underflow----------
  600 ei = 0.0e0
  ierr = 1
  go to 410
! error return for x > xmax,
!                causing overflow----------
  620 ierr = 2
  return
! error return for illegal
!                argument, x = 0----------
  640 ierr = 3
  return
! error return for negative
!                argument in e-sub-1----------
  660 ierr = 4
  return
end
subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1,wa2)
!
!*******************************************************************************
!
!! FDJAC1 computes a forward-difference approximation
!     to the n by n jacobian matrix associated with a specified
!     problem of n functions in n variables. if the jacobian has
!     a banded form, then function evaluations are saved by only
!     approximating the nonzero terms.
!
!     the subroutine statement is
!
!       subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,
!                         wa1,wa2)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(n,x,fvec,iflag)
!         integer n,iflag
!         real x(n),fvec(n)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of fdjac1.
!         in this case set iflag to a negative integer.
!
!       n is a positive integer input variable set to the number
!         of functions and variables.
!
!       x is an input array of length n.
!
!       fvec is an input array of length n which must contain the
!         functions evaluated at x.
!
!       fjac is an output n by n array which contains the
!         approximation to the jacobian matrix evaluated at x.
!
!       ldfjac is a positive integer input variable not less than n
!         which specifies the leading dimension of the array fjac.
!
!       iflag is an integer variable which can be used to terminate
!         the execution of fdjac1. see description of fcn.
!
!       ml is a nonnegative integer input variable which specifies
!         the number of subdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         ml to at least n - 1.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       mu is a nonnegative integer input variable which specifies
!         the number of superdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         mu to at least n - 1.
!
!       wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at
!         least n, then the jacobian is considered dense, and wa2 is
!         not referenced.
!
!     subprograms called
!
!
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer n,ldfjac,iflag,ml,mu
  real epsfcn
  real x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n)
  external fcn
!
  integer i,j,k,msum
  real eps,epsmch,h,temp,zero
  data zero /0.0e0/
!
  epsmch = epsilon ( epsmch )
  eps = sqrt(max ( epsfcn,epsmch))
  msum = ml + mu + 1
  if (msum < n) go to 40
!
!        computation of dense approximate jacobian.
!
     do 20 j = 1, n
        temp = x(j)
        h = eps*abs(temp)
        if (h == zero) h = eps
        x(j) = temp + h
        call fcn(n,x,wa1,iflag)
        if (iflag < 0) go to 30
        x(j) = temp
        do 10 i = 1, n
           fjac(i,j) = (wa1(i) - fvec(i))/h
   10          continue
   20       continue
   30    continue
     go to 110
   40 continue
!
!        computation of banded approximate jacobian.
!
     do 90 k = 1, msum
        do 60 j = k, n, msum
           wa2(j) = x(j)
           h = eps*abs(wa2(j))
           if (h == zero) h = eps
           x(j) = wa2(j) + h
   60          continue
        call fcn(n,x,wa1,iflag)
        if (iflag < 0) go to 100
        do 80 j = k, n, msum
           x(j) = wa2(j)
           h = eps*abs(wa2(j))
           if (h == zero) h = eps
           do 70 i = 1, n
              fjac(i,j) = zero
              if (i >= j - mu .and. i <= j + ml) &
                 fjac(i,j) = (wa1(i) - fvec(i))/h
   70             continue
   80          continue
   90       continue
  100    continue
  110 continue
  return
end
subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
!
!*******************************************************************************
!
!! FDJAC2 computes a forward-difference approximation
!     to the m by n jacobian matrix associated with a specified
!     problem of m functions in n variables.
!
!     the subroutine statement is
!
!       subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(m,n,x,fvec,iflag)
!         integer m,n,iflag
!         real x(n),fvec(m)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of fdjac2.
!         in this case set iflag to a negative integer.
!
!       m is a positive integer input variable set to the number
!         of functions.
!
!       n is a positive integer input variable set to the number
!         of variables. n must not exceed m.
!
!       x is an input array of length n.
!
!       fvec is an input array of length m which must contain the
!         functions evaluated at x.
!
!       fjac is an output m by n array which contains the
!         approximation to the jacobian matrix evaluated at x.
!
!       ldfjac is a positive integer input variable not less than m
!         which specifies the leading dimension of the array fjac.
!
!       iflag is an integer variable which can be used to terminate
!         the execution of fdjac2. see description of fcn.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       wa is a work array of length m.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer m,n,ldfjac,iflag
  real epsfcn
  real x(n),fvec(m),fjac(ldfjac,n),wa(m)
  external fcn
  integer i,j
  real eps,epsmch,h,temp,zero
  data zero /0.0e0/
!
  epsmch = epsilon ( epsmch )

  eps = sqrt(max ( epsfcn,epsmch))
  do 20 j = 1, n
     temp = x(j)
     h = eps*abs(temp)
     if (h == zero) h = eps
     x(j) = temp + h
     call fcn(m,n,x,wa,iflag)
     if (iflag < 0) go to 30
     x(j) = temp
     do 10 i = 1, m
        fjac(i,j) = (wa(i) - fvec(i))/h
   10       continue
   20    continue
   30 continue
  return
end
subroutine fehl(f,neqn,y,t,h,yp,f1,f2,f3,f4,f5,s)
!
!*******************************************************************************
!
!! FEHL: fehlberg fourth-fifth order runge-kutta method
!
!
!    fehl integrates a system of neqn first order
!    ordinary differential equations of the form
!             dy(i)/dt=f(t,y(1),---,y(neqn))
!    where the initial values y(i) and the initial derivatives
!    yp(i) are specified at the starting point t. fehl advances
!    the solution over the fixed step h and returns
!    the fifth order (sixth order accurate locally) solution
!    approximation at t+h in array s(i).
!    f1,---,f5 are arrays of dimension neqn which are needed
!    for internal storage.
!    the formulas have been grouped to control loss of significance.
!    fehl should be called with an h not smaller than 13 units of
!    roundoff in t so that the various independent arguments can be
!    distinguished.
!
!
  integer  neqn
  real  y(neqn),t,h,yp(neqn),f1(neqn),f2(neqn), &
    f3(neqn),f4(neqn),f5(neqn),s(neqn)
!
  real  ch
  integer  k
  external f
!
  ch=h/4.0
  do 221 k=1,neqn
  221   f5(k)=y(k)+ch*yp(k)
  call f(t+ch,f5,f1)
!
  ch=3.0*h/32.0
  do 222 k=1,neqn
  222   f5(k)=y(k)+ch*(yp(k)+3.0*f1(k))
  call f(t+3.0*h/8.0,f5,f2)
!
  ch=h/2197.0
  do 223 k=1,neqn
  223   f5(k)=y(k)+ch*(1932.0*yp(k)+(7296.0*f2(k)-7200.0*f1(k)))
  call f(t+12.0*h/13.0,f5,f3)
!
  ch=h/4104.0
  do 224 k=1,neqn
  224   f5(k)=y(k)+ch*((8341.0*yp(k)-845.0*f3(k))+ &
                              (29440.0*f2(k)-32832.0*f1(k)))
  call f(t+h,f5,f4)
!
  ch=h/20520.0
  do 225 k=1,neqn
  225   f1(k)=y(k)+ch*((-6080.0*yp(k)+(9295.0*f3(k)- &
           5643.0*f4(k)))+(41040.0*f1(k)-28352.0*f2(k)))
  call f(t+h/2.0,f1,f5)
!
!     compute approximate solution at t+h
!
  ch=h/7618050.0
  do 230 k=1,neqn
  230   s(k)=y(k)+ch*((902880.0*yp(k)+(3855735.0*f3(k)- &
          1371249.0*f4(k)))+(3953664.0*f2(k)+ &
          277020.0*f5(k)))
!
  return
end
subroutine fft (c,n,isn,ierr)
!
!*******************************************************************************
!
!! FFT ???
!
!     the complex array c of dimension n is interpreted by the code
!     as a real array of dimension 2*n. if this association is not
!     permitted by the fortran being used, then the user may use the
!     subroutine fft1.
!
  real c(*)
  if (iabs(isn) /= 1) go to 10
  call sfft (c(1),c(2),n,n,n,isn+isn,ierr)
  return
   10 ierr = 4
  return
end
subroutine fft1 (a,b,n,isn,ierr)
!
!*******************************************************************************
!
!! FFT1: ???
!
  real a(n), b(n)
!
  if (iabs(isn) /= 1) go to 10
  call sfft (a,b,n,n,n,isn,ierr)
  return
   10 ierr = 4
  return
end
subroutine fmin(f, a0, b0, x, w, aerr, rerr, error, ind)
!
!*******************************************************************************
!
!! FMIN: golden section minimization of a function f(t)
!
  real f, a0, b0, x, w, aerr, rerr, error
  real eps, eps0, atol, ftol, rtol, tol
  real a, b, c1, c2, e, fu, fv, u, v
  external f
!
!     c1 = 1 - c2
!     c2 = 0.5*(-1 + sqrt(5))
!
  data eps0/5.e-3/
  data c1/.3819660112501052/
  data c2/.6180339887498948/
!
  eps = epsilon ( eps )
  a = a0
  b = b0
  ind = 0
  atol = max ( aerr,1.e-20)
  ftol = max ( 2.0*eps,rerr)
  rtol = max ( 7.0*eps,rerr)
!
  e = b - a
  u = a + c1*e
  v = a + c2*e
  fu = f(u)
  fv = f(v)
!
!        location of the region of a local minimum
!
   10 if (e <= eps0*(1.0 + abs(a))) go to 40
  if (fu - fv) 20,11,30
   11 if (fu > f(b)) go to 30
!
   20 b = v
  e = b - a
  v = u
  u = a + c1*e
  fv = fu
  fu = f(u)
  go to 10
!
   30 a = u
  e = b - a
  u = v
  v = a + c2*e
  fu = fv
  fv = f(v)
  go to 10
!
   40 if (a > 0.0 .or. b < 0.0) go to 41
     w = f(0.0)
     if (w <= amin1(fu,fv)) go to 100
   41 if (a /= a0) go to 42
     if (a == 0.0) go to 201
     w = f(a)
     if (w <= amin1(fu,fv)) go to 130
     go to 201
   42 if (b /= b0) go to 201
     if (b == 0.0) go to 201
     w = f(b)
     if (w <= amin1(fu,fv)) go to 150
     go to 201
!
!              check if 0 is a local minimum
!
  100 if (b <= atol) go to 110
  x = 0.01*b
  if (w > f(x)) go to 180
  b = x
  go to 100
!
  110 if (abs(a) <= atol) go to 120
  x = 0.01*a
  if (w > f(x)) go to 180
  a = x
  go to 110
!
  120 x = 0.0
  error = max ( abs(a),b)
  return
!
!             check if a0 is a local minimum
!
  130 tol = max ( rtol*abs(a),atol)
  131 x = a + 0.01*e
  if (w > f(x)) go to 180
  b = x
  e = b - a
  if (e > tol) go to 131
!
  x = a
  error = e
  return
!
!             check if b0 is a local minimum
!
  150 tol = max ( rtol*abs(b),atol)
  151 x = b - 0.01*e
  if (w > f(x)) go to 180
  a = x
  e = b - a
  if (e > tol) go to 151
!
  x = b
  error = e
  return
!
  180 e = b - a
  u = a + c1*e
  v = a + c2*e
  fu = f(u)
  fv = f(v)
!
!             refinement of the local minimum
!
  200 ind = 0
  201 if (fu > fv) go to 210
!
  b = v
  e = b - a
  v = u
  u = a + c1*e
  fv = fu
  fu = f(u)
  go to 220
!
  210 a = u
  e = b - a
  u = v
  v = a + c2*e
  fu = fv
  fv = f(v)
!
!        checking the accuracy of the local minimum
!
  220 if (e <= max ( rtol*abs(a),atol)) go to 240
  if (abs(fv - fu) > ftol*max ( abs(fu),abs(fv))) go to 200
  if (ind == 1) go to 241
  ind = 1
  go to 201
!
!                    report the results
!
  240 ind = 0
  241 if (fu - fv) 242,243,244
  242 x = u
  w = fu
  error = c1*e
  return
  243 x = v
  w = fv
  error = e
  return
  244 x = v
  w = fv
  error = c1*e
  return
end
subroutine fresnel ( t, c, s )
!
!*******************************************************************************
!
!! FRESNEL evaluates the real Fresnel integrals
!
!
!  Parameters:
!
!    Input, real T, ?
!
!    Output, real C, S, ?
!
  real n
  real a(6)
  real ad(6)
  real an(6)
  real b(6)
  real bd(6)
  real bn(6)
  real cd(5)
  real cn(5)
  real cp(13)
  real dd(5)
  real dn(5)
  real fp(7)
  real gp(7)
  integer imax
  real p(6)
  real pd(6)
  real pi
  real pn(6)
  real q(6)
  real qd(6)
  real qn(6)
  real sp(13)
!
  data a(1)/-.119278241233760e-05/,  a(2)/.540730666359417e-04/, &
       a(3)/-.160488306381990e-02/,  a(4)/.281855008757077e-01/, &
       a(5)/-.246740110027210e+00/,  a(6)/.100000000000000e+01/
  data b(1)/-.155653074871090e-06/,  b(2)/.844415353045065e-05/, &
       b(3)/-.312116934326082e-03/,  b(4)/.724478420395276e-02/, &
       b(5)/-.922805853580325e-01/,  b(6)/.523598775598300e+00/
!
  data cp(1) /.114739945188034e-20/,  cp(2) /-.384444827287950e-18/, &
       cp(3) /.832125729394275e-16/,  cp(4) /-.142979507360076e-13/, &
       cp(5) /.198954961821465e-11/,  cp(6) /-.220226545457144e-09/, &
       cp(7) /.188434924092257e-07/,  cp(8) /-.120009722914157e-05/, &
       cp(9) /.540741337442140e-04/,  cp(10)/-.160488313553028e-02/, &
       cp(11)/.281855008777956e-01/,  cp(12)/-.246740110027196e+00/, &
       cp(13)/.999999999999996e+00/
  data sp(1) /.705700784853927e-22/,  sp(2) /-.252757991492418e-19/, &
       sp(3) /.594117488940008e-17/,  sp(4) /-.112161631555448e-14/, &
       sp(5) /.173332189994074e-12/,  sp(6) /-.215742302078015e-10/, &
       sp(7) /.210821173208116e-08/,  sp(8) /-.156471443116560e-06/, &
       sp(9) /.844427287845253e-05/,  sp(10)/-.312116942346186e-03/, &
       sp(11)/.724478420418951e-02/,  sp(12)/-.922805853580323e-01/, &
       sp(13)/.523598775598300e+00/
!
  data pn(1)/.318309816100920e+00/,  pn(2)/.134919391391516e+02/, &
       pn(3)/.158258097490377e+03/,  pn(4)/.598796451682535e+03/, &
       pn(5)/.632369782194966e+03/,  pn(6)/.967985390141920e+02/
  data pd(1)/.100000000000000e+01/,  pd(2)/.426900960480796e+02/, &
       pd(3)/.509085485682426e+03/,  pd(4)/.200034664144742e+04/, &
       pd(5)/.231910140792937e+04/,  pd(6)/.486678558201084e+03/
  data qn(1)/.101320876178478e+00/,  qn(2)/.490534697099052e+01/, &
       qn(3)/.652095157811808e+02/,  qn(4)/.274183825747887e+03/, &
       qn(5)/.305040725009211e+03/,  qn(6)/.364566615872326e+02/
  data qd(1)/.100000000000000e+01/,  qd(2)/.499330024470621e+02/, &
       qd(3)/.709854097670206e+03/,  qd(4)/.343470762861172e+04/, &
       qd(5)/.522213879312684e+04/,  qd(6)/.168801831831851e+04/
!
  data an(1)/.318309885869756e+00/,  an(2)/.254179177393500e+02/, &
       an(3)/.575003792540838e+03/,  an(4)/.426673405867140e+04/, &
       an(5)/.891831887923938e+04/,  an(6)/.267955736537967e+04/
  data ad(1)/.100000000000000e+01/,  ad(2)/.801567066285184e+02/, &
       ad(3)/.182971463354850e+04/,  ad(4)/.138848884373420e+05/, &
       ad(5)/.309228411873207e+05/,  ad(6)/.120421274105856e+05/
  data bn(1)/.101321181932417e+00/,  bn(2)/.925021984290547e+01/, &
       bn(3)/.240932023056602e+03/,  bn(4)/.206079616836437e+04/, &
       bn(5)/.484901973010149e+04/,  bn(6)/.130680669688315e+04/
  data bd(1)/.100000000000000e+01/,  bd(2)/.928158182389149e+02/, &
       bd(3)/.250926840439955e+04/,  bd(4)/.233924458152954e+05/, &
       bd(5)/.685638896406835e+05/,  bd(6)/.418593101455019e+05/
!
  data cn(1)/.318309886182000e+00/,  cn(2)/.299191968327887e+02/, &
       cn(3)/.691428839605668e+03/,  cn(4)/.394539800974744e+04/, &
       cn(5)/.290314254767015e+04/
  data cd(1)/.100000000000000e+01/,  cd(2)/.942978925136851e+02/, &
       cd(3)/.219977296283666e+04/,  cd(4)/.129726479671006e+05/, &
       cd(5)/.114991427758165e+05/
  data dn(1)/.101321183630876e+00/,  dn(2)/.110988033615242e+02/, &
       dn(3)/.306282306497228e+03/,  dn(4)/.213130259794164e+04/, &
       dn(5)/.171270676541694e+04/
  data dd(1)/.100000000000000e+01/,  dd(2)/.111060616085627e+03/, &
       dd(3)/.318197586347414e+04/,  dd(4)/.249342095714049e+05/, &
       dd(5)/.359241903823488e+05/
!
  data fp(1)/.449763389301234e+05/,  fp(2)/-.188763642051836e+04/, &
       fp(3)/.669261097103246e+02/,  fp(4)/-.343966606879114e+01/, &
       fp(5)/.343112896133346e+00/,  fp(6)/-.967546019461500e-01/, &
       fp(7)/.318309886183465e+00/
  data gp(1)/.316642183365360e+06/,  gp(2)/-.120618995106638e+05/, &
       gp(3)/.359164749179351e+03/,  gp(4)/-.142252603258172e+02/, &
       gp(5)/.982934118445454e+00/,  gp(6)/-.153989722912325e+00/, &
       gp(7)/.101321183639714e+00/
!
  data p(1)/-654729075.0/,  p(2)/2027025.0/,  p(3)/-10395.0/, &
       p(4)/105.0/,  p(5)/-3.0/,  p(6)/1.0/
  data q(1)/-13749310575.0/,  q(2)/34459425.0/,  q(3)/-135135.0/, &
       q(4)/945.0/,  q(5)/-15.0/,  q(6)/1.0/
!
  imax = huge ( imax )
  x = abs(t)
  if (x > 4.0) go to 50
  xx = x*x
  y = xx*xx
!
!             evaluation of c(x) and s(x) for x < 1.65
!                          where x = abs(t)
!
  if (x > 0.6) go to 10
  c = ((((a(1)*y + a(2))*y + a(3))*y + a(4))*y + a(5))*y + a(6)
  s = ((((b(1)*y + b(2))*y + b(3))*y + b(4))*y + b(5))*y + b(6)
  c = t*c
  s = t*xx*s
  return
!
   10 if (x >= 1.65) go to 20
  c = cp(1)
  s = sp(1)
  do i = 2,13
     c = cp(i) + c*y
     s = sp(i) + s*y
  end do
  c = t*c
  s = t*xx*s
  return
!
!          evaluation of the auxiliary functions f(x) and g(x)
!                        for x >= 1.65
!
   20 if (x >= 2.0) go to 30
  fn = ((((pn(1)*y + pn(2))*y + pn(3))*y + pn(4))*y + pn(5))*y &
                   + pn(6)
  fd = ((((pd(1)*y + pd(2))*y + pd(3))*y + pd(4))*y + pd(5))*y &
                   + pd(6)
  gn = ((((qn(1)*y + qn(2))*y + qn(3))*y + qn(4))*y + qn(5))*y &
                   + qn(6)
  gd = ((((qd(1)*y + qd(2))*y + qd(3))*y + qd(4))*y + qd(5))*y &
                   + qd(6)
  f = fn/(x*fd)
  g = gn/(x*xx*gd)
  y = 0.5*xx
  go to 80
!
   30 if (x >= 3.0) go to 40
  fn = ((((an(1)*y + an(2))*y + an(3))*y + an(4))*y + an(5))*y &
                   + an(6)
  fd = ((((ad(1)*y + ad(2))*y + ad(3))*y + ad(4))*y + ad(5))*y &
                   + ad(6)
  gn = ((((bn(1)*y + bn(2))*y + bn(3))*y + bn(4))*y + bn(5))*y &
                   + bn(6)
  gd = ((((bd(1)*y + bd(2))*y + bd(3))*y + bd(4))*y + bd(5))*y &
                   + bd(6)
  f = fn/(x*fd)
  g = gn/(x*xx*gd)
  go to 70
!
   40 fn = (((cn(1)*y + cn(2))*y + cn(3))*y + cn(4))*y + cn(5)
  fd = (((cd(1)*y + cd(2))*y + cd(3))*y + cd(4))*y + cd(5)
  gn = (((dn(1)*y + dn(2))*y + dn(3))*y + dn(4))*y + dn(5)
  gd = (((dd(1)*y + dd(2))*y + dd(3))*y + dd(4))*y + dd(5)
  f = fn/(x*fd)
  g = gn/(x*xx*gd)
  go to 70
!
   50 if (x >= 6.0) go to 60
  xx = x*x
  y = 1.0/(xx*xx)
  f = (((((fp(1)*y + fp(2))*y + fp(3))*y + fp(4))*y + fp(5))*y &
                   + fp(6))*y + fp(7)
  g = (((((gp(1)*y + gp(2))*y + gp(3))*y + gp(4))*y + gp(5))*y &
                   + gp(6))*y + gp(7)
  f = f/x
  g = g/(x*xx)
  go to 70

   60 if (x >= real(imax)) go to 100
  pix = pi() * x
  pixx = pix * x
  y = 1.0E+00 / pixx
  y = y*y
  f = ((((p(1)*y + p(2))*y + p(3))*y + p(4))*y + p(5))*y + p(6)
  g = ((((q(1)*y + q(2))*y + q(3))*y + q(4))*y + q(5))*y + q(6)
  f = f / pix
  g = g / (pix*pixx)
!
!           evaluation of sin(0.5*pi*x*x) and cos(0.5*pi*x*x)
!                 the results are stored in sy and cy
!
   70 m = x
  l = mod(m,2)
  n = m - l
  y = x - m
  r = x - n
!
  y = y*n
  m = y
  y = y - m
  if (mod(m,2) /= 0) y = (y - 0.5) - 0.5
  y = y + 0.5*r*r
!
   80 sy = sin1(y)
  cy = cos1(y)
!
!                             termination
!
   90 c = 0.5 + (f*sy - g*cy)
  s = 0.5 - (f*cy + g*sy)
  if (t >= 0.0) return
     c = - c
     s = - s
     return
!
  100 if (t < 0.0) go to 110
     c = 0.5
     s = 0.5
     return
  110 c = -0.5
  s = -0.5
  return
end
subroutine fresnel_cos_values ( n, x, fx )
!
!*****************************************************************************80
!
!! FRESNEL_COS_VALUES returns some values of Fresnel cosine integral function.
!
!
!  Modified:
!
!    29 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.0000000E+00, 0.1999211E+00, 0.3974808E+00, 0.5810954E+00, &
    0.7228442E+00, 0.7798934E+00, 0.7154377E+00, 0.5430958E+00, &
    0.3654617E+00, 0.3336329E+00, 0.4882534E+00, 0.6362860E+00, &
    0.5549614E+00, 0.3889375E+00, 0.4674917E+00, 0.6057208E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.0E+00,  0.2E+00,  0.4E+00,  0.6E+00, &
     0.8E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
     1.6E+00,  1.8E+00,  2.0E+00,  2.2E+00, &
     2.4E+00,  2.6E+00,  2.8E+00,  3.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine fresnel_sin_values ( n, x, fx )
!
!*******************************************************************************
!
!! FRESNEL_SIN_VALUES returns some values of the Fresnel sine integral function.
!
!
!  Modified:
!
!    27 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.0000000E+00, 0.0041876E+00, 0.0333594E+00, 0.1105402E+00, &
    0.2493414E+00, 0.4382591E+00, 0.6234009E+00, 0.7135251E+00, &
    0.6388877E+00, 0.4509388E+00, 0.3434157E+00, 0.4557046E+00, &
    0.6196900E+00, 0.5499893E+00, 0.3915284E+00, 0.4963130E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.0E+00,  0.2E+00,  0.4E+00,  0.6E+00, &
     0.8E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
     1.6E+00,  1.8E+00,  2.0E+00,  2.2E+00, &
     2.4E+00,  2.6E+00,  2.8E+00,  3.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine fstocd (n, x, fcn, typsiz, r, g)
!
!*******************************************************************************
!
!! FSTOCD: find central difference approximation g to the first derivative
!     (gradient) of the function defined by fcn at the point x.
!
!
!     input ...
!
!       n          dimension of problem
!       x(n)       point at which gradient is to be approximated
!       fcn        name of subroutine to evaluate function
!       typsiz(n)  scaling vector for x
!       r          stepsize factor
!
!     output ...
!
!       g(n)       central difference approximation to gradient
!
!
  real x(n), typsiz(n), g(n)
  external fcn
!
!     find i-th  stepsize, evaluate two neighbors in direction of
!     i-th unit vector, and evaluate i-th  component of gradient.
!
  do 10 i = 1, n
     stepi = r * max ( abs(x(i)),typsiz(i))
     xtempi = x(i)
     x(i) = xtempi + stepi
     call fcn (n, x, fplus)
     x(i) = xtempi - stepi
     call fcn (n, x, fminus)
     x(i) = xtempi
     g(i) = (fplus - fminus)/(2.0*stepi)
   10 continue
  return
end
subroutine fstofd (n, x, fcn, fx, g, typsiz, r)
!
!*******************************************************************************
!
!! FSTOFD: find forward difference approximation g to the first derivative
!     (gradient) of the function defined by fcn at the point x.
!
!
!     input ...
!
!       n          dimension of problem
!       x(n)       point at which the gradient is to be approximated
!       fcn        name of subroutine to evaluate function
!       fx         value of fcn at the point x
!       typsiz(n)  scaling vector for x
!       r          stepsize factor
!
!     output ...
!
!       g(n)       finite difference approximation to the gradient
!
!
  dimension x(n), g(n), typsiz(n)
  external fcn
!
  do 10 j = 1,n
    stepsz = r * max ( abs(x(j)),typsiz(j))
    xtmpj = x(j)
    x(j) = xtmpj + stepsz
    call fcn (n, x, fplus)
    x(j) = xtmpj
    g(j) = (fplus - fx)/stepsz
   10 continue
  return
end
subroutine fupd(a1, a2, p1, p2, v1, v2, i1, k1, n, m, np1)
!
!*******************************************************************************
!
!! FUPD: forward step updating
!
  integer a1(m), a2(m), p1(np1), p2(np1), v1(n), v2(n)
!
  j1 = p1(i1) + 1
  j2 = p1(i1+1)
  do 30 j=j1,j2
    if (a1(j) < 0) go to 30
    ia = a1(j)
    l1 = p2(ia) + 1
    l2 = p2(ia+1)
    do 10 l=l1,l2
      if (a2(l)==i1) go to 20
   10   continue
   20   v2(ia) = v2(ia) - 1
    a2(l) = k1 - a2(l)
    a1(j) = k1 - ia
   30 continue
  v1(i1) = 0
  return
end
subroutine fxdec (fcn, n, x, fx, r)
!
!*******************************************************************************
!
!! FXDEC: fixed step coordinate descent procedure / one iteration
!
  real x(n)
  external fcn
!
  do 20 i = 1,n
     h = r * max ( abs(x(i)), 1.0)
     xi = x(i)
     xplus = xi + h
     x(i) = xplus
     call fcn (n, x, fplus)
     xminus = xi - 1.1*h
     x(i) = xminus
     call fcn (n, x, fminus)
     x(i) = xi
!
     if (fx <= fplus) go to 10
        fx = fplus
        x(i) = xplus
   10    if (fx <= fminus) go to 20
        fx = fminus
        x(i) = xminus
   20 continue
  return
end
subroutine fxshfr(l2, nz, nn, p, qp, k, qk, svk)
!
!*******************************************************************************
!
!! FXSHFR computes up to  l2  fixed shift k-polynomials,
!     testing for convergence in the linear or quadratic
!     case. initiates one of the variable shift
!     iterations and returns with the number of zeros
!     found.
!
!     l2 - limit of fixed shift steps
!     nz - number of zeros found
!
  double precision p(nn), qp(nn), k(nn), qk(nn), svk(nn)
  double precision svu, svv, ui, vi, s
  real betas, betav, oss, ovv, ss, vv, ts, tv, ots, otv, &
       tvv, tss
  integer l2, nz, type, i, j, iflag
  logical vpass, spass, vtry, stry
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
  n = nn - 1
  nz = 0
  betav = .25
  betas = .25
  oss = sr
  ovv = v
!
!     evaluate polynomial by synthetic division
!
  call quadsd(nn, u, v, p, qp, a, b)
  call calcsc(type, n, k, qk)
  do 80 j = 1,l2
!
!     calculate next k polynomial and estimate v
!
     call nextk(type, n, qp, k, qk)
     call calcsc(type, n, k, qk)
     call newest(type, ui, vi, nn, p, k)
     vv = vi
!
!     estimate s
!
     ss = 0.0
     if (k(n) /= 0.d0) ss = -p(nn)/k(n)
     tv = 1.0
     ts = 1.0
     if (j == 1 .or. type == 3) go to 70
!
!     compute relative measures of convergence of s and v
!     sequences
!
     if (vv /= 0.0) tv = abs((vv - ovv)/vv)
     if (ss /= 0.0) ts = abs((ss - oss)/ss)
!
!     if decreasing, multiply two most recent
!     convergence measures
!
     tvv = 1.0
     if (tv < otv) tvv = tv*otv
     tss = 1.0
     if (ts < ots) tss = ts*ots
!
!     compare with convergence criteria
!
     vpass = tvv < betav
     spass = tss < betas
     if (.not.(spass .or. vpass)) go to 70
!
!     at least one sequence has passed the convergence
!     test. store variables before iterating
!
     svu = u
     svv = v
     do 10 i = 1,n
        svk(i) = k(i)
   10    continue
     s = ss
!
!     choose iteration according to the fastest
!     converging sequence
!
     vtry = .false.
     stry = .false.
     if (spass .and. ((.not.vpass) .or. &
                        tss < tvv)) go to 40
   20    call quadit(ui, vi, nz, nn, p, qp, k, qk)
     if (nz > 0) return
!
!     quadratic iteration has failed. flag that it has
!     been tried and decrease the convergence criterion.
!
     vtry = .true.
     betav = betav*0.25
!
!     try linear iteration if it has not been tried and
!     the s sequence is converging
!
     if (stry .or. (.not.spass)) go to 50
     do 30 i = 1,n
        k(i) = svk(i)
   30    continue
   40    call realit(s, nz, iflag, nn, p, qp, k, qk)
     if (nz > 0) return
!
!     linear iteration has failed. flag that it has been
!     tried and decrease the convergence criterion
!
     stry = .true.
     betas = betas*0.25
     if (iflag == 0) go to 50
!
!     if linear iteration signals an almost double real
!     zero attempt quadratic interation
!
     ui = -(s + s)
     vi = s*s
     go to 20
!
!     restore variables
!
   50    u = svu
     v = svv
     do 60 i=1,n
        k(i) = svk(i)
   60    continue
!
!     try quadratic iteration if it has not been tried
!     and the v sequence is converging
!
     if (vpass .and. (.not.vtry)) go to 20
!
!     recompute qp and scalar values to continue the
!     second stage
!
     call quadsd(nn, u, v, p, qp, a, b)
     call calcsc(type, n, k, qk)
   70    ovv = vv
     oss = ss
     otv = tv
     ots = ts
   80 continue
  return
end
subroutine fxshft(l2,zr,zi,conv,nn,pr,pi,hr,hi,qpr,qpi, &
                    qhr,qhi,shr,shi,sr,si,tr,ti,pvr,pvi, &
                    are,mre,eta,infin)
!
!*******************************************************************************
!
!! FXSHFT computes l2 fixed-shift h polynomials and tests for convergence.
!
!
!     initiates a variable-shift iteration and returns with the
!     approximate zero if successful.
!
!     l2 - limit of fixed-shift steps
!     zr,zi - approximate zero if conv is .true.
!     conv - logical variable indicating convergence of stage 3
!            iteration
!
  double precision sr,si,tr,ti,pvr,pvi,are,mre,eta,infin, &
               pr(nn),pi(nn),qpr(nn),qpi(nn),hr(nn),hi(nn), &
               qhr(nn),qhi(nn),shr(nn),shi(nn)
  double precision zr,zi,otr,oti,svsr,svsi,dcpabs
  logical conv,test,pasd,bool
!
     n = nn - 1
!
!     evaluate p at s
!
     call polyev(nn,sr,si,pr,pi,qpr,qpi,pvr,pvi)
     test = .true.
     pasd = .false.
!
!     calculate t = -p(s)/h(s)
!
     call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
!
!     main loop for one second stage step.
!
     do 50 j = 1,l2
        otr = tr
        oti = ti
!
!     compute next h polynomial and new t.
!
        call nexth(bool,n,tr,ti,hr,hi,qpr,qpi,qhr,qhi)
        call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
        zr = sr + tr
        zi = si + ti
!
!     test for convergence unless stage 3 has failed once or this
!     is the last h polynomial.
!
        if (bool .or. (.not. test) .or. j == l2) go to 50
        if (dcpabs(tr - otr,ti - oti) >= 0.5d0*dcpabs(zr,zi)) &
           go to 40
        if (.not. pasd) go to 30
!
!     the weak convergence test has been passed twice. start the
!     third shift iteration after saving the current h polynomial
!     and shift.
!
           do 10 i = 1,n
              shr(i) = hr(i)
              shi(i) = hi(i)
   10          continue
           svsr = sr
           svsi = si
           call vrshft(10,zr,zi,conv,nn,pr,pi,hr,hi,qpr,qpi,qhr, &
                       qhi,sr,si,tr,ti,pvr,pvi,are,mre,eta,infin)
           if (conv) return
!
!     the iteration failed to converge. turn off testing and restore
!     h,s,pv and t.
!
           test = .false.
           do 20 i = 1,n
              hr(i) = shr(i)
              hi(i) = shi(i)
   20          continue
           sr = svsr
           si = svsi
           call polyev(nn,sr,si,pr,pi,qpr,qpi,pvr,pvi)
           call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
           go to 50
!
   30       pasd = .true.
        go to 50
!
   40       pasd = .false.
   50    continue
!
!     attempt an iteration with final h polynomial from second stage.
!
  call vrshft(10,zr,zi,conv,nn,pr,pi,hr,hi,qpr,qpi,qhr,qhi, &
                    sr,si,tr,ti,pvr,pvi,are,mre,eta,infin)
  return
end
function gam1 ( a )
!
!*******************************************************************************
!
!! GAM1: computation of 1/gamma(a+1) - 1  for -0.5 <= a <= 1.5
!
  real gam1
  real p(7), q(5), r(9)
!
  data p(1)/ .577215664901533e+00/, p(2)/-.409078193005776e+00/, &
       p(3)/-.230975380857675e+00/, p(4)/ .597275330452234e-01/, &
       p(5)/ .766968181649490e-02/, p(6)/-.514889771323592e-02/, &
       p(7)/ .589597428611429e-03/
!
  data q(1)/ .100000000000000e+01/, q(2)/ .427569613095214e+00/, &
       q(3)/ .158451672430138e+00/, q(4)/ .261132021441447e-01/, &
       q(5)/ .423244297896961e-02/
!
  data r(1)/-.422784335098468e+00/, r(2)/-.771330383816272e+00/, &
       r(3)/-.244757765222226e+00/, r(4)/ .118378989872749e+00/, &
       r(5)/ .930357293360349e-03/, r(6)/-.118290993445146e-01/, &
       r(7)/ .223047661158249e-02/, r(8)/ .266505979058923e-03/, &
       r(9)/-.132674909766242e-03/
!
  data s1  / .273076135303957e+00/, s2  / .559398236957378e-01/
!
  t = a
  d = a - 0.5
  if (d > 0.0) t = d - 0.5
  if (t) 30,10,20
!
   10 gam1 = 0.0
  return
!
   20 top = (((((p(7)*t + p(6))*t + p(5))*t + p(4))*t + p(3))*t &
                    + p(2))*t + p(1)
  bot = (((q(5)*t + q(4))*t + q(3))*t + q(2))*t + 1.0
  w = top/bot
  if (d > 0.0) go to 21
     gam1 = a*w
     return
   21 gam1 = (t/a)*((w - 0.5) - 0.5)
  return
!
   30 top = (((((((r(9)*t + r(8))*t + r(7))*t + r(6))*t + r(5))*t &
                      + r(4))*t + r(3))*t + r(2))*t + r(1)
  bot = (s2*t + s1)*t + 1.0
  w = top/bot

  if ( d > 0.0 ) go to 31
     gam1 = a*((w + 0.5) + 0.5)
     return
   31 gam1 = t*w/a
  return
end
subroutine gaminv (a, x, x0, p, q, ierr)
!
!*******************************************************************************
!
!! GAMINV: inverse incomplete gamma ratio function
!
!     given positive a, and nonegative p and q where p + q = 1.
!     then x is computed where p(a,x) = p and q(a,x) = q. schroder
!     iteration is employed. the routine attempts to compute x
!     to 10 significant digits if this is possible for the
!     particular computer arithmetic being used.
!
!
!
!     x is a variable. if p = 0 then x is assigned the value 0,
!     and if q = 0 then x is set to the largest floating point
!     number available. otherwise, gaminv attempts to obtain
!     a solution for p(a,x) = p and q(a,x) = q. if the routine
!     is successful then the solution is stored in x.
!
!     x0 is an optional initial approximation for x. if the user
!     does not wish to supply an initial approximation, then set
!     x0 <= 0.
!
!     ierr is a variable that reports the status of the results.
!     when the routine terminates, ierr has one of the following
!     values ...
!
!       ierr =  0    the solution was obtained. iteration was
!                    not used.
!       ierr > 0    the solution was obtained. ierr iterations
!                    were performed.
!       ierr = -2    (input error) a <= 0
!       ierr = -3    no solution was obtained. the ratio q/a
!                    is too large.
!       ierr = -4    (input error) p + q /= 1
!       ierr = -6    20 iterations were performed. the most
!                    recent value obtained for x is given.
!                    this cannot occur if x0 <= 0.
!       ierr = -7    iteration failed. no value is given for x.
!                    this may occur when x is approximately 0.
!       ierr = -8    a value for x has been obtained, but the
!                    routine is not certain of its accuracy.
!                    iteration cannot be performed in this
!                    case. if x0 <= 0, this can occur only
!                    when p or q is approximately 0. if x0 is
!                    positive then this can occur when a is
!                    exceedingly close to x and a is extremely
!                    large (say a >= 1.e20).
!
!     written by Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  real c
  real euler_constant
  real ln10
  real eps0(2), amin(2), bmin(2), dmin(2), emin(2)
!
!     ln10 = ln(10)
!     c = euler constant
!
  data ln10 /2.302585/
!
  data a0 /3.31125922108741/, a1 /11.6616720288968/, &
       a2 /4.28342155967104/, a3 /.213623493715853/
  data b1 /6.61053765625462/, b2 /6.40691597760039/, &
       b3 /1.27364489782223/, b4 /.036117081018842/
!
  data eps0(1) /1.e-10/, eps0(2) /1.e-08/
  data amin(1) / 500.0/, amin(2) / 100.0/
  data bmin(1) /1.e-28/, bmin(2) /1.e-13/
  data dmin(1) /1.e-06/, dmin(2) /1.e-04/
  data emin(1) /2.e-03/, emin(2) /6.e-03/
!
  data tol /1.0e-5/
!
!     xmin, and xmax are machine dependent constants.
!            xmin is the smallest positive number and xmax is the
!            largest positive number.
!
  c = euler_constant ( )
  e = epsilon ( e )
  xmin = tiny ( xmin )
  xmax = huge ( xmax )

  x = 0.0
  if (a <= 0.0) go to 500
  t = dble(p) + dble(q) - 1.d0
  if (abs(t) > max ( e, 1.e-14)) go to 520
!
  ierr = 0
  if (p == 0.0) return
  if (q == 0.0) go to 400
  if (a == 1.0) go to 410
!
  e2 = 2.0*e
  amax = 0.4e-10/(e*e)
  iop = 1
  if (e > 1.e-10) iop = 2
  eps = eps0(iop)
  xn = x0
  if (x0 > 0.0) go to 100
!
!        selection of the initial approximation xn of x
!                       when a < 1
!
  if (a > 1.0) go to 30
  g = gamma(a + 1.0)
  qg = q*g
  if (qg == 0.0) go to 560
  b = qg/a
  if (qg > 0.6*a) go to 20
  if (a >= 0.30 .or. b < 0.35) go to 10
     t = exp(-(b + c))
     u = t*exp(t)
     xn = t*exp(u)
     go to 100
!
   10 if (b >= 0.45) go to 20
  if (b == 0.0) go to 560
  y = -alog(b)
  s = 0.5 + (0.5 - a)
  z = alog(y)
  t = y - s*z
  if (b < 0.15) go to 11
     xn = y - s*alog(t) - alog(1.0 + s/(t + 1.0))
     go to 200
   11 if (b <= 0.01) go to 12
     u = ((t + 2.0*(3.0 - a))*t + (2.0 - a)*(3.0 - a))/ &
             ((t + (5.0 - a))*t + 2.0)
     xn = y - s*alog(t) - alog(u)
     go to 200
   12 c1 = -s*z
  c2 = -s*(1.0 + c1)
  c3 =  s*((0.5*c1 + (2.0 - a))*c1 + (2.5 - 1.5*a))
  c4 = -s*(((c1/3.0 + (2.5 - 1.5*a))*c1 + ((a - 6.0)*a + 7.0))*c1 &
             + ((11.0*a - 46)*a + 47.0)/6.0)
  c5 = -s*((((-c1/4.0 + (11.0*a - 17.0)/6.0)*c1 &
             + ((-3.0*a + 13.0)*a - 13.0))*c1 &
             + 0.5*(((2.0*a - 25.0)*a + 72.0)*a - 61.0))*c1 &
             + (((25.0*a - 195.0)*a + 477.0)*a -379.0)/12.0)
  xn = ((((c5/y + c4)/y + c3)/y + c2)/y + c1) + y
  if (a > 1.0) go to 200
  if (b > bmin(iop)) go to 200
  x = xn
  return
!
   20 if (b*q > 1.e-8) go to 21
     xn = exp(-(q/a + c))
     go to 23
   21 if (p <= 0.9) go to 22
     xn = exp((alnrel(-q) + gamln1(a))/a)
     go to 23
   22 xn = exp(alog(p*g)/a)
   23 if (xn == 0.0) go to 510
  t = 0.5 + (0.5 - xn/(a + 1.0))
  xn = xn/t
  go to 100
!
!        selection of the initial approximation xn of x
!                       when a > 1
!
   30 if (q <= 0.5) go to 31
     w = alog(p)
     go to 32
   31 w = alog(q)
   32 t = sqrt(-2.0*w)
  s = t - (((a3*t + a2)*t + a1)*t + a0)/((((b4*t + b3)*t &
                  + b2)*t + b1)*t + 1.0)
  if (q > 0.5) s = -s
!
  rta = sqrt(a)
  s2 = s*s
  xn = a + s*rta + (s2 - 1.0)/3.0 + s*(s2 - 7.0)/(36.0*rta) &
         - ((3.0*s2 + 7.0)*s2 - 16.0)/(810.0*a) &
         + s*((9.0*s2 + 256.0)*s2 - 433.0)/(38880.0*a*rta)
  xn = max ( xn, 0.0)
  if (a < amin(iop)) go to 40
  x = xn
  d = 0.5 + (0.5 - x/a)
  if (abs(d) <= dmin(iop)) return
!
   40 if (p <= 0.5) go to 50
  if (xn < 3.0*a) go to 200
  y = -(w + gamln(a))
  d = max ( 2.0, a*(a - 1.0))
  if (y < ln10*d) go to 41
     s = 1.0 - a
     z = alog(y)
     go to 12
   41 t = a - 1.0
  xn = y + t*alog(xn) - alnrel(-t/(xn + 1.0))
  xn = y + t*alog(xn) - alnrel(-t/(xn + 1.0))
  go to 200
!
   50 ap1 = a + 1.0
  if (xn > 0.70*ap1) go to 101
  w = w + gamln(ap1)
  if (xn > 0.15*ap1) go to 60
     ap2 = a + 2.0
     ap3 = a + 3.0
     x = exp((w + x)/a)
     x = exp((w + x - alog(1.0 + (x/ap1)*(1.0 + x/ap2)))/a)
     x = exp((w + x - alog(1.0 + (x/ap1)*(1.0 + x/ap2)))/a)
     x = exp((w + x - alog(1.0 + (x/ap1)*(1.0 + (x/ap2)*(1.0 &
                        + x/ap3))))/a)
     xn = x
     if (xn > 1.e-2*ap1) go to 60
     if (xn <= emin(iop)*ap1) return
     go to 101
!
   60 apn = ap1
  t = xn/apn
  sum = 1.0 + t
   61    apn = apn + 1.0
     t = t*(xn/apn)
     sum = sum + t
     if (t > 1.e-4) go to 61
  t = w - alog(sum)
  xn = exp((xn + t)/a)
  xn = xn*(1.0 - (a*alog(xn) - xn -t)/(a - xn))
  go to 101
!
!                 schroder iteration using p
!
  100 if (p > 0.5) go to 200
  101 if (p <= 1.e10*xmin) go to 550
  am1 = (a - 0.5) - 0.5
  102 if (a <= amax) go to 110
  d = 0.5 + (0.5 - xn/a)
  if (abs(d) <= e2) go to 550
!
  110 if (ierr >= 20) go to 530
  ierr = ierr + 1
  call gratio(a,xn,pn,qn,0)
  if (pn == 0.0 .or. qn == 0.0) go to 550
  r = rcomp(a,xn)
  if (r == 0.0) go to 550
  t = (pn - p)/r
  w = 0.5*(am1 - xn)
  if (abs(t) <= 0.1 .and. abs(w*t) <= 0.1) go to 120
     x = xn*(1.0 - t)
     if (x <= 0.0) go to 540
     d = abs(t)
     go to 121
!
  120 h = t*(1.0 + w*t)
  x = xn*(1.0 - h)
  if (x <= 0.0) go to 540
  if (abs(w) >= 1.0 .and. abs(w)*t*t <= eps) return
  d = abs(h)
  121 xn = x
  if (d > tol) go to 102
  if (d <= eps) return
  if (abs(p - pn) <= tol*p) return
  go to 102
!
!                 schroder iteration using q
!
  200 if (q <= 1.e10*xmin) go to 550
  am1 = (a - 0.5) - 0.5
  201 if (a <= amax) go to 210
  d = 0.5 + (0.5 - xn/a)
  if (abs(d) <= e2) go to 550
!
  210 if (ierr >= 20) go to 530
  ierr = ierr + 1
  call gratio(a,xn,pn,qn,0)
  if (pn == 0.0 .or. qn == 0.0) go to 550
  r = rcomp(a,xn)
  if (r == 0.0) go to 550
  t = (q - qn)/r
  w = 0.5*(am1 - xn)
  if (abs(t) <= 0.1 .and. abs(w*t) <= 0.1) go to 220
     x = xn*(1.0 - t)
     if (x <= 0.0) go to 540
     d = abs(t)
     go to 221
!
  220 h = t*(1.0 + w*t)
  x = xn*(1.0 - h)
  if (x <= 0.0) go to 540
  if (abs(w) >= 1.0 .and. abs(w)*t*t <= eps) return
  d = abs(h)
  221 xn = x
  if (d > tol) go to 201
  if (d <= eps) return
  if (abs(q - qn) <= tol*q) return
  go to 201
!
!                       special cases
!
  400 x = xmax
  return
!
  410 if (q < 0.9) go to 411
     x = -alnrel(-p)
     return
  411 x = -alog(q)
  return
!
!                       error return
!
  500 ierr = -2
  return
!
  510 ierr = -3
  return
!
  520 ierr = -4
  return
!
  530 ierr = -6
  return
!
  540 ierr = -7
  return
!
  550 x = xn
  ierr = -8
  return
!
  560 x = xmax
  ierr = -8
  return
end
function gamln ( a )
!
!*******************************************************************************
!
!! GAMLN: evaluation of ln(gamma(a)) for positive a
!
!     written by alfred h. morris
!          Naval Surface Weapons Center,
!          Dahlgren, Virginia
!
!     d = 0.5*(ln(2*pi) - 1)
!
  real gamln
  data d/.418938533204673/
!
  data c0/.833333333333333e-01/, c1/-.277777777770481e-02/, &
       c2/.793650663183693e-03/, c3/-.595156336428591e-03/, &
       c4/.820756370353826e-03/
!
  if (a > 0.8) go to 10
     gamln = gamln1(a) - alog(a)
     return
   10 if (a > 2.25) go to 20
     x = dble(a) - 1.d0
     gamln = gamln1(x)
     return
!
   20 if (a >= 15.0) go to 30
  n = a - 1.25
  x = a
  w = 1.0
  do 21 i = 1,n
     x = x - 1.0
   21    w = x*w
  gamln = gamln1(x - 1.0) + alog(w)
  return
!
   30 x = (1.0/a)**2
  w = ((((c4*x + c3)*x + c2)*x + c1)*x + c0)/a
  gamln = (d + w) + (a - 0.5)*(alog(a) - 1.0)

  return
end
function gamln1(a)
!
!*******************************************************************************
!
!! GAMLN1: evaluation of ln(gamma(1 + a)) for -0.2 <= a <= 1.25
!
  real gamln1
!
  data p0/ .577215664901533e+00/, p1/ .844203922187225e+00/, &
       p2/-.168860593646662e+00/, p3/-.780427615533591e+00/, &
       p4/-.402055799310489e+00/, p5/-.673562214325671e-01/, &
       p6/-.271935708322958e-02/
  data q1/ .288743195473681e+01/, q2/ .312755088914843e+01/, &
       q3/ .156875193295039e+01/, q4/ .361951990101499e+00/, &
       q5/ .325038868253937e-01/, q6/ .667465618796164e-03/
!
  data r0/.422784335098467e+00/,  r1/.848044614534529e+00/, &
       r2/.565221050691933e+00/,  r3/.156513060486551e+00/, &
       r4/.170502484022650e-01/,  r5/.497958207639485e-03/
  data s1/.124313399877507e+01/,  s2/.548042109832463e+00/, &
       s3/.101552187439830e+00/,  s4/.713309612391000e-02/, &
       s5/.116165475989616e-03/
!
  if (a >= 0.6) go to 10
  w = ((((((p6*a + p5)*a + p4)*a + p3)*a + p2)*a + p1)*a + p0)/ &
      ((((((q6*a + q5)*a + q4)*a + q3)*a + q2)*a + q1)*a + 1.0)
  gamln1 = -a*w
  return
!
   10 x = dble(a) - 1.d0
  w = (((((r5*x + r4)*x + r3)*x + r2)*x + r1)*x + r0)/ &
      (((((s5*x + s4)*x + s3)*x + s2)*x + s1)*x + 1.0)
  gamln1 = x*w
  return
end
function gamma(a)
!
!*******************************************************************************
!
!! GAMMA evaluates the Gamma function for a real argument.
!
!
!     gamma(a) is assigned the value 0 when the gamma function cannot
!     be computed.
!
!
!     written by Alfred Morris,
!          Naval Surface Weapons Center,
!          Dahlgren, Virginia
!
  real gamma
  real p(7), q(7)
  double precision d, g, z, lnx, glog
!
!     d = 0.5*(ln(2*pi) - 1)
!
  data pi /3.1415926535898/
  data d /.41893853320467274178d0/
!
  data p(1)/ .539637273585445e-03/,  p(2)/ .261939260042690e-02/, &
       p(3)/ .204493667594920e-01/,  p(4)/ .730981088720487e-01/, &
       p(5)/ .279648642639792e+00/,  p(6)/ .553413866010467e+00/, &
       p(7)/ 1.0/
  data q(1)/-.832979206704073e-03/,  q(2)/ .470059485860584e-02/, &
       q(3)/ .225211131035340e-01/,  q(4)/-.170458969313360e+00/, &
       q(5)/-.567902761974940e-01/,  q(6)/ .113062953091122e+01/, &
       q(7)/ 1.0/
!
  data r1/.820756370353826e-03/, r2/-.595156336428591e-03/, &
       r3/.793650663183693e-03/, r4/-.277777777770481e-02/, &
       r5/.833333333333333e-01/
!
  gamma = 0.0
  x = a
  if (abs(a) >= 15.0) go to 60
!
!            evaluation of gamma(a) for abs(a) < 15
!
  t = 1.0
  m = int(a) - 1
!
!     let t be the product of a-j when a >= 2
!
  if (m) 20,12,10
   10 do 11 j = 1,m
    x = x - 1.0
   11   t = x*t
   12 x = x - 1.0
  go to 40
!
!     let t be the product of a+j when a < 1
!
   20 t = a
  if (a > 0.0) go to 30
  m = - m - 1
  if (m == 0) go to 22
     do 21 j = 1,m
     x = x + 1.0
   21    t = x*t
   22 x = (x + 0.5) + 0.5
  t = x*t
  if (t == 0.0) return
!
   30 continue
!
!     the following code checks if 1/t can overflow. this
!     code may be omitted if desired.
!
  if (abs(t) >= 1.e-30) go to 40
  if (abs(t) * huge ( t ) <= 1.0001) return
  gamma = 1.0/t
  return
!
!     compute gamma(1 + x) for  0 <= x < 1
!
   40 top = p(1)
  bot = q(1)
  do i = 2,7
     top = p(i) + x*top
     bot = q(i) + x*bot
  end do
  gamma = top/bot
!
!     termination
!
  if (a < 1.0) go to 50
  gamma = gamma*t
  return
   50 gamma = gamma/t
  return
!
!            evaluation of gamma(a) for abs(a) >= 15
!
   60 if (abs(a) >= 1.e3) return
  if (a > 0.0) go to 70
  x = -a
  n = x
  t = x - n
  if (t > 0.9) t = 1.0 - t
  s = sin(pi*t)/pi
  if (mod(n,2) == 0) s = -s
  if (s == 0.0) return
!
!     compute the modified asymptotic sum
!
   70 t = 1.0/(x*x)
  g = ((((r1*t + r2)*t + r3)*t + r4)*t + r5)/x
!
!     one may replace the next statement with  lnx = alog(x)
!     but less accuracy will normally be obtained.
!
  lnx = glog(x)
!
!     final assembly
!
  z = x
  g = (d + g) + (z - 0.5d0)*(lnx - 1.d0)
  w = g
  t = g - dble(w)
  if (w > 0.99999*exparg(0)) return
  gamma = exp(w)*(1.0 + t)
  if (a < 0.0) gamma = (1.0/(gamma*s))/x
  return
end
subroutine gamma_inc_values ( n, a, x, fx )
!
!*******************************************************************************
!
!! GAMMA_INC_VALUES returns some values of the incomplete Gamma function.
!
!
!  Discussion:
!
!    The (normalized) incomplete Gamma function P(A,X) is defined as:
!
!      PN(A,X) = 1/GAMMA(A) * INTEGRAL (0 to X) T**(A-1) * EXP(-T) DT.
!
!    With this definition, for all A and X,
!
!      0 <= PN(A,X) <= 1
!
!    and
!
!      PN(A,INFINITY) = 1.0
!
!  Modified:
!
!    08 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real A, X, the arguments of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real a
  real, save, dimension ( nmax ) :: avec = (/ &
    0.1E+00,  0.1E+00,  0.1E+00,  0.5E+00, &
    0.5E+00,  0.5E+00,  1.0E+00,  1.0E+00, &
    1.0E+00,  1.1E+00,  1.1E+00,  1.1E+00, &
    2.0E+00,  2.0E+00,  2.0E+00,  6.0E+00, &
    6.0E+00, 11.0E+00, 26.0E+00, 41.0E+00 /)
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.7420263E+00, 0.9119753E+00, 0.9898955E+00, 0.2931279E+00, &
    0.7656418E+00, 0.9921661E+00, 0.0951626E+00, 0.6321206E+00, &
    0.9932621E+00, 0.0757471E+00, 0.6076457E+00, 0.9933425E+00, &
    0.0091054E+00, 0.4130643E+00, 0.9931450E+00, 0.0387318E+00, &
    0.9825937E+00, 0.9404267E+00, 0.4863866E+00, 0.7359709E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    3.1622777E-02, 3.1622777E-01, 1.5811388E+00, 7.0710678E-02, &
    7.0710678E-01, 3.5355339E+00, 0.1000000E+00, 1.0000000E+00, &
    5.0000000E+00, 1.0488088E-01, 1.0488088E+00, 5.2440442E+00, &
    1.4142136E-01, 1.4142136E+00, 7.0710678E+00, 2.4494897E+00, &
    1.2247449E+01, 1.6583124E+01, 2.5495098E+01, 4.4821870E+01 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    a = 0.0E+00
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  a = avec(n)
  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine gamma_values ( n, x, fx )
!
!*******************************************************************************
!
!! GAMMA_VALUES returns some values of the Gamma function for testing.
!
!
!  Modified:
!
!    17 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 18
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    4.590845E+00,     2.218160E+00,     1.489192E+00,     1.164230E+00, &
    1.0000000000E+00, 0.9513507699E+00, 0.9181687424E+00, 0.8974706963E+00, &
    0.8872638175E+00, 0.8862269255E+00, 0.8935153493E+00, 0.9086387329E+00, &
    0.9313837710E+00, 0.9617658319E+00, 1.0000000000E+00, 3.6288000E+05, &
    1.2164510E+17,    8.8417620E+30 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.2E+00,  0.4E+00,  0.6E+00,  0.8E+00, &
    1.0E+00,  1.1E+00,  1.2E+00,  1.3E+00, &
    1.4E+00,  1.5E+00,  1.6E+00,  1.7E+00, &
    1.8E+00,  1.9E+00,  2.0E+00, 10.0E+00, &
   20.0E+00, 30.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine gerk(f,neqn,y,t,tout,relerr,abserr,iflag,gerror, &
                  work,iwork)
!
!*******************************************************************************
!
!! GERK: fehlberg 4,5 order runge-kutta method with global error assessment
!
!
!  Discussion:
!
!    GERK is designed to solve systems of differential equations when
!    it is important to have a readily available global error estimate.
!    parallel integration is performed to yield two solutions on
!    different mesh spacings and global extrapolation is applied to
!    provide an estimate of the global error in the more accurate
!    solution.
!
!  Author:
!
!    h.a.watts and l.f.shampine
!    sandia laboratories
!
!  Abstract:
!
!    subroutine  gerk  integrates a system of neqn first order
!    ordinary differential equations of the form
!             dy(i)/dt = f(t,y(1),y(2),...,y(neqn))
!              where the y(i) are given at t .
!    typically the subroutine is used to integrate from t to tout but it
!    can be used as a one-step integrator to advance the solution a
!    single step in the direction of tout. on return,an estimate of the
!    global error in the solution at t is provided and the parameters in
!    the call list are set for continuing the integration. the user has
!    only to call gerk again (and perhaps define a new value for tout).
!    actually, gerk  is merely an interfacing routine which allocates
!    virtual storage in the arrays work,iwork and calls subroutine gerks
!    for the solution.  gerks  in turn calls subroutine  fehl  which
!    computes an approximate solution over one step.
!
!    gerk  uses the runge-kutta-fehlberg (4,5)  method described
!    in the reference
!    e.fehlberg , low-order classical runge-kutta formulas with stepsize
!                 control , nasa tr r-315
!
!
!    the parameters represent-
!      f -- subroutine f(t,y,yp) to evaluate derivatives yp(i)=dy(i)/dt
!      neqn -- number of equations to be integrated
!      y(*) -- solution vector at t
!      t -- independent variable
!      tout -- output point at which solution is desired
!      relerr,abserr -- relative and absolute error tolerances for local
!            error test. at each step the code requires that
!                 abs(local error) <= relerr*abs(y) + abserr
!            for each component of the local error and solution vectors
!      iflag -- indicator for status of integration
!      gerror(*) -- vector which estimates the global error at t. that
!                   is, gerror(i) approximates  y(i)-true solution(i).
!      work(*) -- array to hold information internal to gerk which is
!            necessary for subsequent calls. must be dimensioned
!            at least  3+8*neqn.
!      iwork(*) -- integer array used to hold information internal to
!            gerk which is necessary for subsequent calls. must be
!            dimensioned at least  5.
!
!
!
!  first call to gerk
!
!
!    the user must provide storage in his calling program for the arrays
!    in the call list  -      y(neqn) , work(3+8*neqn) , iwork(5)  ,
!    declare f in an external statement, supply subroutine f(t,y,yp) and
!    initialize the following parameters-
!
!      neqn -- number of equations to be integrated.  (neqn >= 1)
!      y(*) -- vector of initial conditions
!      t -- starting point of integration , must be a variable
!      tout -- output point at which solution is desired.
!            t=tout is allowed on the first call only,in which case gerk
!            returns with iflag=2 if continuation is possible.
!      relerr,abserr -- relative and absolute local error tolerances
!            which must be non-negative but may be constants. we can
!            usually expect the global errors to be somewhat smaller
!            than the requested local error tolerances. to avoid
!            limiting precision difficulties the code always uses the
!            larger of relerr and an internal relative error parameter
!            which is machine dependent.
!      iflag -- +1,-1  indicator to initialize the code for each new
!            problem. normal input is +1. the user should set iflag=-1
!            only when one-step integrator control is essential. in this
!            case, gerk attempts to advance the solution a single step
!            in the direction of tout each time it is called. since this
!            mode of operation results in extra computing overhead, it
!            should be avoided unless needed.
!
!
!
!  output from gerk
!
!
!      y(*) -- solution at t
!      t -- last point reached in integration.
!      iflag = 2 -- integration reached tout.indicates successful return
!                   and is the normal mode for continuing integration.
!            =-2 -- a single successful step in the direction of tout
!                   has been taken. normal mode for continuing
!                   integration one step at a time.
!            = 3 -- integration was not completed because more than
!                   9000 derivative evaluations were needed. this
!                   is approximately 500 steps.
!            = 4 -- integration was not completed because solution
!                   vanished making a pure relative error test
!                   impossible. must use non-zero abserr to continue.
!                   using the one-step integration mode for one step
!                   is a good way to proceed.
!            = 5 -- integration was not completed because requested
!                   accuracy could not be achieved using smallest
!                   allowable stepsize. user must increase the error
!                   tolerance before continued integration can be
!                   attempted.
!            = 6 -- gerk is being used inefficiently in solving
!                   this problem. too much output is restricting the
!                   natural stepsize choice. use the one-step
!                   integrator mode.
!            = 7 -- invalid input parameters
!                   this indicator occurs if any of the following is
!                   satisfied -   neqn <= 0
!                                 t=tout  and  iflag /= +1 or -1
!                                 relerr or abserr < 0.
!                                 iflag == 0  or  < -2  or  > 7
!      gerror(*) -- estimate of the global error in the solution at t
!      work(*),iwork(*) -- information which is usually of no interest
!                   to the user but necessary for subsequent calls.
!                   work(1),...,work(neqn) contain the first derivatives
!                   of the solution vector y at t. work(neqn+1) contains
!                   the stepsize h to be attempted on the next step.
!                   iwork(1) contains the derivative evaluation counter.
!
!
!
!  subsequent calls to gerk
!
!
!    subroutine gerk returns with all information needed to continue the
!    integration. if the integration reached tout,the user need only
!    define a new tout and call gerk again. in the one-step integrator
!    mode (iflag=-2) the user must keep in mind that each step taken is
!    in the direction of the current tout. upon reaching tout (indicated
!    by changing iflag to 2),the user must then define a new tout and
!    reset iflag to -2 to continue in the one-step integrator mode.
!
!    if the integration was not completed but the user still wants to
!    continue (iflag=3 case), he just calls gerk again. the function
!    counter is then reset to 0 and another 9000 function evaluations
!    are allowed.
!
!    however,in the case iflag=4, the user must first alter the error
!    criterion to use a positive value of abserr before integration can
!    proceed. if he does not,execution is terminated.
!
!    also,in the case iflag=5, it is necessary for the user to reset
!    iflag to 2 (or -2 when the one-step integration mode is being used)
!    as well as increasing either abserr,relerr or both before the
!    integration can be continued. if this is not done, execution will
!    be terminated. the occurrence of iflag=5 indicates a trouble spot
!    (solution is changing rapidly,singularity may be present) and it
!    often is inadvisable to continue.
!
!    if iflag=6 is encountered, the user should use the one-step
!    integration mode with the stepsize determined by the code. if the
!    user insists upon continuing the integration with gerk in the
!    interval mode, he must reset iflag to 2 before calling gerk again.
!    otherwise,execution will be terminated.
!
!    if iflag=7 is obtained, integration can not be continued unless
!    the invalid input parameters are corrected.
!
!    it should be noted that the arrays work,iwork contain information
!    required for subsequent integration. accordingly, work and iwork
!    should not be altered.
!
  dimension y(neqn),gerror(neqn),work(*),iwork(5)
!
  external f
!
!
!     compute indices for the splitting of the work array
!
  k1m=neqn+1
  k1=k1m+1
  k2=k1+neqn
  k3=k2+neqn
  k4=k3+neqn
  k5=k4+neqn
  k6=k5+neqn
  k7=k6+neqn
  k8=k7+neqn
!
!     this interfacing routine merely relieves the user of a long
!     calling list via the splitting apart of two working storage
!     arrays. if this is not compatible with the users compiler,
!     he must use gerks directly.
!
  call gerks(f,neqn,y,t,tout,relerr,abserr,iflag,gerror, &
            work(1),work(k1m),work(k1),work(k2),work(k3),work(k4), &
            work(k5),work(k6),work(k7),work(k8),work(k8+1), &
            iwork(1),iwork(2),iwork(3),iwork(4),iwork(5))
!
  return
end
subroutine gerks(f,neqn,y,t,tout,relerr,abserr,iflag,gerror, &
                  yp,h,f1,f2,f3,f4,f5,yg,ygp,savre,savae, &
                  nfe,kop,init,jflag,kflag)
!
!*******************************************************************************
!
!! GERKS: fehlberg 4,5 order runge-kutta method with global error assessment
!
!     gerks integrates a system of first order ordinary differential
!     equations as described in the comments for gerk.  the arrays
!     yp,f1,f2,f3,f4,f5,yg and ygp (of dimension at least neqn) and
!     the variables h,savre,savae,nfe,kop,init,jflag,and kflag are used
!     internally by the code and appear in the call list to eliminate
!     local retention of variables between calls. accordingly, they
!     should not be altered. items of possible interest are
!         yp - derivative of solution vector at t
!         h  - an appropriate stepsize to be used for the next step
!         nfe- counter on the number of derivative function evaluations
!
  logical hfaild,output
!
  dimension y(neqn),yp(neqn),f1(neqn),f2(neqn),f3(neqn),f4(neqn), &
            f5(neqn),yg(neqn),ygp(neqn),gerror(neqn)
!
  external f
!
  u = epsilon ( u )
!
!  remin is a tolerance threshold which is also determined by the
!  integration method. in particular, a fifth order method will
!  generally not be capable of delivering accuracies near limiting
!  precision on computers with long wordlengths.
!
  remin = 3.e-11
!
!     the expense is controlled by restricting the number
!     of function evaluations to be approximately maxnfe.
!     as set,this corresponds to about 500 steps.
!
  maxnfe = 9000
!
!     check input parameters
!
!
  if (neqn < 1) go to 10
  if ((relerr < 0.)  .or.  (abserr  <  0.)) go to 10
  mflag=iabs(iflag)
  if ((mflag >= 1)  .and.  (mflag <= 7)) go to 20
!
!     invalid input
   10 iflag=7
  return
!
!     is this the first call
   20 if (mflag == 1) go to 50
!
!     check continuation possibilities
!
  if (t == tout) go to 10
  if (mflag /= 2) go to 25
!
!     iflag = +2 or -2
  if (init == 0) go to 45
  if (kflag == 3) go to 40
  if ((kflag == 4)  .and.  (abserr == 0.)) go to 30
  if ((kflag == 5)  .and.  (relerr <= savre)  .and. &
      (abserr <= savae)) go to 30
  go to 50
!
!     iflag = 3,4,5,6, or 7
   25 if (iflag == 3) go to 40
  if ((iflag == 4) .and. (abserr > 0.)) go to 45
!
!     integration cannot be continued since user did not respond to
!     the instructions pertaining to iflag=4,5,6 or 7
   30 stop
!
!     reset function evaluation counter
   40 nfe=0
  if (mflag == 2) go to 50
!
!     reset flag value from previous call
   45 iflag=jflag
!
!     save input iflag and set continuation flag value for subsequent
!     input checking
   50 jflag=iflag
  kflag=0
!
!     save relerr and abserr for checking input on subsequent calls
  savre=relerr
  savae=abserr
!
!     restrict relative error tolerance to be at least as large as
!     32u+remin to avoid limiting precision difficulties arising from
!     impossible accuracy requests
!
  rer=max ( relerr,32.*u+remin)
!
  u26=26.*u
!
  dt=tout-t
!
  if (mflag == 1) go to 60
  if (init == 0) go to 65
  go to 80
!
!     initialization --
!                       set initialization completion indicator,init
!                       set indicator for too many output points,kop
!                       evaluate initial derivatives
!                       copy initial values and derivatives for the
!                             parallel solution
!                       set counter for function evaluations,nfe
!                       estimate starting stepsize
!
   60 init=0
  kop=0
!
  a=t
  call f(a,y,yp)
  nfe=1
  if (t /= tout) go to 65
  iflag=2
  return
!
!
   65 init=1
  h=abs(dt)
  toln=0.0
  do 70 k=1,neqn
    yg(k)=y(k)
    ygp(k)=yp(k)
    tol=rer*abs(y(k))+abserr
    if (tol <= 0.) go to 70
    toln=tol
    ypk=abs(yp(k))
    if (ypk*h**5 > tol) h=(tol/ypk)**0.2
   70   continue
  if (toln <= 0.) h=0.
  h=max ( h,u26* max ( abs(t),abs(dt)))
!
!     set stepsize for integration in the direction from t to tout
!
   80 h=sign(h,dt)
!
!     test to see if gerk is being severely impacted by too many
!     output points
!
  if (abs(h) > 2.*abs(dt)) kop=kop+1
  if (kop /= 100) go to 85
  kop=0
  iflag=6
  return
!
   85 if (abs(dt) > u26*abs(t)) go to 95
!
!     if too close to output point,extrapolate and return
!
  do 90 k=1,neqn
    yg(k)=yg(k)+dt*ygp(k)
   90   y(k)=y(k)+dt*yp(k)
  a=tout
  call f(a,yg,ygp)
  call f(a,y,yp)
  nfe=nfe+2
  go to 300
!
!     initialize output point indicator
!
   95 output= .false.
!
!     to avoid premature underflow in the error tolerance function,
!     scale the error tolerances
!
  scale=2./rer
  ae=scale*abserr
!
!     step by step integration
!
  100 hfaild= .false.
!
!     set smallest allowable stepsize
!
  hmin=u26*abs(t)
!
!     adjust stepsize if necessary to hit the output point.
!     look ahead two steps to avoid drastic changes in the stepsize
!     and thus lessen the impact of output points on the code.
!
  dt=tout-t
  if (abs(dt) >= 2.*abs(h)) go to 200
  if (abs(dt) > abs(h)) go to 150
!
!     the next successful step will complete the integration to the
!     output point
!
  output= .true.
  h=dt
  go to 200
!
  150 h=0.5*dt
!
!     core integrator for taking a single step
!
!     the tolerances have been scaled to avoid premature underflow in
!     computing the error tolerance function et.
!     to avoid problems with zero crossings,relative error is measured
!     using the average of the magnitudes of the solution at the
!     beginning and end of a step.
!     the error estimate formula has been grouped to control loss of
!     significance.
!     to distinguish the various arguments, h is not permitted
!     to become smaller than 26 units of roundoff in t.
!     practical limits on the change in the stepsize are enforced to
!     smooth the stepsize selection process and to avoid excessive
!     chattering on problems having discontinuities.
!     to prevent unnecessary failures, the code uses 9/10 the stepsize
!     it estimates will succeed.
!     after a step failure, the stepsize is not allowed to increase for
!     the next attempted step. this makes the code more efficient on
!     problems having discontinuities and more effective in general
!     since local extrapolation is being used and the error estimate
!     may be unreliable or unacceptable when a step fails.
!
!     test number of derivative function evaluations.
!     if okay,try to advance the integration from t to t+h
!
  200 if (nfe <= maxnfe) go to 220
!
!     too much work
  iflag=3
  kflag=3
  return
!
!     advance an approximate solution over one step of length h
!
  220 call fehl(f,neqn,yg,t,h,ygp,f1,f2,f3,f4,f5,f1)
  nfe=nfe+5
!
!     compute and test allowable tolerances versus local error estimates
!     and remove scaling of tolerances. note that relative error is
!     measured with respect to the average of the magnitudes of the
!     solution at the beginning and end of the step.
!
  eeoet=0.
  do 250 k=1,neqn
    et=abs(yg(k))+abs(f1(k))+ae
    if (et > 0.) go to 240
!
!       inappropriate error tolerance
    iflag=4
    kflag=4
    return

  240   ee=abs((-2090.0*ygp(k)+(21970.0*f3(k)-15048.0*f4(k)))+ &
                          (22528.0*f2(k)-27360.0*f5(k)))
  250   eeoet=max ( eeoet,ee/et)

  esttol=abs(h)*eeoet*scale/752400.0

  if (esttol <= 1.0E+00 ) go to 260
!
!  unsuccessful step.
!  reduce the stepsize and try again.
!  the decrease is limited to a factor of 1/10.
!
  hfaild= .true.
  output= .false.
  s=0.1
  if (esttol < 59049.) s=0.9/esttol**0.2
  h=s*h
  if (abs(h) > hmin) go to 200
!
!     requested error unattainable at smallest allowable stepsize
  iflag=5
  kflag=5
  return
!
!
!     successful step
!                        store one-step solution yg at t+h
!                        and evaluate derivatives there
!
  260 ts=t
  t=t+h
  do 270 k=1,neqn
  270   yg(k)=f1(k)
  a=t
  call f(a,yg,ygp)
  nfe=nfe+1
!
!                        now advance the y solution over two steps of
!                        length h/2 and evaluate derivatives there
!
  hh=0.5*h
  call fehl(f,neqn,y,ts,hh,yp,f1,f2,f3,f4,f5,y)
  ts=ts+hh
  a=ts
  call f(a,y,yp)
  call fehl(f,neqn,y,ts,hh,yp,f1,f2,f3,f4,f5,y)
  a=t
  call f(a,y,yp)
  nfe=nfe+12
!
!
!                       choose next stepsize
!                       the increase is limited to a factor of 5
!                       if step failure has just occurred, next
!                          stepsize is not allowed to increase
!
  s=5.
  if (esttol > 1.889568e-4) s=0.9/esttol**0.2
  if (hfaild) s=amin1(s,1.)
  h=sign(max ( s*abs(h),hmin),h)
!
!     end of core integrator
!
!     should we take another step
!
  if (output) go to 300
  if (iflag > 0) go to 100
!
!     integration successfully completed
!
!     one-step mode
  iflag=-2
  go to 400
!
!     interval mode
  300 t=tout
  iflag=2
!
  400 continue

  do k=1,neqn
    gerror(k) = ( yg(k) - y(k) ) / 31.0
  end do

  return
end
function glog ( x )
!
!*******************************************************************************
!
!! GLOG evaluates of the natural logarithm of X for X >= 15.
!
!
!  Parameters:
!
!    Input, real X, the argument of the function.
!
!    Output, double precision GLOG, the value of LN(X).
!
  double precision glog
  real x
  double precision z, w(163)
!
  data c1/.286228750476730/, c2/.399999628131494/, &
       c3/.666666666752663/
!
!     w(j) = ln(j + 14) for each j
!
  data w(1) /.270805020110221007d+01/, &
   w(2) /.277258872223978124d+01/, w(3) /.283321334405621608d+01/, &
   w(4) /.289037175789616469d+01/, w(5) /.294443897916644046d+01/, &
   w(6) /.299573227355399099d+01/, w(7) /.304452243772342300d+01/, &
   w(8) /.309104245335831585d+01/, w(9) /.313549421592914969d+01/, &
   w(10)/.317805383034794562d+01/, w(11)/.321887582486820075d+01/, &
   w(12)/.325809653802148205d+01/, w(13)/.329583686600432907d+01/, &
   w(14)/.333220451017520392d+01/, w(15)/.336729582998647403d+01/, &
   w(16)/.340119738166215538d+01/, w(17)/.343398720448514625d+01/, &
   w(18)/.346573590279972655d+01/, w(19)/.349650756146648024d+01/, &
   w(20)/.352636052461616139d+01/, w(21)/.355534806148941368d+01/, &
   w(22)/.358351893845611000d+01/, w(23)/.361091791264422444d+01/, &
   w(24)/.363758615972638577d+01/, w(25)/.366356164612964643d+01/, &
   w(26)/.368887945411393630d+01/, w(27)/.371357206670430780d+01/, &
   w(28)/.373766961828336831d+01/, w(29)/.376120011569356242d+01/, &
   w(30)/.378418963391826116d+01/
  data w(31)/.380666248977031976d+01/, &
   w(32)/.382864139648909500d+01/, w(33)/.385014760171005859d+01/, &
   w(34)/.387120101090789093d+01/, w(35)/.389182029811062661d+01/, &
   w(36)/.391202300542814606d+01/, w(37)/.393182563272432577d+01/, &
   w(38)/.395124371858142735d+01/, w(39)/.397029191355212183d+01/, &
   w(40)/.398898404656427438d+01/, w(41)/.400733318523247092d+01/, &
   w(42)/.402535169073514923d+01/, w(43)/.404305126783455015d+01/, &
   w(44)/.406044301054641934d+01/, w(45)/.407753744390571945d+01/, &
   w(46)/.409434456222210068d+01/, w(47)/.411087386417331125d+01/, &
   w(48)/.412713438504509156d+01/, w(49)/.414313472639153269d+01/, &
   w(50)/.415888308335967186d+01/, w(51)/.417438726989563711d+01/, &
   w(52)/.418965474202642554d+01/, w(53)/.420469261939096606d+01/, &
   w(54)/.421950770517610670d+01/, w(55)/.423410650459725938d+01/, &
   w(56)/.424849524204935899d+01/, w(57)/.426267987704131542d+01/, &
   w(58)/.427666611901605531d+01/, w(59)/.429045944114839113d+01/, &
   w(60)/.430406509320416975d+01/
  data w(61)/.431748811353631044d+01/, &
   w(62)/.433073334028633108d+01/, w(63)/.434380542185368385d+01/, &
   w(64)/.435670882668959174d+01/, w(65)/.436944785246702149d+01/, &
   w(66)/.438202663467388161d+01/, w(67)/.439444915467243877d+01/, &
   w(68)/.440671924726425311d+01/, w(69)/.441884060779659792d+01/, &
   w(70)/.443081679884331362d+01/, w(71)/.444265125649031645d+01/, &
   w(72)/.445434729625350773d+01/, w(73)/.446590811865458372d+01/, &
   w(74)/.447733681447820647d+01/, w(75)/.448863636973213984d+01/, &
   w(76)/.449980967033026507d+01/, w(77)/.451085950651685004d+01/, &
   w(78)/.452178857704904031d+01/, w(79)/.453259949315325594d+01/, &
   w(80)/.454329478227000390d+01/, w(81)/.455387689160054083d+01/, &
   w(82)/.456434819146783624d+01/, w(83)/.457471097850338282d+01/, &
   w(84)/.458496747867057192d+01/, w(85)/.459511985013458993d+01/, &
   w(86)/.460517018598809137d+01/, w(87)/.461512051684125945d+01/, &
   w(88)/.462497281328427108d+01/, w(89)/.463472898822963577d+01/, &
   w(90)/.464439089914137266d+01/
  data w(91) /.465396035015752337d+01/, &
   w(92) /.466343909411206714d+01/, w(93) /.467282883446190617d+01/, &
   w(94) /.468213122712421969d+01/, w(95) /.469134788222914370d+01/, &
   w(96) /.470048036579241623d+01/, w(97) /.470953020131233414d+01/, &
   w(98) /.471849887129509454d+01/, w(99) /.472738781871234057d+01/, &
   w(100)/.473619844839449546d+01/, w(101)/.474493212836325007d+01/, &
   w(102)/.475359019110636465d+01/, w(103)/.476217393479775612d+01/, &
   w(104)/.477068462446566476d+01/, w(105)/.477912349311152939d+01/, &
   w(106)/.478749174278204599d+01/, w(107)/.479579054559674109d+01/, &
   w(108)/.480402104473325656d+01/, w(109)/.481218435537241750d+01/, &
   w(110)/.482028156560503686d+01/, w(111)/.482831373730230112d+01/, &
   w(112)/.483628190695147800d+01/, w(113)/.484418708645859127d+01/, &
   w(114)/.485203026391961717d+01/, w(115)/.485981240436167211d+01/, &
   w(116)/.486753445045558242d+01/, w(117)/.487519732320115154d+01/, &
   w(118)/.488280192258637085d+01/, w(119)/.489034912822175377d+01/, &
   w(120)/.489783979995091137d+01/
  data w(121)/.490527477843842945d+01/, &
   w(122)/.491265488573605201d+01/, w(123)/.491998092582812492d+01/, &
   w(124)/.492725368515720469d+01/, w(125)/.493447393313069176d+01/, &
   w(126)/.494164242260930430d+01/, w(127)/.494875989037816828d+01/, &
   w(128)/.495582705760126073d+01/, w(129)/.496284463025990728d+01/, &
   w(130)/.496981329957600062d+01/, w(131)/.497673374242057440d+01/, &
   w(132)/.498360662170833644d+01/, w(133)/.499043258677873630d+01/, &
   w(134)/.499721227376411506d+01/, w(135)/.500394630594545914d+01/, &
   w(136)/.501063529409625575d+01/, w(137)/.501727983681492433d+01/, &
   w(138)/.502388052084627639d+01/, w(139)/.503043792139243546d+01/, &
   w(140)/.503695260241362916d+01/, w(141)/.504342511691924662d+01/, &
   w(142)/.504985600724953705d+01/, w(143)/.505624580534830806d+01/, &
   w(144)/.506259503302696680d+01/, w(145)/.506890420222023153d+01/, &
   w(146)/.507517381523382692d+01/, w(147)/.508140436498446300d+01/, &
   w(148)/.508759633523238407d+01/, w(149)/.509375020080676233d+01/, &
   w(150)/.509986642782419842d+01/
  data w(151)/.510594547390058061d+01/, &
   w(152)/.511198778835654323d+01/, w(153)/.511799381241675511d+01/, &
   w(154)/.512396397940325892d+01/, w(155)/.512989871492307347d+01/, &
   w(156)/.513579843705026176d+01/, w(157)/.514166355650265984d+01/, &
   w(158)/.514749447681345304d+01/, w(159)/.515329159449777895d+01/, &
   w(160)/.515905529921452903d+01/, w(161)/.516478597392351405d+01/, &
   w(162)/.517048399503815178d+01/, w(163)/.517614973257382914d+01/
!
  if (x >= 178.0) go to 10
  n = x
  t = (x - n)/(x + n)
  t2 = t*t
  z = (((c1*t2 + c2)*t2 + c3)*t2 + 2.0)*t
  glog = w(n - 14) + z
  return
!
   10 glog = alog(x)
  return
end
subroutine gnrtp(degree,alpha,psi,indexs, &
                   newkj,sumsqs,coord,ncrows,npolys, &
                   dimen,npts,f,z,c,psiwid,weight, &
                   alfl,dimp1,maxabs,error)
!
!*******************************************************************************
!
!! GNRTP is a utility routine used by MFIT.
!
!
!     the multinomial fit is generated incrementally, a basis  element
!     at a time.  this subroutine starts the process off by setting up
!     the first basis element, scaling the  data,  finding  the  first
!     coefficient,  and  initializing  the  work array z.  gnrtp  then
!     calls  incdg  if more than one basis element is required.
!
!     this subroutine is called by  mfit .  it is not called by  the
!     user.
!
!     this subroutine calls  scalpm ,  scaldn , and  incdg .
!
!
!     modified by a.h. morris (nswc)
!
  integer degree,dimen,npolys,npts,k,psiwid,alfl,p,sttdeg,onplys
  integer error,dimp1
  integer indexs(4,npolys),newkj(dimen,degree)
  real    psi(npts,psiwid),alpha(alfl),f(npts)
  real    coord(ncrows,dimen),maxabs(dimp1),weight(npts)
  real    z(npts),sumsqs(npolys),c(npolys)
  real    runtot,rntot1
!
!  Set up the scaling.
!
  do k = 1,dimen
     call scalpm(coord(1,k),npts,maxabs(k))
     call scaldn(coord(1,k),npts,maxabs(k))
  end do

  call scalpm(f,npts,maxabs(dimp1))
  call scaldn(f,npts,maxabs(dimp1))
!
!      sumsqs (1) = (1,1)
!     c(1)  = (f,1) / (1,1)
!
  runtot = 0.0
  rntot1 = 0.0
  do p = 1,npts
     psi(p,1) = 1.0
     rntot1 = rntot1 + weight(p)
     runtot = runtot + f(p) * weight(p)
  end do

  sumsqs(1) = rntot1
  c(1) = runtot / rntot1
!
!     z = f - c(1)
!
  do p = 1,npts
    z(p) = f(p) - c(1)
  end do

  if ( npolys == 1 ) return
  sttdeg = 1
  onplys = 1

  call incdg(degree,alpha,psi,indexs,newkj,sumsqs, &
             coord,ncrows,npolys,dimen,npts,f,z,c,psiwid, &
             weight,alfl,onplys,sttdeg,error)
  return
end
subroutine grat1 (a,x,r,p,q,eps)
!
!*******************************************************************************
!
!! GRAT1 evaluates the incomplete gamma ratio functions p(a,x) and q(a,x).
!
!
!     it is assumed that a <= 1.  eps is the tolerance to be used.
!     the input argument r has the value e**(-x)*x**a/gamma(a).
!
  real j, l
!
  if (a*x == 0.0) go to 130
  if (a == 0.5) go to 120
  if (x < 1.1) go to 10
  go to 50
!
!             taylor series for p(a,x)/x**a
!
   10 an = 3.0
  c = x
  sum = x/(a + 3.0)
  tol = 0.1*eps/(a + 1.0)
   11    an = an + 1.0
     c = -c*(x/an)
     t = c/(a + an)
     sum = sum + t
     if (abs(t) > tol) go to 11
  j = a*x*((sum/6.0 - 0.5/(a + 2.0))*x + 1.0/(a + 1.0))
!
  z = a*alog(x)
  h = gam1(a)
  g = 1.0 + h
  if (x < 0.25) go to 20
     if (a < x/2.59) go to 40
     go to 30
   20 if (z > -.13394) go to 40
!
   30 w = exp(z)
  p = w*g*(0.5 + (0.5 - j))
  q = 0.5 + (0.5 - p)
  return
!
   40 l = rexp(z)
  w = 0.5 + (0.5 + l)
  q = (w*j - l)*g - h
  if (q < 0.0) go to 110
  p = 0.5 + (0.5 - q)
  return
!
!              continued fraction expansion
!
   50 a2nm1 = 1.0
  a2n = 1.0
  b2nm1 = x
  b2n = x + (1.0 - a)
  c = 1.0
   51    a2nm1 = x*a2n + c*a2nm1
     b2nm1 = x*b2n + c*b2nm1
     am0 = a2nm1/b2nm1
     c = c + 1.0
     cma = c - a
     a2n = a2nm1 + cma*a2n
     b2n = b2nm1 + cma*b2n
     an0 = a2n/b2n
     if (abs(an0 - am0) >= eps*an0) go to 51
  q = r*an0
  p = 0.5 + (0.5 - q)
  return
!
!                special cases
!
  100 p = 0.0
  q = 1.0
  return

  110 continue

  p = 1.0
  q = 0.0
  return

  120 if (x >= 0.25) go to 121
  p = erf(sqrt(x))
  q = 0.5 + (0.5 - p)
  return
  121 q = erfc1(0,sqrt(x))
  p = 0.5 + (0.5 - q)
  return

  130 if (x <= a) go to 100
  go to 110
end
subroutine gratio ( a, x, ans, qans, ind )
!
!*******************************************************************************
!
!! GRATIO: evaluation of the incomplete gamma ratio functions p(a,x) and q(a,x)
!
!
!
!     it is assumed that a and x are nonnegative, where a and x
!     are not both 0.
!
!     ans and qans are variables. gratio assigns ans the value
!     p(a,x) and qans the value q(a,x). ind may be any integer.
!     if ind = 0 then the user is requesting as much accuracy as
!     possible (up to 14 significant digits). otherwise, if
!     ind = 1 then accuracy is requested to within 1 unit of the
!     6-th significant digit, and if ind /= 0,1 then accuracy
!     is requested to within 1 unit of the 3rd significant digit.
!
!     error return ...
!        ans is assigned the value 2 when a or x is negative,
!     when a*x = 0, or when p(a,x) and q(a,x) are indeterminant.
!     p(a,x) and q(a,x) are computationally indeterminant when
!     x is exceedingly close to a and a is extremely large.
!
!     written by Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  integer max3
  real j, l, acc0(3), big(3), e00(3), x00(3), wk(20)
  real d0(13), d1(12), d2(10), d3(8), d4(6), d5(4), d6(2)
!
  data acc0(1)/5.e-15/, acc0(2)/5.e-7/, acc0(3)/5.e-4/
  data big(1)/20.0/, big(2)/14.0/, big(3)/10.0/
  data e00(1)/.25e-3/, e00(2)/.25e-1/, e00(3)/.14/
  data x00(1)/31.0/, x00(2)/17.0/, x00(3)/9.7/
!
!     alog10 = ln(10)
!     rt2pin = 1/sqrt(2*pi)
!     rtpi   = sqrt(pi)
!
  data alog10/2.30258509299405/
  data rt2pin/0.398942280401433/
  data rtpi  /1.77245385090552/
  data third /0.333333333333333/
!
  data d0(1) / .833333333333333e-01/, d0(2) /-.148148148148148e-01/, &
       d0(3) / .115740740740741e-02/, d0(4) / .352733686067019e-03/, &
       d0(5) /-.178755144032922e-03/, d0(6) / .391926317852244e-04/, &
       d0(7) /-.218544851067999e-05/, d0(8) /-.185406221071516e-05/, &
       d0(9) / .829671134095309e-06/, d0(10)/-.176659527368261e-06/, &
       d0(11)/ .670785354340150e-08/, d0(12)/ .102618097842403e-07/, &
       d0(13)/-.438203601845335e-08/
!
  data d10   /-.185185185185185e-02/, d1(1) /-.347222222222222e-02/, &
       d1(2) / .264550264550265e-02/, d1(3) /-.990226337448560e-03/, &
       d1(4) / .205761316872428e-03/, d1(5) /-.401877572016461e-06/, &
       d1(6) /-.180985503344900e-04/, d1(7) / .764916091608111e-05/, &
       d1(8) /-.161209008945634e-05/, d1(9) / .464712780280743e-08/, &
       d1(10)/ .137863344691572e-06/, d1(11)/-.575254560351770e-07/, &
       d1(12)/ .119516285997781e-07/
!
  data d20   / .413359788359788e-02/, d2(1) /-.268132716049383e-02/, &
       d2(2) / .771604938271605e-03/, d2(3) / .200938786008230e-05/, &
       d2(4) /-.107366532263652e-03/, d2(5) / .529234488291201e-04/, &
       d2(6) /-.127606351886187e-04/, d2(7) / .342357873409614e-07/, &
       d2(8) / .137219573090629e-05/, d2(9) /-.629899213838006e-06/, &
       d2(10)/ .142806142060642e-06/
!
  data d30   / .649434156378601e-03/, d3(1) / .229472093621399e-03/, &
       d3(2) /-.469189494395256e-03/, d3(3) / .267720632062839e-03/, &
       d3(4) /-.756180167188398e-04/, d3(5) /-.239650511386730e-06/, &
       d3(6) / .110826541153473e-04/, d3(7) /-.567495282699160e-05/, &
       d3(8) / .142309007324359e-05/
!
  data d40   /-.861888290916712e-03/, d4(1) / .784039221720067e-03/, &
       d4(2) /-.299072480303190e-03/, d4(3) /-.146384525788434e-05/, &
       d4(4) / .664149821546512e-04/, d4(5) /-.396836504717943e-04/, &
       d4(6) / .113757269706784e-04/
!
  data d50   /-.336798553366358e-03/, d5(1) /-.697281375836586e-04/, &
       d5(2) / .277275324495939e-03/, d5(3) /-.199325705161888e-03/, &
       d5(4) / .679778047793721e-04/
!
  data d60   / .531307936463992e-03/, d6(1) /-.592166437353694e-03/, &
       d6(2) / .270878209671804e-03/
!
  data d70   / .344367606892378e-03/
!
  e = epsilon ( e )
  if (a < 0.0 .or. x  <  0.0) go to 400
  if (a == 0.0 .and. x == 0.0) go to 400
  if (a*x == 0.0) go to 331
!
  iop = ind + 1
  if (iop /= 1 .and. iop /= 2) iop = 3
  acc = max ( acc0(iop),e)
  e0 = e00(iop)
  x0 = x00(iop)
!
!            select the appropriate algorithm
!
  if (a >= 1.0) go to 10
  if (a == 0.5) go to 320
  if (x < 1.1) go to 110
  t1 = a*alog(x) - x
  u = a*exp(t1)
  if (u == 0.0) go to 310
  r = u*(1.0 + gam1(a))
  go to 170
!
   10 if (a >= big(iop)) go to 20
  if (a > x .or. x >= x0) go to 11
     twoa = a + a
     m = int(twoa)
     if (twoa /= real(m)) go to 11
     i = m/2
     if (a == real(i)) go to 140
     go to 150
   11 t1 = a*alog(x) - x
  r = exp(t1)/gamma(a)
  go to 30
!
   20 l = x/a
  if (l == 0.0) go to 300
  s = 0.5 + (0.5 - l)
  z = rlog(l)
  if (z >= 700.0/a) go to 330
  y = a*z
  rta = sqrt(a)
  if (abs(s) <= e0/rta) go to 250
  if (abs(s) <= 0.4) go to 200
!
  t = (1.0/a)**2
  t1 = (((0.75*t - 1.0)*t + 3.5)*t - 105.0)/(a*1260.0)
  t1 = t1 - y
  r = rt2pin*rta*exp(t1)
!
   30 if (r == 0.0) go to 331
  if (x <= max ( a,alog10)) go to 50
  if (x < x0) go to 170
  go to 80
!
!                 taylor series for p/r
!
   50 apn = a + 1.0
  t = x/apn
  wk(1) = t
  do 51 n = 2,20
     apn = apn + 1.0
     t = t*(x/apn)
     if (t <= 1.e-3) go to 60
   51 wk(n) = t
  n = 20
!
   60 sum = t
  tol = 0.5*acc
   61 apn = apn + 1.0
  t = t*(x/apn)
  sum = sum + t
  if (t > tol) go to 61
!
  max3 = n - 1
  do 70 m = 1,max3
     n = n - 1
   70 sum = sum + wk(n)
  ans = (r/a)*(1.0 + sum)
  qans = 0.5 + (0.5 - ans)
  return
!
!                 asymptotic expansion
!
   80 amn = a - 1.0
  t = amn/x
  wk(1) = t
  do 81 n = 2,20
     amn = amn - 1.0
     t = t*(amn/x)
     if (abs(t) <= 1.e-3) go to 90
   81 wk(n) = t
  n = 20
!
   90 sum = t
   91 if (abs(t) <= acc) go to 100
  amn = amn - 1.0
  t = t*(amn/x)
  sum = sum + t
  go to 91
!
  100 max3 = n - 1
  do 101 m = 1,max3
     n = n - 1
  101 sum = sum + wk(n)
  qans = (r/x)*(1.0 + sum)
  ans = 0.5 + (0.5 - qans)
  return
!
!             taylor series for p(a,x)/x**a
!
  110 an = 3.0
  c = x
  sum = x/(a + 3.0)
  tol = 3.0*acc/(a + 1.0)
  111    an = an + 1.0
     c = -c*(x/an)
     t = c/(a + an)
     sum = sum + t
     if (abs(t) > tol) go to 111
  j = a*x*((sum/6.0 - 0.5/(a + 2.0))*x + 1.0/(a + 1.0))
!
  z = a*alog(x)
  h = gam1(a)
  g = 1.0 + h
  if (x < 0.25) go to 120
     if (a < x/2.59) go to 135
     go to 130
  120 if (z > -.13394) go to 135
!
  130 w = exp(z)
  ans = w*g*(0.5 + (0.5 - j))
  qans = 0.5 + (0.5 - ans)
  return
!
  135 l = rexp(z)
  w = 0.5 + (0.5 + l)
  qans = (w*j - l)*g - h
  if (qans < 0.0) go to 310
  ans = 0.5 + (0.5 - qans)
  return
!
!             finite sums for q when a >= 1
!                 and 2*a is an integer
!
  140 sum = exp(-x)
  t = sum
  n = 1
  c = 0.0
  go to 160
!
  150 rtx = sqrt(x)
  sum = erfc1(0,rtx)
  t = exp(-x)/(rtpi*rtx)
  n = 0
  c = -0.5
!
  160 if (n == i) go to 161
     n = n + 1
     c = c + 1.0
     t = (x*t)/c
     sum = sum + t
     go to 160
  161 qans = sum
  ans = 0.5 + (0.5 - qans)
  return
!
!              continued fraction expansion
!
  170 tol = max ( 5.0*e,acc)
  a2nm1 = 1.0
  a2n = 1.0
  b2nm1 = x
  b2n = x + (1.0 - a)
  c = 1.0
  171 a2nm1 = x*a2n + c*a2nm1
  b2nm1 = x*b2n + c*b2nm1
  am0 = a2nm1/b2nm1
  c = c + 1.0
  cma = c - a
  a2n = a2nm1 + cma*a2n
  b2n = b2nm1 + cma*b2n
  an0 = a2n/b2n
  if (abs(an0 - am0) >= tol*an0) go to 171
!
  qans = r*an0
  ans = 0.5 + (0.5 - qans)
  return
!
!                general temme expansion
!
  200 if (abs(s) <= 2.0*e .and. a*e*e > 3.28e-3) go to 400
  c = exp(-y)
  w = 0.5*erfc1(1,sqrt(y))
  u = 1.0/a
  z = sqrt(z + z)
  if (l < 1.0) z = -z
  if (iop - 2) 210,220,230
!
  210 if (abs(s) <= 1.e-3) go to 260
  c0 = ((((((((((((d0(13) * z + d0(12)) * z + d0(11)) * z &
       + d0(10)) * z + d0(9)) * z + d0(8)) * z + d0(7)) * z &
       + d0(6)) * z + d0(5)) * z + d0(4)) * z + d0(3)) * z &
       + d0(2)) * z + d0(1)) * z - third
  c1 = (((((((((((d1(12) * z + d1(11)) * z + d1(10)) * z &
       + d1(9)) * z + d1(8)) * z + d1(7)) * z + d1(6)) * z &
       + d1(5)) * z + d1(4)) * z + d1(3)) * z + d1(2)) * z &
       + d1(1)) * z + d10
  c2 = (((((((((d2(10) * z + d2(9)) * z + d2(8)) * z &
       + d2(7)) * z + d2(6)) * z + d2(5)) * z + d2(4)) * z &
       + d2(3)) * z + d2(2)) * z + d2(1)) * z + d20
  c3 = (((((((d3(8) * z + d3(7)) * z + d3(6)) * z &
       + d3(5)) * z + d3(4)) * z + d3(3)) * z + d3(2)) * z &
       + d3(1)) * z + d30
  c4 = (((((d4(6) * z + d4(5)) * z + d4(4)) * z + d4(3)) * z &
       + d4(2)) * z + d4(1)) * z + d40
  c5 = (((d5(4) * z + d5(3)) * z + d5(2)) * z + d5(1)) * z &
       + d50
  c6 = (d6(2) * z + d6(1)) * z + d60
  t  = ((((((d70*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u &
                   + c1)*u + c0
  go to 240
!
  220 c0 = (((((d0(6) * z + d0(5)) * z + d0(4)) * z + d0(3)) * z &
       + d0(2)) * z + d0(1)) * z - third
  c1 = (((d1(4) * z + d1(3)) * z + d1(2)) * z + d1(1)) * z &
       + d10
  c2 = d2(1) * z + d20
  t  = (c2*u + c1)*u + c0
  go to 240
!
  230 t  = ((d0(3) * z + d0(2)) * z + d0(1)) * z - third
!
  240 if (l < 1.0) go to 241
  qans = c*(w + rt2pin*t/rta)
  ans = 0.5 + (0.5 - qans)
  return
  241 ans = c*(w - rt2pin*t/rta)
  qans = 0.5 + (0.5 - ans)
  return
!
!               temme expansion for l = 1
!
  250 if (a*e*e > 3.28e-3) go to 400
  c = 0.5 + (0.5 - y)
  w = (0.5 - sqrt(y)*(0.5 + (0.5 - y/3.0))/rtpi)/c
  u = 1.0/a
  z = sqrt(z + z)
  if (l < 1.0) z = -z
  if (iop - 2) 260,270,280
!
  260 c0 = ((((((d0(7) * z + d0(6)) * z + d0(5)) * z + d0(4)) * z &
       + d0(3)) * z + d0(2)) * z + d0(1)) * z - third
  c1 = (((((d1(6) * z + d1(5)) * z + d1(4)) * z + d1(3)) * z &
       + d1(2)) * z + d1(1)) * z + d10
  c2 = ((((d2(5) * z + d2(4)) * z + d2(3)) * z + d2(2)) * z &
       + d2(1)) * z + d20
  c3 = (((d3(4) * z + d3(3)) * z + d3(2)) * z + d3(1)) * z &
       + d30
  c4 = (d4(2) * z + d4(1)) * z + d40
  c5 = (d5(2) * z + d5(1)) * z + d50
  c6 = d6(1) * z + d60
  t  = ((((((d70*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u &
                   + c1)*u + c0
  go to 240
!
  270 c0 = (d0(2) * z + d0(1)) * z - third
  c1 = d1(1) * z + d10
  t  = (d20*u + c1)*u + c0
  go to 240
!
  280 t  = d0(1) * z - third
  go to 240
!
!                     special cases
!
  300 ans = 0.0
  qans = 1.0
  return
!
  310 ans = 1.0
  qans = 0.0
  return
!
  320 if (x >= 0.25) go to 321
  ans = erf(sqrt(x))
  qans = 0.5 + (0.5 - ans)
  return
  321 qans = erfc1(0,sqrt(x))
  ans = 0.5 + (0.5 - qans)
  return
!
  330 if (abs(s) <= 2.0*e) go to 400
  331 if (x <= a) go to 300
  go to 310
!
!                     error return
!
  400 ans = 2.0
  return
end
function gsumln ( a, b )
!
!*******************************************************************************
!
!! GSUMLN: evaluation of the function ln(gamma(a + b))
!          for 1 <= a <= 2  and  1 <= b <= 2
!
  real gsumln
!
  x = dble(a) + dble(b) - 2.d0
  if (x > 0.25) go to 10
     gsumln = gamln1(1.0 + x)
     return
   10 if (x > 1.25) go to 20
     gsumln = gamln1(x) + alnrel(x)
     return
   20 gsumln = gamln1(x - 1.0) + alog(x*(1.0 + x))
  return
end
subroutine h12 (mode,lpivot,l1,m,u,iue,up,c,ice,icv,ncv)
!
!*******************************************************************************
!
!! H12 constructs or applies a householder transformation: q = i + u*(u**t)/b
!
!
!     written by c.l. lawson and r.j. hanson.  modified by a.h. morris.
!     from the book solving least squares problems, prentice-hall, 1974.
!
!     mode    = 1 or 2   to select algorithm  h1  or  h2.
!     lpivot is the index of the pivot element.
!     l1,m   if l1 <= m   the transformation will be constructed to
!            zero elements indexed from l1 through m.   if l1 gt. m
!            the subroutine does an identity transformation.
!     u(),iue,up    on entry to h1 u() contains the pivot vector.
!                   iue is the storage increment between elements.
!                                       on exit from h1 u() and up
!                   contain quantities defining the vector u of the
!                   householder transformation.   on entry to h2 u()
!                   and up should contain quantities previously computed
!                   by h1.  these will not be modified by h2.
!     c()    on entry to h1 or h2 c() contains a matrix which will be
!            regarded as a set of vectors to which the householder
!            transformation is to be applied.  on exit c() contains the
!            set of transformed vectors.
!     ice    storage increment between elements of vectors in c().
!     icv    storage increment between vectors in c().
!     ncv    number of vectors in c() to be transformed. if ncv <= 0
!            no operations will be done on c().
!
  dimension u(iue,m), c(*)
  double precision sm,b
!
  if (0 >= lpivot .or. lpivot >= l1 .or. l1 > m) return
  cl = abs(u(1,lpivot))
  if (mode == 2) go to 60
!
!  construct the transformation.
!
      do 10 j = l1,m
   10     cl = max ( abs(u(1,j)),cl)
  if (cl <= 0.0) go to 130
  d = u(1,lpivot)/cl
  sm = d*d
      do 20 j = l1,m
      d = u(1,j)/cl
   20     sm = sm + dble(d*d)
!
  sm1 = sm
  cl = cl*sqrt(sm1)
  if (u(1,lpivot) > 0.0) cl = -cl
  up = u(1,lpivot) - cl
  u(1,lpivot) = cl
  go to 70
!
!  apply the transformation  i+u*(u**t)/b  to c.
!
   60 if (cl) 130,130,70
   70 if (ncv <= 0) return
  b = dble(up)*dble(u(1,lpivot))
!
!                       b  must be nonpositive here.  if b = 0., return.
!
  if (b >= 0.d0) go to 130
  b = 1.d0/b
  i2 = 1 - icv + ice*(lpivot - 1)
  incr = ice*(l1 - lpivot)
      do 120 j = 1,ncv
      i2 = i2 + icv
      i3 = i2 + incr
      i4 = i3
      sm = dble(c(i2))*dble(up)
          do 90 i = l1,m
          sm = sm + dble(c(i3))*dble(u(1,i))
   90         i3 = i3 + ice
      if (sm == 0.d0) go to 120
      sm = sm*b
      c(i2) = c(i2) + sm*dble(up)
          do 110 i = l1,m
          c(i4) = c(i4) + sm*dble(u(1,i))
  110         i4 = i4 + ice
  120     continue
  130 return
end
subroutine hbrd(fcn,n,x,fvec,epsfcn,tol,info,wa,lwa)
!
!*******************************************************************************
!
!! HBRD finds a zero of n nonlinear functions in n variables
!  by a modification of the powell hybrid method. this is done by using the
!     more general nonlinear equation solver hybrd. the user
!     must provide a subroutine which calculates the functions.
!     the jacobian is then calculated by a forward-difference
!     approximation.
!
!     the subroutine statement is
!
!       subroutine hbrd(fcn,n,x,fvec,epsfcn,tol,info,wa,lwa)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(n,x,fvec,iflag)
!         integer n,iflag
!         real x(n),fvec(n)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate the execution of hbrd.
!         in this case set iflag to a negative integer.
!
!       n is a positive integer input variable set to the number
!         of functions and variables.
!
!       x is an array of length n. on input x must contain
!         an initial estimate of the solution vector. on output x
!         contains the final estimate of the solution vector.
!
!       fvec is an output array of length n which contains
!         the functions evaluated at the output x.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       tol is a nonnegative input variable. termination occurs
!         when the algorithm estimates that the relative error
!         between x and the solution is at most tol.
!
!       info is an integer output variable. if the user has
!         terminated execution, info is set to the (negative)
!         value of iflag. see description of fcn. otherwise,
!         info is set as follows.
!
!         info = 0   improper input parameters.
!
!         info = 1   algorithm estimates that the relative error
!                    between x and the solution is at most tol.
!
!         info = 2   number of calls to fcn has reached or exceeded
!                    200*(n+1).
!
!         info = 3   tol is too small. no further improvement in
!                    the approximate solution x is possible.
!
!         info = 4   iteration is not making good progress.
!
!       wa is a work array of length lwa.
!
!       lwa is a positive integer input variable not less than
!         (n*(3*n+13))/2.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!       minpack-supplied ... hybrd
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer n,info,lwa
  real epsfcn,tol
  real x(n),fvec(n),wa(lwa)
  external fcn
!
  integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint
  real factor,one,xtol,zero
  data factor,one,zero /1.0e2,1.0e0,0.0e0/
  info = 0
!
!     check the input parameters for errors.
!
  if (n <= 0 .or. epsfcn < zero .or. tol  <  zero .or. &
     lwa < (n*(3*n + 13))/2) go to 20
!
!     call hybrd.
!
  maxfev = 200*(n + 1)
  xtol = tol
  ml = n - 1
  mu = n - 1
  mode = 2
  do 10 j = 1, n
     wa(j) = one
   10    continue
  nprint = 0
  lr = (n*(n + 1))/2
  index = 6*n + lr
  call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, &
             factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, &
             wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
  if (info == 5) info = 4
   20 continue
  return
end
subroutine hc (ind, m, n, pr, ar, nb, s, iwk, num)
!
!*******************************************************************************
!
!! HC finds one or more hamiltonian circuits in a directed graph
!  of n vertices ( n > 1 ) represented
!  by the integers  1, 2, ..., n  and  m  arcs.
!
! input ...
!
! ind   = 0  on an initial call to hc.
!       = 1  obtain another hamiltonian circuit.
!       = 2  more back tracks are being permitted.
!       = 3  restore the orginal array ar.
! m     = number of arcs.
! n     = number of vertices.
! pr(i) = sum of the out-degrees of vertices  1, ..., i-1
!         (pr(1) = 0 ,  pr(n+1) = m).
! ar    = adjacency list. the elements from  ar(pr(i)+1) to
!         ar(pr(i+1))  are a record containing,in any order,
!         all the vertices  j  such that arc  (i,j)  exists.
!         the graph should not contain arcs starting and
!         ending at the same vertex.
! nb    = upper bound on the number of back tracks to be
!         performed. (nb = -1 if no limit is to be placed
!         on the number of back tracks taken.)
! num   = dimension of the work space iwk. it is assumed that
!         num >= m + 8*n + 20.
!
! output ...
!
! ind   = 1   a hamiltonian circuit was found. to find another
!             circuit, reset nb and recall the routine.
!             the array ar has been modified. if one does not
!             wish to obtain another circuit, set ind = 3 and
!             recall the routine. this will restore ar.
!       = 2   the maximum number of back tracks were performed.
!             to continue, reset nb and recall the routine.
!             the array ar has been modified. if one does not
!             wish to continue, set ind = 3 and recall the
!             routine. this will restore ar.
!       = 4   no circuits were found. the array  ar  has been
!             restored (see the remark below) and the procedure
!             is finished.
!       = -1  (input error) ind < 0  or ind > 3 on input.
!       = -2  (input error) ind was modified. reset ind to its
!              previous output value and rerun the code.
!       = -3  (input error) the input setting ind = 3 can be
!              used only when the previous output value for
!              ind was 1 or 2. if the previous output value
!              for ind was 4, then the array ar has already
!              been restored and there is nothing to be done.
!       = -4  (input error) num < m + 8*n + 20.
!       = -5  (input error) pr(1) /= 0  or  pr(n+1) /= m.
!       = -6  (input error) pr(i) > pr(i+1) for some i.
! nb    = number of back tracks performed.
! s(i)  = i-th  vertex in the hamiltonian circuit found.
!
! work space ... iwk
!
! remark. in ar, the order of the arcs in each record may be
! altered by the routine.
!
!     integer pr(n + 1), ar(m), s(n), iwk(m + 8*n + 20)
!
  integer pr(*), ar(m), s(n), iwk(num)
  integer s0, pc, ac, vr, vc, p, subr, rbus, tor
!
  np1 = n + 1
  if (ind < 0 .or. ind > 3) go to 20
  if (num < m + 8*n + 20) go to 30
  if (pr(1) /= 0 .or. pr(np1) /= m) go to 40
!
  s0 = 20
  pc = s0 + n
  ac = pc + np1
  vr = ac + m
  vc = vr + n
  p  = vc + n
  subr = p + n
  rbus = subr + n
  tor  = rbus + n
!
  call hc1 (ind, m, n, pr, ar, nb, iwk(s0), np1, iwk(pc), &
            iwk(ac), iwk(vr), iwk(vc), iwk(p), iwk(subr), &
            iwk(rbus), iwk(tor), iwk(1))
  if (ind /= 1) return
!
  ii = s0
  do 10 i = 1,n
     s(i) = iwk(ii)
     ii = ii + 1
   10 continue
  return
!
!                   error return
!
   20 ind = -1
  return
   30 ind = -4
  return
   40 ind = -5
  return
end
subroutine hc1 (ind, m, n, pr, ar, nb, s, np1, pc, ac, &
                  vr, vc, p, subr, rbus, tor, iwk)
!
!*******************************************************************************
!
!! HC1 is a utility routine used by hc to find hamilton circuits.
!
!
! meaning of the work arrays ...
!
! pc(i)   = sum of the in-degrees of vertices  1, ..., i-1
!           ( pc(1) = 0 ).
! ac      = adjacency list (backward). the elements from
!           ac(pc(i)+1)  to  ac(pc(i+1))  contain, in any
!           order, all the vertices  j  such that arc  (j,i)
!           exists.
! when an arc is removed from the graph at the  k-th  level
! of the branch-decision tree, the corresponding elements
! ar(q)  and  ac(t)  are set to  - (k*(n+1) + ar(q))  and
! to  - (k*(n+1) + ac(t)) , respectively.
! vr(i)   = current out-degree of vertex i .
! vc(i)   = current in-degree of vertex i .
! subr(i) = - (k*(n+1) + j)  if arc  (i,j)  was implied at
!           the  k-th  level of the branch-decision tree.
!         = 0  otherwise.
! rbus(i) = - j  if arc  (j,i)  is currently implied.
!         = 0  otherwise.
! tor(k)  = q*(m+1) + t  if the arc going from  s(k)  to the
!           root, corresponding to  ar(q)  and to  ac(t),
!           was removed from the graph at the  k-th  level
!           of the branch-decision tree.
!         = 0  otherwise.
! p(i)    = pointer for the forward step. the next arc
!           starting from  i  to be considered in the
!           branch-decision tree is  (i,ar(pr(i)+p(i)).
! iwk     = array for saving the variable information for
!           reuse in subsequent calls to the subroutine hc.
!
! meaning of the main simple variables ...
!
! jr  = root. the hamiltonian circuits are determined as
!       paths starting and ending at  jr .
! k   = current level of the branch-decision tree.
!
  integer pr(np1), pc(np1), ar(m), ac(m), s(n), vr(n), vc(n), p(n), &
          subr(n), rbus(n), tor(n), iwk(19)
!
  nbo = nb
  nb = 0
  mp1 = m + 1
  if (ind /= 0) go to 500
!
! step  0   (initialize).
!
  do 10 i=1,n
    vc(i) = 0
    subr(i) = 0
    rbus(i) = 0
    p(i) = 1
   10 continue
  do 30 i=1,n
    j1 = pr(i) + 1
    j2 = pr(i+1)
    vr(i) = j2 - j1 + 1
    if (vr(i) == 0) go to 440
    if (vr(i) < 0) go to 620
    do 20 j=j1,j2
      ja = ar(j)
      vc(ja) = vc(ja) + 1
   20   continue
   30 continue
  pc(1) = 0
  do 40 i=1,n
    if (vc(i) == 0) go to 440
    pc(i+1) = pc(i) + vc(i)
    vc(i) = 0
   40 continue
  do 60 i=1,n
    j1 = pr(i) + 1
    j2 = pr(i+1)
    do 50 j=j1,j2
      jj = ar(j)
      vc(jj) = vc(jj) + 1
      ja = pc(jj) + vc(jj)
      ac(ja) = i
   50   continue
   60 continue
! select as root  jr  the vertex  i  with maximum  vc(i)
! (break ties by choosing  i  with minimum  vr(i) ).
  maxe = vc(1)
  minu = vr(1)
  jr = 1
  do 100 i=2,n
    if (vc(i)-maxe) 100, 70, 80
   70   if (vr(i) >= minu) go to 100
    go to 90
   80   maxe = vc(i)
   90   minu = vr(i)
    jr = i
  100 continue
  k1 = -np1
  k = 1
  s(1) = jr
!
! step   1   (search for implied arcs).
!
  110 do 120 j=1,n
    if (vr(j)==1) go to 130
    if (vc(j)==1) go to 170
  120 continue
! no further arc can be implied.
  go to 220
! arc  (j,jl)  is implied because  vr(j) = 1 .
  130 l1 = pr(j) + 1
  l2 = pr(j+1)
  do 140 l=l1,l2
    if (ar(l) > 0) go to 150
  140 continue
  150 jl = ar(l)
! find the starting vertex  it1  and the ending vertex  it2
! of the largest path of implied arcs containing  (j,jl) .
  call ipath(j, jl, subr, rbus, ar, pr, s, n, np, it1, it2, k, jr, &
   m, np1)
  if (np==0) go to 160
  if (np==(-1)) go to 340
! subroutine ipath found a hamiltonian circuit.
  k = k + 1
  go to 320
  160 subr(j) = k1 - jl
  rbus(jl) = j
! remove from the graph all arcs terminating at  jl .
  call iupd(j, jl, l, ac, ar, pc, pr, vc, vr, k1, n, m, np1)
  if (j==0) go to 340
  go to 210
! arc  (jl,j)  is implied because  vc(j) = 1 .
  170 l1 = pc(j) + 1
  l2 = pc(j+1)
  do 180 l=l1,l2
    if (ac(l) > 0) go to 190
  180 continue
  190 jl = ac(l)
! find the starting vertex  it1  and the ending vertex  it2
! of the largest path of implied arcs containing  (jl,j) .
  call ipath(jl, j, subr, rbus, ar, pr, s, n, np, it1, it2, k, jr, &
   m, np1)
  if (np==0) go to 200
  if (np==(-1)) go to 340
! subroutine ipath found a hamiltonian circuit.
  i = s(k)
  k = k + 1
  go to 320
  200 subr(jl) = k1 - j
  rbus(j) = jl
! remove from the graph all arcs emanating from  jl .
  call iupd(j, jl, l, ar, ac, pr, pc, vr, vc, k1, n, m, np1)
  if (j==0) go to 340
! if arc  (it2,it1)  is in the graph, remove it.
  210 call rarc(it2, it1, ar, ac, pr, pc, vr, vc, k1, jj, ll, n, m, np1)
  if (jj==(-1)) go to 340
  go to 110
!
! step   2   (add implied arcs to s).
!
  220 i = s(k)
  if (subr(i)==0) go to 230
  jsubr = -subr(i) + (subr(i)/np1)*np1
  if (jsubr==jr) go to 340
  k = k + 1
  s(k) = jsubr
  if (k/=n) go to 220
  if (subr(jsubr) < 0) go to 320
  go to 340
!
! step   3   (branch).
!
  230 l1 = pr(i) + p(i)
  l2 = pr(i+1)
  if (l1 > l2) go to 340
! find the next arc  (i,jl)  to be added to  s .
  dens = n**3
  j1 = 0
  j2 = 0
  do 310 j=l1,l2
    jl = ar(j)
    if (jl < 0) go to 310
    if (vr(jl) > 0) go to 260
    if (subr(jl)==0) go to 310
    if (jl==jr) go to 310
    iend = jl
  240   iend = -subr(iend) + (subr(iend)/np1)*np1
    if (subr(iend)/=0) go to 240
    if (vc(jl) < vr(iend)) go to 250
    score = vr(iend)*n + vc(jl)
    go to 280
  250   score = vc(jl)*n + vr(iend)
    go to 280
  260   if (vc(jl) < vr(jl)) go to 270
    score = vr(jl)*n + vc(jl)
    go to 280
  270   score = vc(jl)*n + vr(jl)
  280   if (dens <= score) go to 290
    dens = score
    ipi = j
  290   if (j1==0) go to 300
    if (j2==0) j2 = j
    go to 310
  300   j1 = j
  310 continue
  if (j1==0) go to 340
  jl = ar(ipi)
  ar(ipi) = ar(j1)
  ar(j1) = jl
  if (j2==0) j2 = pr(i+1) + 1
  p(i) = j2 - pr(i)
  k = k + 1
  s(k) = jl
  k1 = -k*np1
! remove from the graph all arcs emanating from  i .
  call fupd(ar, ac, pr, pc, vr, vc, i, k1, n, m, np1)
! remove from the graph all arcs terminating at jl .
  call fupd(ac, ar, pc, pr, vc, vr, jl, k1, n, m, np1)
  tor(k) = 0
! if arc  (jl,jr)  is in the graph, remove it.
  call rarc(jl, jr, ar, ac, pr, pc, vr, vc, k1, jj, ll, n, m, np1)
  if (jj==0) go to 110
  if (jj==(-1)) go to 340
  tor(k) = jj*mp1 + ll
  go to 110
!
! step   4   (hamiltonian circuit found).
!
  320 ind = 1
  k = k - 1
  go to 460
!
! step   5   (backtrack).
!
  340 if (k <= 1) go to 430
  ja = s(k)
  p(ja) = 1
  ja = s(k-1)
  if (subr(ja)==0) go to 350
! backtracking for an implied arc.
  k = k - 1
  go to 340
  350 if (nb == nbo) go to 450
  nb = nb + 1
  k1 = -k*np1
  k2 = -(k+1)*np1
  i = s(k-1)
! backtracking for the arcs implied at level  k .
  iff = 0
  do 360 j=1,n
    if (subr(j) > k1) go to 360
    if (subr(j) < k2) go to 360
    ja = k1 - subr(j)
    rbus(ja) = 0
    subr(j) = 0
    iff = 1
  360 continue
  if (iff==1) go to 370
! no arc was implied at level  k .
  call bupd(ar, ac, pr, pc, vr, vc, i, k1, k2, n, m, np1)
  call bupd(ac, ar, pc, pr, vc, vr, s(k), k1, k2, n, m, np1)
  if (tor(k)==0) go to 420
  j1 = tor(k)/mp1
  j2 = tor(k) - j1*mp1
  ar(j1) = jr
  ja = s(k)
  vr(ja) = vr(ja) + 1
  ac(j2) = s(k)
  vc(jr) = vc(jr) + 1
  go to 420
! at least one arc was implied at level  k .
  370 do 410 j=1,n
    l1 = pr(j) + 1
    l2 = pr(j+1)
    do 400 l=l1,l2
      jl = ar(l)
      if (jl > k1) go to 400
      if (jl < k2) go to 400
      jl = k1 - jl
      ar(l) = jl
      vr(j) = vr(j) + 1
      ll1 = pc(jl) + 1
      ll2 = pc(jl+1)
      do 380 ll=ll1,ll2
        if (k1-ac(ll)==j) go to 390
  380     continue
  390     ac(ll) = j
      vc(jl) = vc(jl) + 1
  400   continue
  410 continue
  420 k = k - 1
  go to 230
!
! restore the original vector  ar
!
  430 do 431 j = 1,m
    if (ar(j) > 0) go to 431
    ar(j) = -ar(j) + (ar(j)/np1)*np1
  431 continue
!
! the algorithm is finished
!
  440 ind = 4
  iwk(13) = ind
  return
!
! the maximum number of back tracks were performed
!
  450 ind = 2
!
! save the variable information
!
  460 iwk(1) = i
  iwk(2) = it1
  iwk(3) = it2
  iwk(4) = j
  iwk(5) = jj
  iwk(6) = jl
  iwk(7) = jr
  iwk(8) = k
  iwk(9) = k1
  iwk(10) = k2
  iwk(11) = l
  iwk(12) = ll
  iwk(13) = ind
  return
!
! check ind when ind = 1, 2, or 3
!
  500 if (ind /= 3) go to 510
     if (iwk(13) == 1 .or. iwk(13) == 2) go to 430
     go to 610
  510 if (ind /= iwk(13)) go to 600
!
! restore the variable information
!
  i = iwk(1)
  it1 = iwk(2)
  it2 = iwk(3)
  j  = iwk(4)
  jj = iwk(5)
  jl = iwk(6)
  jr = iwk(7)
  k  = iwk(8)
  k1 = iwk(9)
  k2 = iwk(10)
  l  = iwk(11)
  ll = iwk(12)
!
  if (ind == 1) go to 340
  go to 350
!
! error return
!
  600 ind = -2
  return
  610 ind = -3
  return
  620 ind = -6
  return
end
subroutine hfti (a,mda,m,n,b,mdb,nb,tau,k,rnorm,h,g,ip)
!
!*****************************************************************************80
!
!! HFTI solves a linear least squares problem
!  or a set of linear least squares problems having same matrix but different
!     right-side vectors.  the problem data consists of an m by n matrix
!     a, an m by nb matrix b, and an absolute tolerance parameter tau
!     whose usage is described below.  the nb column vectors of b
!     represent right-side vectors for nb distinct linear least squares
!     problems.
!
!     this set of problems can also be written as the matrix least
!     squares problem
!
!                       ax = b,
!
!     where x is the n by nb solution matrix.
!
!     note that if b is the m by m identity matrix, then x will be the
!     pseudo-inverse of a.
!
!     this subroutine first transforms the augmented matrix (a b) to a
!     matrix (r c) using premultiplying householder transformations with
!     column interchanges.  all subdiagonal elements in the matrix r are
!     zero and its diagonal elements satisfy
!
!                       abs(r(i,i)) >= abs(r(i+1,i+1)),
!
!                       i = 1,...,l-1, where
!
!                       l = min(m,n).
!
!     the subroutine sets k to be the number of diagonal elements
!     of r that exceed tau in magnitude. then the solution of minimum
!     euclidean length is computed using the first k rows of (r c).
!
!     to be specific we suggest that the user consider an easily
!     computable matrix norm, such as, the maximum of all column sums of
!     magnitudes.
!
!     now if the relative uncertainty of b is eps, (norm of uncertainty/
!     norm of b), it is suggested that tau be set approximately equal to
!     eps*(norm of a).
!
!     written by c.l. lawson and r.j. hanson.
!     from the book solving least squares problems, prentice-hall, 1974.
!     for algorithmic details see algorithm hfti in chapter 14.
!
!     the entire set of parameters for hfti are
!
!     input..
!
!     a(*,*),mda,m,n    the array a(*,*) initially contains the m by n
!                       matrix a of the least squares problem ax = b.
!                       the first dimensioning parameter of the array
!                       a(*,*) is mda, which must satisfy mda >= m
!                       either m >= n or m < n is permitted.  there
!                       is no restriction on the rank of a.  the
!                       condition mda < m is considered an error.
!
!     b(*),mdb,nb       if nb = 0 the subroutine will perform the
!                       orthogonal decomposition but will make no
!                       references to the array b(*).  if nb > 0
!                       the array b(*) must initially contain the m by
!                       nb matrix b of the least squares problem ax =
!                       b.  if nb >= 2 the array b(*) must be doubly
!                       subscripted with first dimensioning parameter
!                       mdb >= max(m,n).  if nb = 1 the array b(*) may
!                       be either doubly or singly subscripted.  in
!                       the latter case the value of mdb is arbitrary
!                       but it should be set to some valid integer
!                       value such as mdb = m.
!
!                       the condition of nb > 1.and.mdb <  max(m,n)
!                       is considered an error.
!
!     tau               absolute tolerance parameter provided by user
!                       for pseudorank determination.
!
!     h(*),g(*),ip(*)   arrays of working space used by hfti.
!
!     output..
!
!     a(*,*)            the contents of the array a(*,*) will be
!                       modified by the subroutine.  these contents
!                       are not generally required by the user.
!
!     b(*)              on return the array b(*) will contain the n by
!                       nb solution matrix x.
!
!     k                 set by the subroutine to indicate the
!                       pseudorank of a.
!
!     rnorm(*)          on return, rnorm(j) will contain the euclidean
!                       norm of the residual vector for the problem
!                       defined by the j-th column vector of the array
!                       b(*,*) for j = 1,...,nb.
!
!     h(*),g(*)         on return these arrays respectively contain
!                       elements of the pre- and post-multiplying
!                       householder transformations used to compute
!                       the minimum euclidean length solution.
!
!     ip(*)             array in which the subroutine records indices
!                       describing the permutation of column vectors.
!                       the contents of arrays h(*),g(*) and ip(*)
!                       are not generally required by the user.
!
  dimension a(mda,n),b(mdb,*),rnorm(*),h(n),g(n)
  integer ip(n)
  double precision sm
!
  data factor /1.e-3/
!
  k = 0
  ldiag = min (m,n)
  if (ldiag <= 0) go to 270
      do 80 j = 1,ldiag
      if (j == 1) go to 20
!
!     update squared column lengths and find lmax
!
      lmax = j
          do 10 l = j,n
          h(l) = h(l) - a(j-1,l)**2
          if (h(l) > h(lmax)) lmax = l
   10         continue
      z = hmax + factor*h(lmax)
      if (z > hmax) go to 50
!
!     compute squared column lengths and find lmax
!    ..
   20     lmax=j
          do 40 l = j,n
          h(l) = 0.0
              do 30 i = j,m
   30             h(l) = h(l) + a(i,l)**2
          if (h(l) > h(lmax)) lmax = l
   40         continue
      hmax = h(lmax)
!    ..
!     lmax has been determined
!
!     do column interchanges if needed.
!    ..
   50     ip(j) = lmax
      if (ip(j) == j) go to 70
          do 60 i = 1,m
          tmp = a(i,j)
          a(i,j) = a(i,lmax)
   60         a(i,lmax) = tmp
      h(lmax) = h(j)
!
!     compute the j-th transformation and apply it to a and b.
!    ..
   70     call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)
   80     call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
!
!     determine the pseudorank, k, using the tolerance, tau.
!    ..
      do 90 j = 1,ldiag
      if (abs(a(j,j)) <= tau) go to 100
   90     continue
  k = ldiag
  go to 110
  100 k = j - 1
  110 kp1 = k + 1
!
!     compute the norms of the residual vectors.
!
  if (nb <= 0) go to 140
      do 130 jb = 1,nb
      tmp = 0.0
      if (kp1 > m) go to 130
          do 120 i = kp1,m
  120         tmp = tmp + b(i,jb)**2
  130     rnorm(jb) = sqrt(tmp)
  140 continue
!                                           special for pseudorank = 0
  if (k > 0) go to 160
  if (nb <= 0) go to 270
      do 151 jb = 1,nb
          do 150 i = 1,n
  150         b(i,jb) = 0.0
  151     continue
  go to 270
!
!     if the pseudorank is less than n compute householder
!     decomposition of first k rows.
!    ..
  160 if (k == n) go to 180
      do 170 ii = 1,k
      i = kp1 - ii
  170     call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
!
!
  if (nb <= 0) go to 270
      do 260 jb = 1,nb
!
!     solve the k by k triangular system.
!    ..
          do 210 l = 1,k
          sm = 0.d0
          i = kp1 - l
          if (i == k) go to 200
          ip1 = i + 1
              do 190 j = ip1,k
  190             sm = sm + dble(a(i,j))*dble(b(j,jb))
  200         sm1 = dble(b(i,jb)) - sm
  210         b(i,jb) = sm1/a(i,i)
!
!     complete computation of solution vector.
!    ..
      if (k == n) go to 240
          do 220 j = kp1,n
  220         b(j,jb) = 0.0
          do 230 i = 1,k
  230         call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
!
!      re-order the solution vector to compensate for the
!      column interchanges.
!    ..
  240         do 250 jj = 1,ldiag
          j = ldiag + 1 - jj
          if (ip(j) == j) go to 250
          l = ip(j)
          tmp = b(l,jb)
          b(l,jb) = b(j,jb)
          b(j,jb) = tmp
  250         continue
  260     continue
!
!     the solution vectors, x, are now
!     in the first  n  rows of the array b(,).
!
  270 return
end
subroutine hfti2(a,mda,m,n,b,mdb,nb,d,tau,k,rnorm,h,g,ip,ierr)
!
!*******************************************************************************
!
!! HFTI2 solves a linear least squares problem
!  or a set of linear least squares problems having same matrix but different
!     right-side vectors.  the problem data consists of an m by n matrix
!     a, an m by nb matrix b, and an absolute tolerance parameter tau
!     whose usage is described below.  the nb column vectors of b
!     represent right-side vectors for nb distinct linear least squares
!     problems.
!
!     this set of problems can also be written as the matrix least
!     squares problem
!
!                       ax = b,
!
!     where x is the n by nb solution matrix.
!
!     note that if b is the m by m identity matrix, then x will be the
!     pseudo-inverse of a.
!
!     this subroutine first transforms the augmented matrix (a b) to a
!     matrix (r c) using premultiplying householder transformations with
!     column interchanges.  all subdiagonal elements in the matrix r are
!     zero and its diagonal elements satisfy
!
!                       abs(r(i,i)) >= abs(r(i+1,i+1)),
!
!                       i = 1,...,l-1, where
!
!                       l = min(m,n).
!
!     the array d will contain the diagonal elements r(1,1),...,r(l,l).
!     the subroutine sets k to be the number of diagonal elements that
!     exceed tau in magnitude.  then the solution of minimum euclidean
!     length is computed using the first k rows of (r c).
!
!     to be specific we suggest that the user consider an easily
!     computable matrix norm, such as, the maximum of all column sums of
!     magnitudes.
!
!     now if the relative uncertainty of b is eps, (norm of uncertainty/
!     norm of b), it is suggested that tau be set approximately equal to
!     eps*(norm of a).
!
!     written by c.l. lawson and r.j. hanson. modified by a.h. morris.
!     from the book solving least squares problems, prentice-hall, 1974.
!     for algorithmic details see algorithm hfti in chapter 14.
!
!     the entire set of parameters for hfti2 are
!
!     input..
!
!     a(*,*),mda,m,n    the array a(*,*) initially contains the m by n
!                       matrix a of the least squares problem ax = b.
!                       the first dimensioning parameter of the array
!                       a(*,*) is mda, which must satisfy mda >= m
!                       either m >= n or m < n is permitted.  there
!                       is no restriction on the rank of a.  the
!                       condition mda < m is considered an error.
!
!     b(*),mdb,nb       if nb = 0 the subroutine will perform the
!                       orthogonal decomposition but will make no
!                       references to the array b(*).  if nb > 0
!                       the array b(*) must initially contain the m by
!                       nb matrix b of the least squares problem ax =
!                       b.  if nb >= 2 the array b(*) must be doubly
!                       subscripted with first dimensioning parameter
!                       mdb >= max(m,n).  if nb = 1 the array b(*) may
!                       be either doubly or singly subscripted.  in
!                       the latter case the value of mdb is arbitrary
!                       but it should be set to some valid integer
!                       value such as mdb = m.
!
!                       the condition of nb > 1.and.mdb <  max(m,n)
!                       is considered an error.
!
!     tau               absolute tolerance parameter provided by user
!                       for pseudorank determination.
!
!     h(*),g(*),ip(*)   arrays of working space used by hfti2.
!
!     output..
!
!     a(*,*)            the contents of the array a(*,*) will be
!                       modified by the subroutine.  these contents
!                       are not generally required by the user.
!
!     b(*)              on return the array b(*) will contain the n by
!                       nb solution matrix x.
!
!     d(*)              the array of diagonal elements of the
!                       triangular matrix r
!
!     k                 set by the subroutine to indicate the
!                       pseudorank of a.
!
!     rnorm(*)          on return, rnorm(j) will contain the euclidean
!                       norm of the residual vector for the problem
!                       defined by the j-th column vector of the array
!                       b(*,*) for j = 1,...,nb.
!
!     h(*),g(*)         on return these arrays respectively contain
!                       elements of the pre- and post-multiplying
!                       householder transformations used to compute
!                       the minimum euclidean length solution.
!
!     ip(*)             array in which the subroutine records indices
!                       describing the permutation of column vectors.
!                       the contents of arrays h(*),g(*) and ip(*)
!                       are not generally required by the user.
!
!     ierr              error indicator. if no input errors are
!                       detected then ierr is set to 0. otherwise
!                          ierr = 1  if mda < m
!                          ierr = 2  if nb > 1 and mdb < max(m,n)
!                       these errors are fatal.
!
  dimension a(mda,n),b(mdb,*),d(*),rnorm(*),h(n),g(n)
  integer ip(n)
  double precision sm
!
  data factor /1.e-3/
!
  k = 0
  ldiag = min (m,n)
  if (ldiag <= 0) go to 270
  if (m > mda) go to 300
  if (nb > 1 .and. max (m,n)  >  mdb) go to 310
!
      do 80 j = 1,ldiag
      if (j == 1) go to 20
!
!     update squared column lengths and find lmax
!    ..
      lmax = j
          do 10 l = j,n
          h(l) = h(l) - a(j-1,l)**2
          if (h(l) > h(lmax)) lmax = l
   10         continue
      z = hmax + factor*h(lmax)
      if (z > hmax) go to 50
!
!     compute squared column lengths and find lmax
!    ..
   20     lmax = j
          do 40 l = j,n
          h(l) = 0.0
              do 30 i = j,m
   30             h(l) = h(l) + a(i,l)**2
          if (h(l) > h(lmax)) lmax = l
   40         continue
      hmax = h(lmax)
!    ..
!     lmax has been determined
!
!     do column interchanges if needed.
!    ..
   50     ip(j) = lmax
      if (ip(j) == j) go to 70
          do 60 i = 1,m
          tmp = a(i,j)
          a(i,j) = a(i,lmax)
   60         a(i,lmax) = tmp
      h(lmax) = h(j)
!
!     compute the j-th transformation and apply it to a and b.
!    ..
   70     call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)
   80     call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
!
!     determine the pseudorank, k, using the tolerance, tau.
!     also store the diagonal elements in the array d.
!    ..
      do 90 j = 1,ldiag
      if (abs(a(j,j)) <= tau) go to 100
   90     d(j) = a(j,j)
      k = ldiag
      kp1 = k + 1
      go to 110
!
  100     k = j - 1
      kp1 = j
      do 105 j = kp1,ldiag
  105     d(j) = a(j,j)
!
!     compute the norms of the residual vectors.
!
  110 if (nb <= 0) go to 140
      do 130 jb = 1,nb
      tmp = 0.0
      if (kp1 > m) go to 130
          do 120 i = kp1,m
  120         tmp = tmp + b(i,jb)**2
  130     rnorm(jb) = sqrt(tmp)
  140 continue
!                                           special for pseudorank = 0
  if (k > 0) go to 160
  if (nb <= 0) go to 270
      do 151 jb = 1,nb
          do 150 i = 1,n
  150         b(i,jb) = 0.0
  151     continue
  go to 270
!
!     if the pseudorank is less than n compute householder
!     decomposition of first k rows.
!    ..
  160 if (k == n) go to 180
      do 170 ii = 1,k
      i = kp1 - ii
  170     call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
!
!
  if (nb <= 0) go to 270
      do 260 jb = 1,nb
!
!     solve the k by k triangular system.
!    ..
          do 210 l = 1,k
          sm = 0.d0
          i = kp1 - l
          if (i == k) go to 200
          ip1 = i + 1
              do 190 j = ip1,k
  190             sm = sm + dble(a(i,j))*dble(b(j,jb))
  200         sm1 = dble(b(i,jb)) - sm
  210         b(i,jb)=sm1/a(i,i)
!
!     complete computation of solution vector.
!    ..
      if (k == n) go to 240
          do 220 j = kp1,n
  220         b(j,jb) = 0.0
          do 230 i = 1,k
  230         call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
!
!      re-order the solution vector to compensate for the
!      column interchanges.
!    ..
  240         do 250 jj = 1,ldiag
          j = ldiag + 1 - jj
          if (ip(j) == j) go to 250
          l = ip(j)
          tmp = b(l,jb)
          b(l,jb) = b(j,jb)
          b(j,jb) = tmp
  250         continue
  260     continue
!    ..
!     the solution vectors, x, are now
!     in the first  n  rows of the array b(,).
!
  270 ierr = 0
  return
!
!     error return
!
  300 ierr = 1
  return
  310 ierr = 2
  return
end
subroutine hqr(nm,n,low,igh,h,wr,wi,ierr)
!
!*******************************************************************************
!
!! HQR finds the eigenvalues of a real upper hessenberg matrix by the qr method.
!
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        h contains the upper hessenberg matrix.  information about
!          the transformations used in the reduction to hessenberg
!          form by  elmhes  or  orthes, if performed, is stored
!          in the remaining triangle under the hessenberg matrix.
!
!     on output-
!
!        h has been destroyed.  therefore, it must be saved
!          before calling  hqr  if subsequent calculation and
!          back transformation of eigenvectors is to be performed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
  integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,its,low,mp2,enm2,ierr
  real h(nm,n),wr(n),wi(n)
  real p,q,r,s,t,w,x,y,zz,norm,machep
!     real sqrt,abs
!     integer min0
  logical notlas
!
  machep = epsilon ( machep )
  ierr = 0
  norm = 0.0
  k = 1
!  store roots isolated by balanc
!                and compute matrix norm.
  do 50 i = 1, n
!
     do 40 j = k, n
   40    norm = norm + abs(h(i,j))
!
     k = i
     if (i >= low .and. i <= igh) go to 50
     wr(i) = h(i,i)
     wi(i) = 0.0
   50 continue
!
  en = igh
  t = 0.0
!     search for next eigenvalues.
   60 if (en < low) go to 1001
  its = 0
  na = en - 1
  enm2 = na - 1
!     look for single small sub-diagonal element
!                for l=en step -1 until low do
   70 do 80 ll = low, en
     l = en + low - ll
     if (l == low) go to 100
     s = abs(h(l-1,l-1)) + abs(h(l,l))
     if (s == 0.0) s = norm
     if (abs(h(l,l-1)) <= machep * s) go to 100
   80 continue
!     form shift.
  100 x = h(en,en)
  if (l == en) go to 270
  y = h(na,na)
  w = h(en,na) * h(na,en)
  if (l == na) go to 280
  if (its == 30) go to 1000
  if (its /= 10 .and. its /= 20) go to 130
!     form exceptional shift.
  t = t + x
!
  do 120 i = low, en
  120 h(i,i) = h(i,i) - x
!
  s = abs(h(en,na)) + abs(h(na,enm2))
  x = 0.75 * s
  y = x
  w = -0.4375 * s * s
  130 its = its + 1
!     look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do
  do 140 mm = l, enm2
     m = enm2 + l - mm
     zz = h(m,m)
     r = x - zz
     s = y - zz
     p = (r * s - w) / h(m+1,m) + h(m,m+1)
     q = h(m+1,m+1) - zz - r - s
     r = h(m+2,m+1)
     s = abs(p) + abs(q) + abs(r)
     p = p / s
     q = q / s
     r = r / s
     if (m == l) go to 150
     if (abs(h(m,m-1)) * (abs(q) + abs(r)) <= machep * abs(p) &
      * (abs(h(m-1,m-1)) + abs(zz) + abs(h(m+1,m+1)))) go to 150
  140 continue
!
  150 mp2 = m + 2
!
  do 160 i = mp2, en
     h(i,i-2) = 0.0
     if (i == mp2) go to 160
     h(i,i-3) = 0.0
  160 continue
!     double qr step involving rows l to en and
!                columns m to en.
  do 260 k = m, na
     notlas = k /= na
     if (k == m) go to 170
     p = h(k,k-1)
     q = h(k+1,k-1)
     r = 0.0
     if (notlas) r = h(k+2,k-1)
     x = abs(p) + abs(q) + abs(r)
     if (x == 0.0) go to 260
     p = p / x
     q = q / x
     r = r / x
  170    s = sqrt(p*p + q*q + r*r)
     if (p < 0.0) s = -s
     if (k == m) go to 180
     h(k,k-1) = -s * x
     go to 190
  180    if (l /= m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
     x = p / s
     y = q / s
     zz = r / s
     q = q / p
     r = r / p
!     row modification.
     do 210 j = k, en
        p = h(k,j) + q * h(k+1,j)
        if (.not. notlas) go to 200
        p = p + r * h(k+2,j)
        h(k+2,j) = h(k+2,j) - p * zz
  200       h(k+1,j) = h(k+1,j) - p * y
        h(k,j) = h(k,j) - p * x
  210    continue
!
     j = min (en,k+3)
!     column modification.
     do 230 i = l, j
        p = x * h(i,k) + y * h(i,k+1)
        if (.not. notlas) go to 220
        p = p + zz * h(i,k+2)
        h(i,k+2) = h(i,k+2) - p * r
  220       h(i,k+1) = h(i,k+1) - p * q
        h(i,k) = h(i,k) - p
  230    continue
!
  260 continue
!
  go to 70
!     one root found
  270 wr(en) = x + t
  wi(en) = 0.0
  en = na
  go to 60
!     two roots found.
  280 p = (y - x) / 2.0
  q = p * p + w
  zz = sqrt(abs(q))
  x = x + t
  if (q < 0.0) go to 320
!     real pair
  if (p < 0.0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.0) wr(en) = x - w / zz
  wi(na) = 0.0
  wi(en) = 0.0
  go to 330
!     complex pair
  320 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  330 en = enm2
  go to 60
!     set error -- no convergence to an
!                eigenvalue after 30 iterations
 1000 ierr = en
 1001 return
end
subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr)
!
!*******************************************************************************
!
!! HQR2 finds the eigenvalues and eigenvectors of a real upper hessenberg matrix
!  by the qr method.  the eigenvectors of real general matrix can also be found
!     if  elmhes  and  eltran  or  orthes  and  ortran  have
!     been used to reduce this general matrix to hessenberg form
!     and to accumulate the similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        h contains the upper hessenberg matrix,
!
!        z contains the transformation matrix produced by  eltran
!          after the reduction by  elmhes, or by  ortran  after the
!          reduction by  orthes, if performed.  if the eigenvectors
!          of the hessenberg matrix are desired, z must contain the
!          identity matrix.
!
!     on output-
!
!        h has been destroyed,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n,
!
!        z contains the real and imaginary parts of the eigenvectors.
!          if the i-th eigenvalue is real, the i-th column of z
!          contains its eigenvector.  if the i-th eigenvalue is complex
!          with positive imaginary part, the i-th and (i+1)-th
!          columns of z contain the real and imaginary parts of its
!          eigenvector.  the eigenvectors are unnormalized.  if an
!          error exit is made, none of the eigenvectors has been found,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     arithmetic is real except for the replacement of the algol
!     procedure cdiv by complex division.
!
  integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, &
          igh,its,low,mp2,enm2,ierr
  real h(nm,n),wr(n),wi(n),z(nm,n)
  real p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,machep
!     real sqrt,abs
!     integer min0
  logical notlas
  complex z3
!     complex cmplx
!     real real,aimag
!
  machep = epsilon ( machep )
  ierr = 0
  norm = 0.0
  k = 1
!     store roots isolated by balanc
!                and compute matrix norm
  do 50 i = 1, n
!
     do 40 j = k, n
   40    norm = norm + abs(h(i,j))
!
     k = i
     if (i >= low .and. i <= igh) go to 50
     wr(i) = h(i,i)
     wi(i) = 0.0
   50 continue
!
  en = igh
  t = 0.0
!     search for next eigenvalues
   60 if (en < low) go to 340
  its = 0
  na = en - 1
  enm2 = na - 1
!     look for single small sub-diagonal element
!                for l=en step -1 until low do --
   70 do 80 ll = low, en
     l = en + low - ll
     if (l == low) go to 100
     s = abs(h(l-1,l-1)) + abs(h(l,l))
     if (s == 0.0) s = norm
     if (abs(h(l,l-1)) <= machep * s) go to 100
   80 continue
!     form shift
  100 x = h(en,en)
  if (l == en) go to 270
  y = h(na,na)
  w = h(en,na) * h(na,en)
  if (l == na) go to 280
  if (its == 30) go to 1000
  if (its /= 10 .and. its /= 20) go to 130
!     form exceptional shift
  t = t + x
!
  do 120 i = low, en
  120 h(i,i) = h(i,i) - x
!
  s = abs(h(en,na)) + abs(h(na,enm2))
  x = 0.75 * s
  y = x
  w = -0.4375 * s * s
  130 its = its + 1
!     look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do --
  do 140 mm = l, enm2
     m = enm2 + l - mm
     zz = h(m,m)
     r = x - zz
     s = y - zz
     p = (r * s - w) / h(m+1,m) + h(m,m+1)
     q = h(m+1,m+1) - zz - r - s
     r = h(m+2,m+1)
     s = abs(p) + abs(q) + abs(r)
     p = p / s
     q = q / s
     r = r / s
     if (m == l) go to 150
     if (abs(h(m,m-1)) * (abs(q) + abs(r)) <= machep * abs(p) &
      * (abs(h(m-1,m-1)) + abs(zz) + abs(h(m+1,m+1)))) go to 150
  140 continue
!
  150 mp2 = m + 2
!
  do 160 i = mp2, en
     h(i,i-2) = 0.0
     if (i == mp2) go to 160
     h(i,i-3) = 0.0
  160 continue
!     double qr step involving rows l to en and
!                columns m to en
  do 260 k = m, na
     notlas = k /= na
     if (k == m) go to 170
     p = h(k,k-1)
     q = h(k+1,k-1)
     r = 0.0
     if (notlas) r = h(k+2,k-1)
     x = abs(p) + abs(q) + abs(r)
     if (x == 0.0) go to 260
     p = p / x
     q = q / x
     r = r / x
  170    s = sqrt(p*p + q*q + r*r)
     if (p < 0.0) s = -s
     if (k == m) go to 180
     h(k,k-1) = -s * x
     go to 190
  180    if (l /= m) h(k,k-1) = -h(k,k-1)
  190    p = p + s
     x = p / s
     y = q / s
     zz = r / s
     q = q / p
     r = r / p
!     row modification
     do 210 j = k, n
        p = h(k,j) + q * h(k+1,j)
        if (.not. notlas) go to 200
        p = p + r * h(k+2,j)
        h(k+2,j) = h(k+2,j) - p * zz
  200       h(k+1,j) = h(k+1,j) - p * y
        h(k,j) = h(k,j) - p * x
  210    continue
!
     j = min (en,k+3)
!     column modification
     do 230 i = 1, j
        p = x * h(i,k) + y * h(i,k+1)
        if (.not. notlas) go to 220
        p = p + zz * h(i,k+2)
        h(i,k+2) = h(i,k+2) - p * r
  220       h(i,k+1) = h(i,k+1) - p * q
        h(i,k) = h(i,k) - p
  230    continue
!     accumulate transformations
     do 250 i = low, igh
        p = x * z(i,k) + y * z(i,k+1)
        if (.not. notlas) go to 240
        p = p + zz * z(i,k+2)
        z(i,k+2) = z(i,k+2) - p * r
  240       z(i,k+1) = z(i,k+1) - p * q
        z(i,k) = z(i,k) - p
  250    continue
!
  260 continue
!
  go to 70
!     one root found
  270 h(en,en) = x + t
  wr(en) = h(en,en)
  wi(en) = 0.0
  en = na
  go to 60
!     two roots found
  280 p = (y - x) / 2.0
  q = p * p + w
  zz = sqrt(abs(q))
  h(en,en) = x + t
  x = h(en,en)
  h(na,na) = y + t
  if (q < 0.0) go to 320
!     real pair
  if (p < 0.0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.0) wr(en) = x - w / zz
  wi(na) = 0.0
  wi(en) = 0.0
  x = h(en,na)
  s = abs(x) + abs(zz)
  p = x / s
  q = zz / s
  r = sqrt(p*p+q*q)
  p = p / r
  q = q / r
!     row modification
  do 290 j = na, n
     zz = h(na,j)
     h(na,j) = q * zz + p * h(en,j)
     h(en,j) = q * h(en,j) - p * zz
  290 continue
!     column modification
  do 300 i = 1, en
     zz = h(i,na)
     h(i,na) = q * zz + p * h(i,en)
     h(i,en) = q * h(i,en) - p * zz
  300 continue
!     accumulate transformations
  do 310 i = low, igh
     zz = z(i,na)
     z(i,na) = q * zz + p * z(i,en)
     z(i,en) = q * z(i,en) - p * zz
  310 continue
!
  go to 330
!     complex pair
  320 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  330 en = enm2
  go to 60
!     all roots found.  backsubstitute to find
!                vectors of upper triangular form
  340 if (norm == 0.0) go to 1001
!     for en=n step -1 until 1 do --
  do 800 nn = 1, n
     en = n + 1 - nn
     p = wr(en)
     q = wi(en)
     na = en - 1
     if (q) 710, 600, 800
!     real vector
  600    m = en
     h(en,en) = 1.0
     if (na == 0) go to 800
!     for i=en-1 step -1 until 1 do --
     do 700 ii = 1, na
        i = en - ii
        w = h(i,i) - p
        r = h(i,en)
        if (m > na) go to 620
!
        do 610 j = m, na
  610       r = r + h(i,j) * h(j,en)
!
  620       if (wi(i) >= 0.0) go to 630
        zz = w
        s = r
        go to 700
  630       m = i
        if (wi(i) /= 0.0) go to 640
        t = w
        if (w == 0.0) t = machep * norm
        h(i,en) = -r / t
        go to 700
!     solve real equations
  640       x = h(i,i+1)
        y = h(i+1,i)
        q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i)
        t = (x * s - zz * r) / q
        h(i,en) = t
        if (abs(x) <= abs(zz)) go to 650
        h(i+1,en) = (-r - w * t) / x
        go to 700
  650       h(i+1,en) = (-s - y * t) / zz
  700    continue
!     end real vector
     go to 800
!     complex vector
  710    m = na
!     last vector component chosen imaginary so that
!                eigenvector matrix is triangular
     if (abs(h(en,na)) <= abs(h(na,en))) go to 720
     h(na,na) = q / h(en,na)
     h(na,en) = -(h(en,en) - p) / h(en,na)
     go to 730
  720    z3 = cmplx(0.0,-h(na,en)) / cmplx(h(na,na)-p,q)
     h(na,na) = real(z3)
     h(na,en) = aimag(z3)
  730    h(en,na) = 0.0
     h(en,en) = 1.0
     enm2 = na - 1
     if (enm2 == 0) go to 800
!     for i=en-2 step -1 until 1 do --
     do 790 ii = 1, enm2
        i = na - ii
        w = h(i,i) - p
        ra = 0.0
        sa = h(i,en)
!
        do 760 j = m, na
           ra = ra + h(i,j) * h(j,na)
           sa = sa + h(i,j) * h(j,en)
  760       continue
!
        if (wi(i) >= 0.0) go to 770
        zz = w
        r = ra
        s = sa
        go to 790
  770       m = i
        if (wi(i) /= 0.0) go to 780
        z3 = cmplx(-ra,-sa) / cmplx(w,q)
        h(i,na) = real(z3)
        h(i,en) = aimag(z3)
        go to 790
!     solve complex equations
  780       x = h(i,i+1)
        y = h(i+1,i)
        vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q
        vi = (wr(i) - p) * 2.0 * q
        if (vr == 0.0 .and. vi == 0.0) vr = machep * norm &
         * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz))
        z3 = cmplx(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra) / cmplx(vr,vi)
        h(i,na) = real(z3)
        h(i,en) = aimag(z3)
        if (abs(x) <= abs(zz) + abs(q)) go to 785
        h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x
        h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x
        go to 790
  785       z3 = cmplx(-r-y*h(i,na),-s-y*h(i,en)) / cmplx(zz,q)
        h(i+1,na) = real(z3)
        h(i+1,en) = aimag(z3)
  790    continue
!     end complex vector
  800 continue
!     end back substitution.
!                vectors of isolated roots
  do 840 i = 1, n
     if (i >= low .and. i <= igh) go to 840
!
     do 820 j = i, n
  820    z(i,j) = h(i,j)
!
  840 continue
!     multiply by transformation matrix to give
!                vectors of original full matrix.
!                for j=n step -1 until low do --
  do 880 jj = low, n
     j = n + low - jj
     m = min (j,igh)
!
     do 880 i = low, igh
        zz = 0.0
!
        do 860 k = low, m
  860       zz = zz + z(i,k) * h(k,j)
!
        z(i,j) = zz
  880 continue
!
  go to 1001
!     set error -- no convergence to an
!                eigenvalue after 30 iterations
 1000 ierr = en
 1001 return
end
subroutine hstart(f,neq,a,b,y,yprime,etol,morder,small,big, &
                                      spy,pv,yp,sf,rpar,ipar,h)
!
!*******************************************************************************
!
!! HSTART computes a starting step size for solving initial value problems
!  in ordinary differential equations.
!
!
!  abstract
!
!     subroutine hstart computes a starting step size to be used by an
!     initial value method in solving ordinary differential equations.
!     it is based on an estimate of the local lipschitz constant for the
!     differential equation   (lower bound on a norm of the jacobian) ,
!     a bound on the differential equation  (first derivative) , and
!     a bound on the partial derivative of the equation with respect to
!     the independent variable.
!     (all approximated near the initial point a)
!
!     subroutine hstart uses a function subprogram vnorm for computing
!     a vector norm. the maximum norm is presently utilized though it
!     can easily be replaced by any other vector norm. it is presumed
!     that any replacement norm routine would be carefully coded to
!     prevent unnecessary underflows or overflows from occurring, and
!     also, would not alter the vector or number of components.
!
!
!  on input you must provide the following
!
!      f -- this is a subroutine of the form
!                               f(x,u,uprime,rpar,ipar)
!             which defines the system of first order differential
!             equations to be solved. for the given values of x and the
!             vector  u(*)=(u(1),u(2),...,u(neq)) , the subroutine must
!             evaluate the neq components of the system of differential
!             equations  du/dx=f(x,u)  and store the derivatives in the
!             array uprime(*), that is,  uprime(i) = * du(i)/dx *  for
!             equations i=1,...,neq.
!
!             subroutine f must not alter x or u(*). you must declare
!             the name f in an external statement in your program that
!             calls hstart. you must dimension u and uprime in f.
!
!             rpar and ipar are real and integer parameter arrays which
!             you can use for communication between your program and
!             subroutine f. they are not used or altered by hstart. if
!             you do not need rpar or ipar, ignore these parameters by
!             treating them as dummy arguments. if you do choose to use
!             them, dimension them in your program and in f as arrays
!             of appropriate length.
!
!      neq -- this is the number of (first order) differential equations
!             to be integrated.
!
!      a -- this is the initial point of integration.
!
!      b -- this is a value of the independent variable used to define
!             the direction of integration. a reasonable choice is to
!             set  b  to the first point at which a solution is desired.
!             you can also use  b, if necessary, to restrict the length
!             of the first integration step because the algorithm will
!             not compute a starting step length which is bigger than
!             abs(b-a), unless  b  has been chosen too close to  a.
!             (it is presumed that hstart has been called with  b
!             different from  a  on the machine being used. also see the
!             discussion about the parameter  small.)
!
!      y(*) -- this is the vector of initial values of the neq solution
!             components at the initial point  a.
!
!      yprime(*) -- this is the vector of derivatives of the neq
!             solution components at the initial point  a.
!             (defined by the differential equations in subroutine f)
!
!      etol -- this is the vector of error tolerances corresponding to
!             the neq solution components. it is assumed that all
!             elements are positive. following the first integration
!             step, the tolerances are expected to be used by the
!             integrator in an error test which roughly requires that
!                        abs(local error)  <=  etol
!             for each vector component.
!
!      morder -- this is the order of the formula which will be used by
!             the initial value method for taking the first integration
!             step.
!
!      small -- this is a small positive machine dependent constant
!             which is used for protecting against computations with
!             numbers which are too small relative to the precision of
!             floating point arithmetic.  small  should be set to
!             (approximately) the smallest positive real number such
!             that  (1.+small) > 1.  on the machine being used. the
!             quantity  small**(3/8)  is used in computing increments of
!             variables for approximating derivatives by differences.
!             also the algorithm will not compute a starting step length
!             which is smaller than  100*small*abs(a).
!
!      big -- this is a large positive machine dependent constant which
!             is used for preventing machine overflows. a reasonable
!             choice is to set big to (approximately) the square root of
!             the largest real number which can be held in the machine.
!
!      spy(*),pv(*),yp(*),sf(*) -- these are real work arrays of length
!             neq which provide the routine with needed storage space.
!
!      rpar,ipar -- these are parameter arrays, of real and integer
!             type, respectively, which can be used for communication
!             between your program and the f subroutine. they are not
!             used or altered by hstart.
!
!
!  on output  (after the return from hstart),
!
!      h -- is an appropriate starting step size to be attempted by the
!             differential equation method.
!
!           all parameters in the call list remain unchanged except for
!           the working arrays spy(*),pv(*),yp(*), and sf(*).
!
!
!
!  routines called  vnorm
!
  dimension y(neq),yprime(neq),etol(neq), &
            spy(neq),pv(neq),yp(neq),sf(neq),rpar(*),ipar(*)
  external f
!
  dx=b-a
  absdx=abs(dx)
  relper=small**0.375
!
!     compute an approximate bound (dfdxb) on the partial
!     derivative of the equation with respect to the
!     independent variable. protect against an overflow.
!     also compute a bound (fbnd) on the first derivative locally.
!
  da=sign(max ( amin1(relper*abs(a),absdx),100.*small*abs(a)),dx)
  if (da == 0.) da=relper*dx
  call f(a+da,y,sf,rpar,ipar)
  do 10 j=1,neq
   10   yp(j)=sf(j)-yprime(j)
  delf=vnorm(yp,neq)
  dfdxb=big
  if (delf < big*abs(da)) dfdxb=delf/abs(da)
  fbnd=vnorm(sf,neq)
!
!     compute an estimate (dfdub) of the local lipschitz constant for
!     the system of differential equations. this also represents an
!     estimate of the norm of the jacobian locally.
!     three iterations (two when neq=1) are used to estimate the
!     lipschitz constant by numerical differences. the first
!     perturbation vector is based on the initial derivatives and
!     direction of integration. the second perturbation vector is
!     formed using another evaluation of the differential equation.
!     the third perturbation vector is formed using perturbations based
!     only on the initial values. components that are zero are always
!     changed to non-zero values (except on the first iteration). when
!     information is available, care is taken to ensure that components
!     of the perturbation vector have signs which are consistent with
!     the slopes of local solution curves.
!     also choose the largest bound (fbnd) for the first derivative.
!
!                       perturbation vector size is held constant for
!                       all iterations. compute this change from the
!                               size of the vector of initial values.
  dely=relper*vnorm(y,neq)
  if (dely == 0.) dely=relper
  dely=sign(dely,dx)
  delf=vnorm(yprime,neq)
  fbnd=max ( fbnd,delf)
  if (delf == 0.) go to 30
!                       use initial derivatives for first perturbation
  do 20 j=1,neq
    spy(j)=yprime(j)
   20   yp(j)=yprime(j)
  go to 50
!                       cannot have a null perturbation vector
   30 do 40 j=1,neq
    spy(j)=0.
   40   yp(j)=1.
  delf=vnorm(yp,neq)
!
   50 dfdub=0.
  lk=min (neq+1,3)
  do 140 k=1,lk
!                       define perturbed vector of initial values
    do 60 j=1,neq
   60     pv(j)=y(j)+dely*(yp(j)/delf)
    if (k == 2) go to 80
!                       evaluate derivatives associated with perturbed
!                       vector  and  compute corresponding differences
    call f(a,pv,yp,rpar,ipar)
    do 70 j=1,neq
   70     pv(j)=yp(j)-yprime(j)
    go to 100
!                       use a shifted value of the independent variable
!                                             in computing one estimate
   80   call f(a+da,pv,yp,rpar,ipar)
    do 90 j=1,neq
   90     pv(j)=yp(j)-sf(j)
!                       choose largest bounds on the first derivative
!                                      and a local lipschitz constant
  100   fbnd=max ( fbnd,vnorm(yp,neq))
    delf=vnorm(pv,neq)
    if (delf >= big*abs(dely)) go to 150
    dfdub=max ( dfdub,delf/abs(dely))
    if (k == lk) go to 160
!                       choose next perturbation vector
    if (delf == 0.) delf=1.
    do 130 j=1,neq
      if (k == 2) go to 110
      dy=abs(pv(j))
      if (dy == 0.) dy=delf
      go to 120
  110     dy=y(j)
      if (dy == 0.) dy=dely/relper
  120     if (spy(j) == 0.) spy(j)=yp(j)
      if (spy(j) /= 0.) dy=sign(dy,spy(j))
  130     yp(j)=dy
  140   delf=vnorm(yp,neq)
!
!                       protect against an overflow
  150 dfdub=big
!
!     compute a bound (ydpb) on the norm of the second derivative
!
  160 ydpb=dfdxb+dfdub*fbnd
!
!     define the tolerance parameter upon which the starting step size
!     is to be based.  a value in the middle of the error tolerance
!     range is selected.
!
  tolmin=big
  tolsum=0.
  do 170 k=1,neq
    tolexp=alog10(etol(k))
    tolmin=amin1(tolmin,tolexp)
 170    tolsum=tolsum+tolexp
  tolp=10.**(0.5*(tolsum/real(neq)+tolmin)/float(morder+1))
!
!     compute a starting step size based on the above first and second
!     derivative information
!
!                       restrict the step length to be not bigger than
!                       abs(b-a).   (unless  b  is too close to  a)
  h=absdx
!
  if (ydpb /= 0.  .or.  fbnd /= 0.) go to 180
!
!                       both first derivative term (fbnd) and second
!                                    derivative term (ydpb) are zero
  if (tolp < 1.) h=absdx*tolp
  go to 200
!
  180 if (ydpb /= 0.) go to 190
!
!                       only second derivative term (ydpb) is zero
  if (tolp < fbnd*absdx) h=tolp/fbnd
  go to 200
!
!                       second derivative term (ydpb) is non-zero
  190 srydpb=sqrt(0.5*ydpb)
  if (tolp < srydpb*absdx) h=tolp/srydpb
!
!                       further restrict the step length to be not
!                                                 bigger than  1/dfdub
  200 if (h*dfdub > 1.) h=1./dfdub
!
!                       finally, restrict the step length to be not
!                       smaller than  100*small*abs(a).  however, if
!                       a=0. and the computed h underflowed to zero,
!                       the algorithm returns  small*abs(b)  for the
!                                                       step length.
  h=max ( h,100.*small*abs(a))
  if (h == 0.) h=small*abs(b)
!
!                       now set direction of integration
  h=sign(h,dx)

  return
end
subroutine htrp (n,x,y,a,t,ierr)
!
!*******************************************************************************
!
!! HTRP: hermite interpolation
!
  dimension x(n),y(n),a(n),t(n)
!
  if (n <= 0) go to 30
  ierr = 0
  a(1) = y(1)
  if (n==1) return
  f = 1.0
  r = 0.0
  iend = 0
  ibeg = 1
!
  do 22 k=2,n
  if (x(k)-x(k-1)) 10,20,10
!
   10 f = 1.0
  r = 0.0
  iend = k-1
  ibeg = k
  t(1) = y(k)
  do 11 i=1,iend
  diff = x(i)-x(k)
  if (diff) 11,31,11
   11 t(i+1) = (a(i)-t(i))/diff
  go to 22
!
   20 r = r+1.0
  f = f*r
  t(1) = y(k)/f
  if (iend==0) go to 22
  do 21 i=1,iend
   21 t(i+1) = (t(i+1)-t(i))/(x(i)-x(k))
   22 a(k) = t(ibeg)
  return
!
   30 ierr = 1
  return
   31 ierr = 2
  t(1) = i
  t(2) = k
  return
end
subroutine hull (x, y, m, bx, by, k, vx, vy, n )
!
!*******************************************************************************
!
!! HULL computes the convex hull of a finite planar set
!
!
!  Parameters:
!
!    Input, real X(M), Y(M), the coordinates of a set of points.
!
!    Input, integer M, the number of points.
!
  integer m
!
  real bx(*)
  real by(*)
  logical ibeg
  real vx(*)
  real vy(*)
  real x(m)
  real y(m)
!
  eps = epsilon ( eps )
  mp1 = m + 1
  onep = 1.0 + 4.0*eps
!
!                       reorder x and y
!
  call rrsort (y, x, m)
  ymin = y(1)
  ymax = y(m)
  if (ymin == ymax) go to 500

  l = 1
10    continue

  l = l + 1
  if ( y(l) == ymin ) go to 10

  lmin = l
  l = l - 1
  call rrsort (x, y, l)
  x1 = x(1)
!
  i = m
   20    i = i - 1
     if (y(i) == ymax) go to 20
  lmax = i
  i = i + 1
  call rrsort (x(i), y(i), m - lmax)
  xm = x(m)
!
!                      find xmin and xmax
!
  xmin = x1
  xmax = x(l)
  do 31 i = lmin,m
     if (x(i) > xmin) go to 30
        xmin = x(i)
        go to 31
   30    if (x(i) > xmax) xmax = x(i)
   31 continue
!
!                   going along the ymin axis
!
  k = l
  do i = 1,l
     bx(i) = x(i)
     by(i) = y(i)
  end do

  n = 1
  vx(1) = x(1)
  vy(1) = y(1)
  if (l == 1) go to 100
  n = 2
  vx(2) = x(l)
  vy(2) = y(l)
!
!           going from the ymin axis to the xmax axis
!
  100 h = xmax - bx(k)
  if (h == 0.0) go to 150
  k0 = k
  ibeg = .true.
!
  110 continue
     l = l + 1
     if (l > lmax) l = m
     h = x(l) - bx(k)
     if (h <= 0.0) go to 110
     dx = x(l) - bx(k0)
     dy = y(l) - by(k0)
     if (ibeg) go to 120
     r = (dx0/dx)*dy
     if (r > onep*dy0) go to 130
     if (dy0 > onep*r) go to 120
     if (dy0 == 0.0 .and. dy > 0.0) go to 140
        k = k + 1
        go to 121
  120    ibeg = .false.
     dx0 = dx
     dy0 = dy
     k = k0 + 1
  121    bx(k) = x(l)
     by(k) = y(l)
     lsav = l
  130 h = xmax - x(l)
  if (h > 0.0) go to 110
!
  140 l = lsav
  n = n + 1
  vx(n) = bx(k)
  vy(n) = by(k)
  go to 100
!
!                   going along the xmax axis
!
  150 if (l == m) go to 250
  ksav = k
  i = l
  151    if (i == lmax) go to 160
     i = i + 1
     if (x(i) /= xmax) go to 151
     l = i
     k = k + 1
     bx(k) = x(i)
     by(k) = y(i)
     go to 151
!
  160 xmax = x(l)
  h = xmax - xm
  if (h <= 0.0) go to 170
  if (l /= lmax) go to 200
     if (k == ksav) go to 170
     n = n + 1
     vx(n) = bx(k)
     vy(n) = by(k)
!
  170 l = m
  k = k + 1
  bx(k) = xm
  by(k) = y(m)
  n = n + 1
  vx(n) = xm
  vy(n) = y(m)
  go to 250
!
!           going from the ymax axis to the xmax axis
!        (here we are traversing the boundary clockwise)
!
  200 j = mp1
  nn = mp1
  bx(mp1) = xm
  vx(mp1) = xm
  by(mp1) = y(m)
  vy(mp1) = y(m)
  i = lmax + 1
  201 j0 = j
  ibeg = .true.
!
  210 continue
     i = i - 1
     h = x(i) - bx(j)
     if (h <= 0.0) go to 210
     dx = x(i) - bx(j0)
     dy = abs(y(i) - by(j0))
     if (ibeg) go to 220
     r = (dx0/dx)*dy
     if (r > onep*dy0) go to 230
     if (dy0 > onep*r) go to 220
     if (dy0 == 0.0 .and. dy > 0.0) go to 235
        j = j - 1
        go to 221
  220    ibeg = .false.
     dx0 = dx
     dy0 = dy
     j = j0 - 1
  221    bx(j) = x(i)
     by(j) = y(i)
     isav = i
  230 h = xmax - x(i)
  if (h > 0.0) go to 210
!
  235 i = isav
  nn = nn - 1
  vx(nn) = bx(j)
  vy(nn) = by(j)
  h = xmax - bx(j)
  if (h > 0.0) go to 201
!
!          update bx,by and vx,vy so that the boundary
!           is again being traversed counterclockwise
!
  if (i == l .and. k == ksav) nn = nn + 1
  do ii = nn,mp1
     n = n + 1
     vx(n) = vx(ii)
     vy(n) = vy(ii)
  end do

  if (i == l) j = j + 1
  do ii = j,mp1
     k = k + 1
     bx(k) = bx(ii)
     by(k) = by(ii)
  end do
  l = m
!
!                   going along the ymax axis
!
  250 lbeg = lmax + 1
  if (lbeg == m) go to 260
  mm1 = m - 1
  do 251 i = lbeg,mm1
     l = l - 1
     k = k + 1
     bx(k) = x(l)
     by(k) = y(l)
  251 continue
  n = n + 1
  vx(n) = bx(k)
  vy(n) = by(k)
!
  260 h = xmax - bx(k)
  if (h > 0.0) go to 300
  h = bx(k) - xmin
  if (h > 0.0) go to 301
  go to 370
!
!           going from the ymax axis to the xmin axis
!
  300 h = bx(k) - xmin
  if (h == 0.0) go to 350
  301 k0 = k
  ibeg = .true.
!
  310 continue
     l = l - 1
     if (l < lmin) l = 1
     h = x(l) - bx(k)
     if (h >= 0.0) go to 310
     dx = abs(x(l) - bx(k0))
     dy = abs(y(l) - by(k0))
     if (ibeg) go to 320
     r = (dx0/dx)*dy
     if (r > onep*dy0) go to 330
     if (dy0 > onep*r) go to 320
     if (dy0 == 0.0 .and. dy > 0.0) go to 340
        k = k + 1
        go to 321
  320    ibeg = .false.
     dx0 = dx
     dy0 = dy
     k = k0 + 1
  321    bx(k) = x(l)
     by(k) = y(l)
     lsav = l
  330 h = x(l) - xmin
  if (h > 0.0) go to 310
!
  340 l = lsav
  n = n + 1
  vx(n) = bx(k)
  vy(n) = by(k)
  go to 300
!
!                   going along the xmin axis
!
  350 if (l == 1) return
  ksav = k
  i = l
  351    if (i == lmin) go to 360
     i = i - 1
     if (x(i) /= xmin) go to 351
     l = i
     k = k + 1
     bx(k) = x(i)
     by(k) = y(i)
     go to 351
!
  360 xmin = x(l)
  h = x1 - xmin
  if (h <= 0.0) go to 370
  if (l /= lmin) go to 400
     if (k == ksav) go to 370
     n = n + 1
     vx(n) = bx(k)
     vy(n) = by(k)
!
  370 k = k + 1
  bx(k) = x1
  by(k) = y(1)
  n = n + 1
  vx(n) = x1
  vy(n) = y(1)
  return
!
!           going from the ymin axis to the xmin axis
!        (here we are traversing the boundary clockwise)
!
  400 j = mp1
  nn = mp1
  bx(mp1) = x1
  vx(mp1) = x1
  by(mp1) = y(1)
  vy(mp1) = y(1)
  i = lmin - 1
  401 j0 = j
  ibeg = .true.
!
  410 continue
     i = i + 1
     h = x(i) - bx(j)
     if (h >= 0.0) go to 410
     dx = abs(x(i) - bx(j0))
     dy = y(i) - by(j0)
     if (ibeg) go to 420
     r = (dx0/dx)*dy
     if (r > onep*dy0) go to 430
     if (dy0 > onep*r) go to 420
     if (dy0 == 0.0 .and. dy > 0.0) go to 435
        j = j - 1
        go to 421
  420    ibeg = .false.
     dx0 = dx
     dy0 = dy
     j = j0 - 1
  421    bx(j) = x(i)
     by(j) = y(i)
     isav = i
  430 h = x(i) - xmin
  if (h > 0.0) go to 410
!
  435 i = isav
  nn = nn - 1
  vx(nn) = bx(j)
  vy(nn) = by(j)
  h = bx(j) - xmin
  if (h > 0.0) go to 401
!
!          update bx,by and vx,vy so that the boundary
!           is again being traversed counterclockwise
!
  if (nn == n) return
  if (i == l .and. k == ksav) nn = nn + 1
  do 440 ii = nn,mp1
     n = n + 1
     vx(n) = vx(ii)
     vy(n) = vy(ii)
  440 continue
!
  if (j == k) return
  if (i == l) j = j + 1
  do ii = j,mp1
     k = k + 1
     bx(k) = bx(ii)
     by(k) = by(ii)
  end do
  return
!
!                     case when ymin = ymax
!
  500 call rrsort (x, y, m)
  do 510 i = 1,m
     bx(i) = x(i)
     by(i) = y(i)
  510 continue
  k = mp1
  bx(k) = bx(1)
  by(k) = by(1)
!
  n = 3
  vx(1) = x(1)
  vx(2) = x(m)
  vx(3) = x(1)
  vy(1) = y(1)
  vy(2) = y(m)
  vy(3) = y(1)

  return
end
subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, &
                   mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, &
                   qtf,wa1,wa2,wa3,wa4)
!
!*******************************************************************************
!
!! HYBRD find a zero of n nonlinear functions in n variables
!  by a modification of the powell hybrid method. the user must provide a
!     subroutine which calculates the functions. the jacobian is
!     then calculated by a forward-difference approximation.
!
!     the subroutine statement is
!
!       subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,
!                        diag,mode,factor,nprint,info,nfev,fjac,
!                        ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(n,x,fvec,iflag)
!         integer n,iflag
!         real x(n),fvec(n)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of hybrd.
!         in this case set iflag to a negative integer.
!
!       n is a positive integer input variable set to the number
!         of functions and variables.
!
!       x is an array of length n. on input x must contain
!         an initial estimate of the solution vector. on output x
!         contains the final estimate of the solution vector.
!
!       fvec is an output array of length n which contains
!         the functions evaluated at the output x.
!
!       xtol is a nonnegative input variable. termination
!         occurs when the relative error between two consecutive
!         iterates is at most xtol.
!
!       maxfev is a positive integer input variable. termination
!         occurs when the number of calls to fcn is at least maxfev
!         by the end of an iteration.
!
!       ml is a nonnegative integer input variable which specifies
!         the number of subdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         ml to at least n - 1.
!
!       mu is a nonnegative integer input variable which specifies
!         the number of superdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         mu to at least n - 1.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       diag is an array of length n. if mode = 1 (see
!         below), diag is internally set. if mode = 2, diag
!         must contain positive entries that serve as
!         multiplicative scale factors for the variables.
!
!       mode is an integer input variable. if mode = 1, the
!         variables will be scaled internally. if mode = 2,
!         the scaling is specified by the input diag. other
!         values of mode are equivalent to mode = 1.
!
!       factor is a positive input variable used in determining the
!         initial step bound. this bound is set to the product of
!         factor and the euclidean norm of diag*x if nonzero, or else
!         to factor itself. in most cases factor should lie in the
!         interval (.1,100.). 100. is a generally recommended value.
!
!       nprint is an integer input variable that enables controlled
!         printing of iterates if it is positive. in this case,
!         fcn is called with iflag = 0 at the beginning of the first
!         iteration and every nprint iterations thereafter and
!         immediately prior to return, with x and fvec available
!         for printing. if nprint is not positive, no special calls
!         of fcn with iflag = 0 are made.
!
!       info is an integer output variable. if the user has
!         terminated execution, info is set to the (negative)
!         value of iflag. see description of fcn. otherwise,
!         info is set as follows.
!
!         info = 0   improper input parameters.
!
!         info = 1   relative error between two consecutive iterates
!                    is at most xtol.
!
!         info = 2   number of calls to fcn has reached or exceeded
!                    maxfev.
!
!         info = 3   xtol is too small. no further improvement in
!                    the approximate solution x is possible.
!
!         info = 4   iteration is not making good progress, as
!                    measured by the improvement from the last
!                    five jacobian evaluations.
!
!         info = 5   iteration is not making good progress, as
!                    measured by the improvement from the last
!                    ten iterations.
!
!       nfev is an integer output variable set to the number of
!         calls to fcn.
!
!       fjac is an output n by n array which contains the
!         orthogonal matrix q produced by the qr factorization
!         of the final approximate jacobian.
!
!       ldfjac is a positive integer input variable not less than n
!         which specifies the leading dimension of the array fjac.
!
!       r is an output array of length lr which contains the
!         upper triangular matrix produced by the qr factorization
!         of the final approximate jacobian, stored rowwise.
!
!       lr is a positive integer input variable not less than
!         (n*(n+1))/2.
!
!       qtf is an output array of length n which contains
!         the vector (q transpose)*fvec.
!
!       wa1, wa2, wa3, and wa4 are work arrays of length n.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr
  real xtol,epsfcn,factor
  real x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),qtf(n),wa1(n), &
       wa2(n),wa3(n),wa4(n)
  external fcn

  integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2
  integer iwa(1)
  logical jeval,sing
  real actred,delta,epsmch,fnorm,fnorm1,one,pnorm,prered,p1,p5, &
       p001,p0001,ratio,sum,temp,xnorm,zero
  real enorm
  data one,p1,p5,p001,p0001,zero &
       /1.0e0,1.0e-1,5.0e-1,1.0e-3,1.0e-4,0.0e0/
!
  epsmch = epsilon ( epsmch )

  info = 0
  iflag = 0
  nfev = 0
!
!     check the input parameters for errors.
!
  if (n <= 0 .or. xtol < zero .or. maxfev <= 0 &
      .or. ml < 0 .or. mu  <  0 .or. factor <= zero &
      .or. ldfjac < n .or. lr  <  (n*(n + 1))/2) go to 300
  if (mode /= 2) go to 20
  do 10 j = 1, n
     if (diag(j) <= zero) go to 300
   10    continue
   20 continue
!
!     evaluate the function at the starting point
!     and calculate its norm.
!
  iflag = 1
  call fcn(n,x,fvec,iflag)
  nfev = 1
  if (iflag < 0) go to 300
  fnorm = enorm(n,fvec)
!
!     determine the number of calls to fcn needed to compute
!     the jacobian matrix.
!
  msum = min (ml+mu+1,n)
!
!     initialize iteration counter and monitors.
!
  iter = 1
  ncsuc = 0
  ncfail = 0
  nslow1 = 0
  nslow2 = 0
!
!     beginning of the outer loop.
!
   30 continue
     jeval = .true.
!
!        calculate the jacobian matrix.
!
     iflag = 2
     call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, &
                 wa2)
     nfev = nfev + msum
     if (iflag < 0) go to 300
!
!        compute the qr factorization of the jacobian.
!
     call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2)
!
!        on the first iteration and if mode is 1, scale according
!        to the norms of the columns of the initial jacobian.
!
     if (iter /= 1) go to 70
     if (mode == 2) go to 50
     do 40 j = 1, n
        diag(j) = wa2(j)
        if (wa2(j) == zero) diag(j) = one
   40       continue
   50    continue
!
!        on the first iteration, calculate the norm of the scaled x
!        and initialize the step bound delta.
!
     do 60 j = 1, n
        wa3(j) = diag(j)*x(j)
   60       continue
     xnorm = enorm(n,wa3)
     delta = factor*xnorm
     if (delta == zero) delta = factor
   70    continue
!
!        form (q transpose)*fvec and store in qtf.
!
     do 80 i = 1, n
        qtf(i) = fvec(i)
   80       continue
     do 120 j = 1, n
        if (fjac(j,j) == zero) go to 110
        sum = zero
        do 90 i = j, n
           sum = sum + fjac(i,j)*qtf(i)
   90          continue
        temp = -sum/fjac(j,j)
        do 100 i = j, n
           qtf(i) = qtf(i) + fjac(i,j)*temp
  100          continue
  110       continue
  120       continue
!
!        copy the triangular factor of the qr factorization into r.
!
     sing = .false.
     do 150 j = 1, n
        l = j
        jm1 = j - 1
        if (jm1 < 1) go to 140
        do 130 i = 1, jm1
           r(l) = fjac(i,j)
           l = l + n - i
  130          continue
  140       continue
        r(l) = wa1(j)
        if (wa1(j) == zero) sing = .true.
  150       continue
!
!  Accumulate the orthogonal factor in fjac.
!
     call qform ( n, n, fjac, ldfjac )
!
!        rescale if necessary.
!
     if (mode == 2) go to 170
     do 160 j = 1, n
        diag(j) = max ( diag(j),wa2(j))
  160       continue
  170    continue
!
!        beginning of the inner loop.
!
  180    continue
!
!           if requested, call fcn to enable printing of iterates.
!
        if (nprint <= 0) go to 190
        iflag = 0
        if (mod(iter-1,nprint) == 0) call fcn(n,x,fvec,iflag)
        if (iflag < 0) go to 300
  190       continue
!
!           determine the direction p.
!
        call dogleg(n,r,lr,diag,qtf,delta,wa1)
!
!           store the direction p and x + p. calculate the norm of p.
!
        do 200 j = 1, n
           wa1(j) = -wa1(j)
           wa2(j) = x(j) + wa1(j)
           wa3(j) = diag(j)*wa1(j)
  200          continue
        pnorm = enorm(n,wa3)
!
!           on the first iteration, adjust the initial step bound.
!
        if (iter == 1) delta = amin1(delta,pnorm)
!
!           evaluate the function at x + p and calculate its norm.
!
        iflag = 1
        call fcn(n,wa2,wa4,iflag)
        nfev = nfev + 1
        if (iflag < 0) go to 300
        fnorm1 = enorm(n,wa4)
!
!           compute the scaled actual reduction.
!
        actred = -one
        if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2
!
!           compute the scaled predicted reduction.
!
        l = 1
        do 220 i = 1, n
           sum = zero
           do 210 j = i, n
              sum = sum + r(l)*wa1(j)
              l = l + 1
  210             continue
           wa3(i) = qtf(i) + sum
  220          continue
        temp = enorm(n,wa3)
        prered = zero
        if (temp < fnorm) prered = one - (temp/fnorm)**2
!
!           compute the ratio of the actual to the predicted
!           reduction.
!
        ratio = zero
        if (prered > zero) ratio = actred/prered
!
!           update the step bound.
!
        if (ratio >= p1) go to 230
           ncsuc = 0
           ncfail = ncfail + 1
           delta = p5*delta
           go to 240
  230       continue
           ncfail = 0
           ncsuc = ncsuc + 1
           if (ratio >= p5 .or. ncsuc > 1) &
              delta = max ( delta,pnorm/p5)
           if (abs(ratio-one) <= p1) delta = pnorm/p5
  240       continue
!
!           test for successful iteration.
!
        if (ratio < p0001) go to 260
!
!           successful iteration. update x, fvec, and their norms.
!
        do 250 j = 1, n
           x(j) = wa2(j)
           wa2(j) = diag(j)*x(j)
           fvec(j) = wa4(j)
  250          continue
        xnorm = enorm(n,wa2)
        fnorm = fnorm1
        iter = iter + 1
  260       continue
!
!           determine the progress of the iteration.
!
        nslow1 = nslow1 + 1
        if (actred >= p001) nslow1 = 0
        if (jeval) nslow2 = nslow2 + 1
        if (actred >= p1) nslow2 = 0
!
!           test for convergence.
!
        if (delta <= xtol*xnorm .or. fnorm == zero) info = 1
        if (info /= 0) go to 300
!
!           tests for termination and stringent tolerances.
!
        if (nfev >= maxfev) info = 2
        if (p1*max ( p1*delta,pnorm) <= epsmch*xnorm) info = 3
        if (nslow2 == 5) info = 4
        if (nslow1 == 10) info = 5
        if (info /= 0) go to 300
!
!           criterion for recalculating jacobian approximation
!           by forward differences.
!
        if (ncfail == 2) go to 290
!
!           calculate the rank one modification to the jacobian
!           and update qtf if necessary.
!
        do 280 j = 1, n
           sum = zero
           do 270 i = 1, n
              sum = sum + fjac(i,j)*wa4(i)
  270             continue
           wa2(j) = (sum - wa3(j))/pnorm
           wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
           if (ratio >= p0001) qtf(j) = sum
  280          continue
!
!           compute the qr factorization of the updated jacobian.
!
        call r1updt(n,n,r,lr,wa1,wa2,wa3,sing)
        call r1mpyq(n,n,fjac,ldfjac,wa2,wa3)
        call r1mpyq(1,n,qtf,1,wa2,wa3)
!
!           end of the inner loop.
!
        jeval = .false.
        go to 180
  290    continue
!
!        end of the outer loop.
!
     go to 30
  300 continue
!
!     termination, either normal or user imposed.
!
  if (iflag < 0) info = iflag
  iflag = 0
  if (nprint > 0) call fcn(n,x,fvec,iflag)
  return
end
subroutine i4_swap ( i, j )

!*******************************************************************************
!
!! I4_SWAP swaps two I4's.
!
!  Modified:
!
!    30 November 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer I, J.  On output, the values of I and
!    J have been interchanged.
!
  implicit none

  integer i
  integer j
  integer k

  k = i
  i = j
  j = k

  return
end
subroutine ia ( z, i1, i2, i1m, i2m )
!
!*******************************************************************************
!
!! IA calculates the modified Bessel function of the first kind
!  for orders 1/3, 2/3, -1/3, and -2/3 and for complex
!     argument z, where -pi < arg(z) <= pi.  i1 and i2
!     are replaced by the functions of orders 1/3 and 2/3,
!     respectively, and i1m and i2m by the functions of orders
!     -1/3 and -2/3, respectively.
!
  complex z,i1,i2,i1m,i2m,cz,ex13,ex13c,ex23,ex23c
!
!     ex13 = exp(i*pi/3)
!     ex13c = exp(-i*pi/3)
!     ex23 = exp(2*i*pi/3)
!     ex23c = exp(-2*i*pi/3)
!
  data ex13/(5.0e-01, 8.66025403784439e-01)/
  data ex13c/(5.0e-01, -8.66025403784439e-01)/
  data ex23/(-5.0e-01, 8.66025403784439e-01)/
  data ex23c/(-5.0e-01, -8.66025403784439e-01)/
  if(real(z) >= 0.0) go to 20
     cz = -z
!
!     calculation of i1, i2, i1m, and i2m when real(cz) > 0.
!
     call imc(cz, i1, i2, i1m, i2m)
!
!     final assembly
!
     if(aimag(z) < 0.0) go to 10
        i1 = ex13*i1
        i2 = ex23*i2
        i1m = ex13c*i1m
        i2m = ex23c*i2m
        return
   10    i1 = ex13c*i1
     i2 = ex23c*i2
     i1m = ex13*i1m
     i2m = ex23*i2m
     return
   20    call imc(z, i1, i2, i1m, i2m)
     return
end
function icamax(n,cx,incx)
!
!*******************************************************************************
!
!! ICAMAX finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!
  complex cx(*)
  integer icamax
  real smax
  integer i,incx,ix,n
  complex zdum
  real cabs1
  cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
!
  icamax = 0
  if( n < 1 ) return
  icamax = 1
  if(n==1)return
  if(incx==1)go to 20
!
!        code for increment not equal to 1
!
  ix = 1
  smax = cabs1(cx(1))
  ix = ix + incx
  do 10 i = 2,n
     if(cabs1(cx(ix)) <= smax) go to 5
     icamax = i
     smax = cabs1(cx(ix))
5    ix = ix + incx
   10 continue
  return
!
!        code for increment equal to 1
!
   20 smax = cabs1(cx(1))
  do 30 i = 2,n
     if(cabs1(cx(i)) <= smax) go to 30
     icamax = i
     smax = cabs1(cx(i))
   30 continue
  return
end
function idamax(n,dx,incx)
!
!*******************************************************************************
!
!! IDAMAX finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!
  double precision dx(*),dmax
  integer idamax
  integer i,incx,ix,n
!
  idamax = 0
  if( n < 1 ) return
  idamax = 1
  if(n==1)return
  if(incx==1)go to 20
!
!        code for increment not equal to 1
!
  ix = 1
  dmax = dabs(dx(1))
  ix = ix + incx
  do 10 i = 2,n
     if(dabs(dx(ix)) <= dmax) go to 5
     idamax = i
     dmax = dabs(dx(ix))
5    ix = ix + incx
   10 continue
  return
!
!        code for increment equal to 1
!
   20 dmax = dabs(dx(1))
  do 30 i = 2,n
     if(dabs(dx(i)) <= dmax) go to 30
     idamax = i
     dmax = dabs(dx(i))
   30 continue
  return
end
subroutine idcldp(ndp,xd,yd,ncp,ipc,ierr)
!
!*****************************************************************************80
!
!! IDCLDP selects several data points that are closest to each of data point.
!
!
! the input parameters are
!     ndp = number of data points,
!     xd,yd = arrays of dimension ndp containing the x and y
!           coordinates of the data points,
!     ncp = number of data points closest to each data
!           point.
! the output parameters are
!     ipc = integer array of dimension ncp*ndp, where the
!           point numbers of ncp data points closest to
!           each of the ndp data points are to be stored.
!     ierr = error indicator. ierr is set to 0 if no errors
!           are detected.
! this subroutine arbitrarily sets a restriction that ncp must
! not exceed 25.
!
  dimension xd(ndp), yd(ndp), ipc(*)
  dimension dsq0(25), ipc0(25)
  data  ncpmx/25/
!
! statement function
!
  dsqf(u1,v1,u2,v2)=(u2-u1)**2+(v2-v1)**2
!
! preliminary processing
  ndp0=ndp
  ncp0=ncp
  if(ndp0 < 2)  go to 91
  if(ncp0 < 1.or.ncp0 > ncpmx.or.ncp0 >= ndp0)    go to 90
  ierr=0
! calculation
  do 59  ip1=1,ndp0
! - selects ncp points.
    x1=xd(ip1)
    y1=yd(ip1)
    j1=0
    dsqmx=0.0
    do 22  ip2=1,ndp0
      if(ip2==ip1)  go to 22
      dsqi=dsqf(x1,y1,xd(ip2),yd(ip2))
      j1=j1+1
      dsq0(j1)=dsqi
      ipc0(j1)=ip2
      if(dsqi <= dsqmx)    go to 21
      dsqmx=dsqi
      jmx=j1
   21     if(j1 >= ncp0)  go to 23
   22   continue
   23   ip2mn=ip2+1
    if(ip2mn > ndp0)      go to 30
    do 25  ip2=ip2mn,ndp0
      if(ip2==ip1)  go to 25
      dsqi=dsqf(x1,y1,xd(ip2),yd(ip2))
      if(dsqi >= dsqmx)    go to 25
      dsq0(jmx)=dsqi
      ipc0(jmx)=ip2
      dsqmx=0.0
      do 24  j1=1,ncp0
        if(dsq0(j1) <= dsqmx)   go to 24
        dsqmx=dsq0(j1)
        jmx=j1
   24     continue
   25   continue
! - checks if all the ncp+1 points are collinear.
   30   ip2=ipc0(1)
    dx12=xd(ip2)-x1
    dy12=yd(ip2)-y1
    do 31  j3=2,ncp0
      ip3=ipc0(j3)
      dx13=xd(ip3)-x1
      dy13=yd(ip3)-y1
      if((dy13*dx12-dx13*dy12)/=0.0)    go to 50
   31   continue
! - searches for the closest noncollinear point.
    nclpt=0
    do 43  ip3=1,ndp0
      if(ip3==ip1)       go to 43
      do 41  j4=1,ncp0
        if(ip3==ipc0(j4))     go to 43
   41     continue
      dx13=xd(ip3)-x1
      dy13=yd(ip3)-y1
      if((dy13*dx12-dx13*dy12)==0.0)    go to 43
      dsqi=dsqf(x1,y1,xd(ip3),yd(ip3))
      if(nclpt==0)       go to 42
      if(dsqi >= dsqmn)    go to 43
   42     nclpt=1
      dsqmn=dsqi
      ip3mn=ip3
   43   continue
    if(nclpt==0)    go to 92
    dsqmx=dsqmn
    ipc0(jmx)=ip3mn
! - replaces the local array for the output array.
   50   j1=(ip1-1)*ncp0
    do 51  j2=1,ncp0
      j1=j1+1
      ipc(j1)=ipc0(j2)
   51   continue
   59 continue
  return
!
!                        error return
!
!          either  2 <= ncp < ndp  or  ncp <= ncpmx
!                      is not satisfied
   90 ierr=2
  return
!                     ndp is less than 2
   91 ierr=3
  return
!            the points in xd,yd,zd are collinear
   92 ierr=8
  return
end
subroutine idgrid(xd, yd, nt, ipt, nl, ipl, nxi, nyi, xi, yi, &
    ngp, igp)
!
!*******************************************************************************
!
!! IDGRID organizes grid points for surface fitting by sorting them
!  in ascending order of triangle numbers and of the
! border line segment number.
! the input parameters are
!     xd,yd = arrays of dimension ndp containing the x and y
!           coordinates of the data points, where ndp is the
!           number of the data points,
!     nt  = number of triangles,
!     ipt = integer array of dimension 3*nt containing the
!           point numbers of the vertices of the triangles,
!     nl  = number of border line segments,
!     ipl = integer array of dimension 3*nl containing the
!           point numbers of the end points of the border
!           line segments and their respective triangle
!           numbers,
!     nxi = number of grid points in the x coordinate,
!     nyi = number of grid points in the y coordinate,
!     xi,yi = arrays of dimension nxi and nyi containing
!           the x and y coordinates of the grid points,
!           respectively.
! the output parameters are
!     ngp = integer array of dimension 2*(nt+2*nl) where the
!           number of grid points that belong to each of the
!           triangles or of the border line segments are to
!           be stored,
!     igp = integer array of dimension nxi*nyi where the
!           grid point numbers are to be stored in ascending
!           order of the triangle number and the border line
!           segment number.
!
  dimension xd(*), yd(*), ipt(*), ipl(*), xi(nxi), &
            yi(nyi), ngp(*), igp(*)
!
! statement functions
!
  side(u1,v1,u2,v2,u3,v3) = (u1-u3)*(v2-v3) - (v1-v3)*(u2-u3)
  spdt(u1,v1,u2,v2,u3,v3) = (u1-u2)*(u3-u2) + (v1-v2)*(v3-v2)
!
! preliminary processing
  nt0 = nt
  nl0 = nl
  nxi0 = nxi
  nyi0 = nyi
  nxinyi = nxi0*nyi0
  ximn = amin1(xi(1),xi(nxi0))
  ximx = max ( xi(1),xi(nxi0))
  yimn = amin1(yi(1),yi(nyi0))
  yimx = max ( yi(1),yi(nyi0))
! determines grid points inside the data area.
  jngp0 = 0
  jngp1 = 2*(nt0+2*nl0) + 1
  jigp0 = 0
  jigp1 = nxinyi + 1
  do 160 it0=1,nt0
    ngp0 = 0
    ngp1 = 0
    it0t3 = it0*3
    ip1 = ipt(it0t3-2)
    ip2 = ipt(it0t3-1)
    ip3 = ipt(it0t3)
    x1 = xd(ip1)
    y1 = yd(ip1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    x3 = xd(ip3)
    y3 = yd(ip3)
    xmn = amin1(x1,x2,x3)
    xmx = max ( x1,x2,x3)
    ymn = amin1(y1,y2,y3)
    ymx = max ( y1,y2,y3)
    insd = 0
    do 20 ixi=1,nxi0
      if (xi(ixi) >= xmn .and. xi(ixi) <= xmx) go to 10
      if (insd==0) go to 20
      iximx = ixi - 1
      go to 30
   10     if (insd==1) go to 20
      insd = 1
      iximn = ixi
   20   continue
    if (insd==0) go to 150
    iximx = nxi0
   30   do 140 iyi=1,nyi0
      yii = yi(iyi)
      if (yii < ymn .or. yii > ymx) go to 140
      do 130 ixi=iximn,iximx
        xii = xi(ixi)
        l = 0
        if (side(x1,y1,x2,y2,xii,yii)) 130, 40, 50
   40       l = 1
   50       if (side(x2,y2,x3,y3,xii,yii)) 130, 60, 70
   60       l = 1
   70       if (side(x3,y3,x1,y1,xii,yii)) 130, 80, 90
   80       l = 1
   90       izi = nxi0*(iyi-1) + ixi
        if (l==1) go to 100
        ngp0 = ngp0 + 1
        jigp0 = jigp0 + 1
        igp(jigp0) = izi
        go to 130
  100       if (jigp1 > nxinyi) go to 120
        do 110 jigp1i=jigp1,nxinyi
          if (izi==igp(jigp1i)) go to 130
  110       continue
  120       ngp1 = ngp1 + 1
        jigp1 = jigp1 - 1
        igp(jigp1) = izi
  130     continue
  140   continue
  150   jngp0 = jngp0 + 1
    ngp(jngp0) = ngp0
    jngp1 = jngp1 - 1
    ngp(jngp1) = ngp1
  160 continue
! determines grid points outside the data area.
! - in semi-infinite rectangular area.
  do 450 il0=1,nl0
    ngp0 = 0
    ngp1 = 0
    il0t3 = il0*3
    ip1 = ipl(il0t3-2)
    ip2 = ipl(il0t3-1)
    x1 = xd(ip1)
    y1 = yd(ip1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    xmn = ximn
    xmx = ximx
    ymn = yimn
    ymx = yimx
    if (y2 >= y1) xmn = amin1(x1,x2)
    if (y2 <= y1) xmx = max ( x1,x2)
    if (x2 <= x1) ymn = amin1(y1,y2)
    if (x2 >= x1) ymx = max ( y1,y2)
    insd = 0
    do 180 ixi=1,nxi0
      if (xi(ixi) >= xmn .and. xi(ixi) <= xmx) go to 170
      if (insd==0) go to 180
      iximx = ixi - 1
      go to 190
  170     if (insd==1) go to 180
      insd = 1
      iximn = ixi
  180   continue
    if (insd==0) go to 310
    iximx = nxi0
  190   do 300 iyi=1,nyi0
      yii = yi(iyi)
      if (yii < ymn .or. yii > ymx) go to 300
      do 290 ixi=iximn,iximx
        xii = xi(ixi)
        l = 0
        if (side(x1,y1,x2,y2,xii,yii)) 210, 200, 290
  200       l = 1
  210       if (spdt(x2,y2,x1,y1,xii,yii)) 290, 220, 230
  220       l = 1
  230       if (spdt(x1,y1,x2,y2,xii,yii)) 290, 240, 250
  240       l = 1
  250       izi = nxi0*(iyi-1) + ixi
        if (l==1) go to 260
        ngp0 = ngp0 + 1
        jigp0 = jigp0 + 1
        igp(jigp0) = izi
        go to 290
  260       if (jigp1 > nxinyi) go to 280
        do 270 jigp1i=jigp1,nxinyi
          if (izi==igp(jigp1i)) go to 290
  270       continue
  280       ngp1 = ngp1 + 1
        jigp1 = jigp1 - 1
        igp(jigp1) = izi
  290     continue
  300   continue
  310   jngp0 = jngp0 + 1
    ngp(jngp0) = ngp0
    jngp1 = jngp1 - 1
    ngp(jngp1) = ngp1
! - in semi-infinite triangular area.
    ngp0 = 0
    ngp1 = 0
    ilp1 = mod(il0,nl0) + 1
    ilp1t3 = ilp1*3
    ip3 = ipl(ilp1t3-1)
    x3 = xd(ip3)
    y3 = yd(ip3)
    xmn = ximn
    xmx = ximx
    ymn = yimn
    ymx = yimx
    if (y3 >= y2 .and. y2 >= y1) xmn = x2
    if (y3 <= y2 .and. y2 <= y1) xmx = x2
    if (x3 <= x2 .and. x2 <= x1) ymn = y2
    if (x3 >= x2 .and. x2 >= x1) ymx = y2
    insd = 0
    do 330 ixi=1,nxi0
      if (xi(ixi) >= xmn .and. xi(ixi) <= xmx) go to 320
      if (insd==0) go to 330
      iximx = ixi - 1
      go to 340
  320     if (insd==1) go to 330
      insd = 1
      iximn = ixi
  330   continue
    if (insd==0) go to 440
    iximx = nxi0
  340   do 430 iyi=1,nyi0
      yii = yi(iyi)
      if (yii < ymn .or. yii > ymx) go to 430
      do 420 ixi=iximn,iximx
        xii = xi(ixi)
        l = 0
        if (spdt(x1,y1,x2,y2,xii,yii)) 360, 350, 420
  350       l = 1
  360       if (spdt(x3,y3,x2,y2,xii,yii)) 380, 370, 420
  370       l = 1
  380       izi = nxi0*(iyi-1) + ixi
        if (l==1) go to 390
        ngp0 = ngp0 + 1
        jigp0 = jigp0 + 1
        igp(jigp0) = izi
        go to 420
  390       if (jigp1 > nxinyi) go to 410
        do 400 jigp1i=jigp1,nxinyi
          if (izi==igp(jigp1i)) go to 420
  400       continue
  410       ngp1 = ngp1 + 1
        jigp1 = jigp1 - 1
        igp(jigp1) = izi
  420     continue
  430   continue
  440   jngp0 = jngp0 + 1
    ngp(jngp0) = ngp0
    jngp1 = jngp1 - 1
    ngp(jngp1) = ngp1
  450 continue
  return
end
subroutine idlctn(ndp, xd, yd, nt, ipt, nl, ipl, xii, yii, iti, &
    iwk, wk)
!
!*******************************************************************************
!
!! IDLCTN determines what triangle a given point belongs to.
!
!
!  when the given point
! does not lie inside the data area, this subroutine determines
! the border line segment when the point lies in an outside
! rectangular area, and two border line segments when the point
! lies in an outside triangular area.
! the input parameters are
!     ndp = number of data points,
!     xd,yd = arrays of dimension ndp containing the x and y
!           coordinates of the data points,
!     nt  = number of triangles,
!     ipt = integer array of dimension 3*nt containing the
!           point numbers of the vertices of the triangles,
!     nl  = number of border line segments,
!     ipl = integer array of dimension 3*nl containing the
!           point numbers of the end points of the border
!           line segments and their respective triangle
!           numbers,
!     xii,yii = x and y coordinates of the point to be
!           located.
! the output parameter is
!     iti = triangle number, when the point is inside the
!           data area, or
!           two border line segment numbers, il1 and il2,
!           coded to il1*(nt+nl)+il2, when the point is
!           outside the data area.
! the other parameters are
!     iwk = integer array of dimension 18*ndp used inter-
!           nally as a work area,
!     wk  = array of dimension 8*ndp used internally as a
!           work area.
!
  dimension xd(ndp), yd(ndp), ipt(*), ipl(*), iwk(*), wk(*)
  dimension idsc(9)
  common/idlc/itipv,xs1,xs2,ys1,ys2,ntsc(9)
!
! statement functions
!
  side(u1,v1,u2,v2,u3,v3) = (u1-u3)*(v2-v3) - (v1-v3)*(u2-u3)
  spdt(u1,v1,u2,v2,u3,v3) = (u1-u2)*(u3-u2) + (v1-v2)*(v3-v2)
!
! preliminary processing
  ndp0 = ndp
  nt0 = nt
  nl0 = nl
  ntl = nt0 + nl0
  x0 = xii
  y0 = yii
! processing for a new set of data points
  if (itipv/=0) go to 80
! - divides the x-y plane into nine rectangular sections.
  xmn = xd(1)
  xmx = xmn
  ymn = yd(1)
  ymx = ymn
  do idp=2,ndp0
    xi = xd(idp)
    yi = yd(idp)
    xmn = amin1(xi,xmn)
    xmx = max ( xi,xmx)
    ymn = amin1(yi,ymn)
    ymx = max ( yi,ymx)
  end do

  xs1 = (xmn+xmn+xmx)/3.0
  xs2 = (xmn+xmx+xmx)/3.0
  ys1 = (ymn+ymn+ymx)/3.0
  ys2 = (ymn+ymx+ymx)/3.0
! - determines and stores in the iwk array triangle numbers of
! - the triangles associated with each of the nine sections.
  do 20 isc=1,9
    ntsc(isc) = 0
    idsc(isc) = 0
   20 continue
  it0t3 = 0
  jwk = 0
  do 70 it0=1,nt0
    it0t3 = it0t3 + 3
    i1 = ipt(it0t3-2)
    i2 = ipt(it0t3-1)
    i3 = ipt(it0t3)
    xmn = amin1(xd(i1),xd(i2),xd(i3))
    xmx = max ( xd(i1),xd(i2),xd(i3))
    ymn = amin1(yd(i1),yd(i2),yd(i3))
    ymx = max ( yd(i1),yd(i2),yd(i3))
    if (ymn > ys1) go to 30
    if (xmn <= xs1) idsc(1) = 1
    if (xmx >= xs1 .and. xmn <= xs2) idsc(2) = 1
    if (xmx >= xs2) idsc(3) = 1
   30   if (ymx < ys1 .or. ymn > ys2) go to 40
    if (xmn <= xs1) idsc(4) = 1
    if (xmx >= xs1 .and. xmn <= xs2) idsc(5) = 1
    if (xmx >= xs2) idsc(6) = 1
   40   if (ymx < ys2) go to 50
    if (xmn <= xs1) idsc(7) = 1
    if (xmx >= xs1 .and. xmn <= xs2) idsc(8) = 1
    if (xmx >= xs2) idsc(9) = 1
   50   do 60 isc=1,9
      if (idsc(isc)==0) go to 60
      jiwk = 9*ntsc(isc) + isc
      iwk(jiwk) = it0
      ntsc(isc) = ntsc(isc) + 1
      idsc(isc) = 0
   60   continue
! - stores in the wk array the minimum and maximum of the x and
! - y coordinate values for each of the triangle.
    jwk = jwk + 4
    wk(jwk-3) = xmn
    wk(jwk-2) = xmx
    wk(jwk-1) = ymn
    wk(jwk) = ymx
   70 continue
  go to 110
! checks if in the same triangle as previous.
   80 it0 = itipv
  if (it0 > nt0) go to 90
  it0t3 = it0*3
  ip1 = ipt(it0t3-2)
  x1 = xd(ip1)
  y1 = yd(ip1)
  ip2 = ipt(it0t3-1)
  x2 = xd(ip2)
  y2 = yd(ip2)
  if (side(x1,y1,x2,y2,x0,y0) < 0.0) go to 110
  ip3 = ipt(it0t3)
  x3 = xd(ip3)
  y3 = yd(ip3)
  if (side(x2,y2,x3,y3,x0,y0) < 0.0) go to 110
  if (side(x3,y3,x1,y1,x0,y0) < 0.0) go to 110
  go to 170
! checks if on the same border line segment.
   90 il1 = it0/ntl
  il2 = it0 - il1*ntl
  il1t3 = il1*3
  ip1 = ipl(il1t3-2)
  x1 = xd(ip1)
  y1 = yd(ip1)
  ip2 = ipl(il1t3-1)
  x2 = xd(ip2)
  y2 = yd(ip2)
  if (il2/=il1) go to 100
  if (spdt(x1,y1,x2,y2,x0,y0) < 0.0) go to 110
  if (spdt(x2,y2,x1,y1,x0,y0) < 0.0) go to 110
  if (side(x1,y1,x2,y2,x0,y0) > 0.0) go to 110
  go to 170
! checks if between the same two border line segments.
  100 if (spdt(x1,y1,x2,y2,x0,y0) > 0.0) go to 110
  ip3 = ipl(3*il2-1)
  x3 = xd(ip3)
  y3 = yd(ip3)
  if (spdt(x3,y3,x2,y2,x0,y0) <= 0.0) go to 170
! locates inside the data area.
! - determines the section in which the point in question lies.
  110 isc = 1
  if (x0 >= xs1) isc = isc + 1
  if (x0 >= xs2) isc = isc + 1
  if (y0 >= ys1) isc = isc + 3
  if (y0 >= ys2) isc = isc + 3
! - searches through the triangles associated with the section.
  ntsci = ntsc(isc)
  if (ntsci <= 0) go to 130
  jiwk = -9 + isc
  do 120 itsc=1,ntsci
    jiwk = jiwk + 9
    it0 = iwk(jiwk)
    jwk = it0*4
    if (x0 < wk(jwk-3)) go to 120
    if (x0 > wk(jwk-2)) go to 120
    if (y0 < wk(jwk-1)) go to 120
    if (y0 > wk(jwk)) go to 120
    it0t3 = it0*3
    ip1 = ipt(it0t3-2)
    x1 = xd(ip1)
    y1 = yd(ip1)
    ip2 = ipt(it0t3-1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    if (side(x1,y1,x2,y2,x0,y0) < 0.0) go to 120
    ip3 = ipt(it0t3)
    x3 = xd(ip3)
    y3 = yd(ip3)
    if (side(x2,y2,x3,y3,x0,y0) < 0.0) go to 120
    if (side(x3,y3,x1,y1,x0,y0) < 0.0) go to 120
    go to 170
  120 continue
! locates outside the data area.
  130 do 150 il1=1,nl0
    il1t3 = il1*3
    ip1 = ipl(il1t3-2)
    x1 = xd(ip1)
    y1 = yd(ip1)
    ip2 = ipl(il1t3-1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    if (spdt(x2,y2,x1,y1,x0,y0) < 0.0) go to 150
    if (spdt(x1,y1,x2,y2,x0,y0) < 0.0) go to 140
    if (side(x1,y1,x2,y2,x0,y0) > 0.0) go to 150
    il2 = il1
    go to 160
  140   il2 = mod(il1,nl0) + 1
    ip3 = ipl(3*il2-1)
    x3 = xd(ip3)
    y3 = yd(ip3)
    if (spdt(x3,y3,x2,y2,x0,y0) <= 0.0) go to 160
  150 continue
  it0 = 1
  go to 170
  160 it0 = il1*ntl + il2
! normal exit
  170 iti = it0
  itipv = it0
  return
end
subroutine idpdrv(ndp,xd,yd,zd,ncp,ipc,pd)
!
!*******************************************************************************
!
!! IDPDRV estimates first and second partial derivatives at the data points.
!
!
! the input parameters are
!     ndp = number of data points,
!     xd,yd,zd = arrays of dimension ndp containing the x,
!           y, and z coordinates of the data points,
!     ncp = number of additional data points used for esti-
!           mating partial derivatives at each data point,
!     ipc = integer array of dimension ncp*ndp containing
!           the point numbers of ncp data points closest to
!           each of the ndp data points.
! the output parameter is
!     pd  = array of dimension 5*ndp, where the estimated
!           zx, zy, zxx, zxy, and zyy values at the data
!           points are to be stored.
!
  dimension   xd(ndp),yd(ndp),zd(ndp),ipc(*),pd(*)
  real        nmx,nmy,nmz,nmxx,nmxy,nmyx,nmyy
!
! preliminary processing
  ndp0=ndp
  ncp0=ncp
  ncpm1=ncp0-1
! estimation of zx and zy
  do 24  ip0=1,ndp0
    x0=xd(ip0)
    y0=yd(ip0)
    z0=zd(ip0)
    nmx=0.0
    nmy=0.0
    nmz=0.0
    jipc0=ncp0*(ip0-1)
    do 23  ic1=1,ncpm1
      jipc=jipc0+ic1
      ipi=ipc(jipc)
      dx1=xd(ipi)-x0
      dy1=yd(ipi)-y0
      dz1=zd(ipi)-z0
      ic2mn=ic1+1
      do 22  ic2=ic2mn,ncp0
        jipc=jipc0+ic2
        ipi=ipc(jipc)
        dx2=xd(ipi)-x0
        dy2=yd(ipi)-y0
        dnmz=dx1*dy2-dy1*dx2
        if(dnmz==0.0)    go to 22
        dz2=zd(ipi)-z0
        dnmx=dy1*dz2-dz1*dy2
        dnmy=dz1*dx2-dx1*dz2
        if(dnmz >= 0.0)    go to 21
        dnmx=-dnmx
        dnmy=-dnmy
        dnmz=-dnmz
   21       nmx=nmx+dnmx
        nmy=nmy+dnmy
        nmz=nmz+dnmz
   22     continue
   23   continue
    jpd0=5*ip0
    pd(jpd0-4)=-nmx/nmz
    pd(jpd0-3)=-nmy/nmz
   24 continue
! estimation of zxx, zxy, and zyy
  do 34  ip0=1,ndp0
    jpd0=jpd0+5
    x0=xd(ip0)
    jpd0=5*ip0
    y0=yd(ip0)
    zx0=pd(jpd0-4)
    zy0=pd(jpd0-3)
    nmxx=0.0
    nmxy=0.0
    nmyx=0.0
    nmyy=0.0
    nmz =0.0
    jipc0=ncp0*(ip0-1)
    do 33  ic1=1,ncpm1
      jipc=jipc0+ic1
      ipi=ipc(jipc)
      dx1=xd(ipi)-x0
      dy1=yd(ipi)-y0
      jpd=5*ipi
      dzx1=pd(jpd-4)-zx0
      dzy1=pd(jpd-3)-zy0
      ic2mn=ic1+1
      do 32  ic2=ic2mn,ncp0
        jipc=jipc0+ic2
        ipi=ipc(jipc)
        dx2=xd(ipi)-x0
        dy2=yd(ipi)-y0
        dnmz =dx1*dy2 -dy1*dx2
        if(dnmz==0.0)    go to 32
        jpd=5*ipi
        dzx2=pd(jpd-4)-zx0
        dzy2=pd(jpd-3)-zy0
        dnmxx=dy1*dzx2-dzx1*dy2
        dnmxy=dzx1*dx2-dx1*dzx2
        dnmyx=dy1*dzy2-dzy1*dy2
        dnmyy=dzy1*dx2-dx1*dzy2
        if(dnmz >= 0.0)    go to 31
        dnmxx=-dnmxx
        dnmxy=-dnmxy
        dnmyx=-dnmyx
        dnmyy=-dnmyy
        dnmz =-dnmz
   31       nmxx=nmxx+dnmxx
        nmxy=nmxy+dnmxy
        nmyx=nmyx+dnmyx
        nmyy=nmyy+dnmyy
        nmz =nmz +dnmz
   32     continue
   33   continue
    pd(jpd0-2)=-nmxx/nmz
    pd(jpd0-1)=-(nmxy+nmyx)/(2.0*nmz)
    pd(jpd0)  =-nmyy/nmz
   34 continue
  return
end
subroutine idptip(xd,yd,zd,nt,ipt,nl,ipl,pdd,iti,xii,yii, &
                     zii)
!
!*******************************************************************************
!
!! IDPTIP performs pointwise interpolation or extrapolation.
!
!
!  i.e., determines the z value at a point.
! the input parameters are
!     xd,yd,zd = arrays of dimension ndp containing the x,
!           y, and z coordinates of the data points, where
!           ndp is the number of the data points,
!     nt  = number of triangles,
!     ipt = integer array of dimension 3*nt containing the
!           point numbers of the vertices of the triangles,
!     nl  = number of border line segments,
!     ipl = integer array of dimension 3*nl containing the
!           point numbers of the end points of the border
!           line segments and their respective triangle
!           numbers,
!     pdd = array of dimension 5*ndp containing the partial
!           derivatives at the data points,
!     iti = triangle number of the triangle in which lies
!           the point for which interpolation is to be
!           performed,
!     xii,yii = x and y coordinates of the point for which
!           interpolation is to be performed.
! the output parameter is
!     zii = interpolated z value.
!
  dimension   xd(*),yd(*),zd(*),ipt(*),ipl(*),pdd(*)
  common/idpi/itpv,x0,y0,ap,bp,cp,dp, &
              p00,p10,p20,p30,p40,p50,p01,p11,p21,p31,p41, &
              p02,p12,p22,p32,p03,p13,p23,p04,p14,p05
  dimension   x(3),y(3),z(3),pd(15), &
              zu(3),zv(3),zuu(3),zuv(3),zvv(3)
  real        lusq,lvsq
!
! preliminary processing
  it0=iti
  ntl=nt+nl
  if(it0 <= ntl)      go to 20
  il1=it0/ntl
  il2=it0-il1*ntl
  if(il1==il2)      go to 40
  go to 60
! calculation of zii by interpolation.
! checks if the necessary coefficients have been calculated.
   20 if(it0==itpv)     go to 30
! loads coordinate and partial derivative values at the
! vertices.
  jipt=3*(it0-1)
  jpd=0
  do 23  i=1,3
    jipt=jipt+1
    idp=ipt(jipt)
    x(i)=xd(idp)
    y(i)=yd(idp)
    z(i)=zd(idp)
    jpdd=5*(idp-1)
    do 22  kpd=1,5
      jpd=jpd+1
      jpdd=jpdd+1
      pd(jpd)=pdd(jpdd)
   22   continue
   23 continue
! determines the coefficients for the coordinate system
! transformation from the x-y system to the u-v system
! and vice versa.
  x0=x(1)
  y0=y(1)
  a=x(2)-x0
  b=x(3)-x0
  c=y(2)-y0
  d=y(3)-y0
  ad=a*d
  bc=b*c
  dlt=ad-bc
  ap= d/dlt
  bp=-b/dlt
  cp=-c/dlt
  dp= a/dlt
! converts the partial derivatives at the vertices of the
! triangle for the u-v coordinate system.
  aa=a*a
  act2=2.0*a*c
  cc=c*c
  ab=a*b
  adbc=ad+bc
  cd=c*d
  bb=b*b
  bdt2=2.0*b*d
  dd=d*d
  do 26  i=1,3
    jpd=5*i
    zu(i)=a*pd(jpd-4)+c*pd(jpd-3)
    zv(i)=b*pd(jpd-4)+d*pd(jpd-3)
    zuu(i)=aa*pd(jpd-2)+act2*pd(jpd-1)+cc*pd(jpd)
    zuv(i)=ab*pd(jpd-2)+adbc*pd(jpd-1)+cd*pd(jpd)
    zvv(i)=bb*pd(jpd-2)+bdt2*pd(jpd-1)+dd*pd(jpd)
   26 continue
! calculates the coefficients of the polynomial.
  p00=z(1)
  p10=zu(1)
  p01=zv(1)
  p20=0.5*zuu(1)
  p11=zuv(1)
  p02=0.5*zvv(1)
  h1=z(2)-p00-p10-p20
  h2=zu(2)-p10-zuu(1)
  h3=zuu(2)-zuu(1)
  p30= 10.0*h1-4.0*h2+0.5*h3
  p40=-15.0*h1+7.0*h2    -h3
  p50=  6.0*h1-3.0*h2+0.5*h3
  h1=z(3)-p00-p01-p02
  h2=zv(3)-p01-zvv(1)
  h3=zvv(3)-zvv(1)
  p03= 10.0*h1-4.0*h2+0.5*h3
  p04=-15.0*h1+7.0*h2    -h3
  p05=  6.0*h1-3.0*h2+0.5*h3
  lusq = aa + cc
  lvsq = bb + dd
  spuv = ab + cd
  p41 = 5.0*spuv/lusq*p50
  p14 = 5.0*spuv/lvsq*p05
  h1=zv(2)-p01-p11-p41
  h2=zuv(2)-p11-4.0*p41
  p21= 3.0*h1-h2
  p31=-2.0*h1+h2
  h1=zu(3)-p10-p11-p14
  h2=zuv(3)-p11-4.0*p14
  p12= 3.0*h1-h2
  p13=-2.0*h1+h2
  e1 = (lvsq - spuv)/((lvsq - spuv) + (lusq - spuv))
  e2 = 1.0 - e1
  g1 = 5.0*e1 - 2.0
  g2 = 1.0 - g1
  h1 = 5.0*(e1*(p50 - p41) + e2*(p05 - p14)) + (p41 + p14)
  h2=0.5*zvv(2)-p02-p12
  h3=0.5*zuu(3)-p20-p21
  p22 = h1 + g1*h2 + g2*h3
  p32=h2-p22
  p23=h3-p22
  itpv=it0
! converts xii and yii to u-v system.
   30 dx=xii-x0
  dy=yii-y0
  u=ap*dx+bp*dy
  v=cp*dx+dp*dy
! evaluates the polynomial.
  p0=p00+v*(p01+v*(p02+v*(p03+v*(p04+v*p05))))
  p1=p10+v*(p11+v*(p12+v*(p13+v*p14)))
  p2=p20+v*(p21+v*(p22+v*p23))
  p3=p30+v*(p31+v*p32)
  p4=p40+v*p41
  zii=p0+u*(p1+u*(p2+u*(p3+u*(p4+u*p50))))
  return
! calculation of zii by extrapolation in the rectangle.
! checks if the necessary coefficients have been calculated.
   40 if(it0==itpv)     go to 50
! loads coordinate and partial derivative values at the end
! points of the border line segment.
  jipl=3*(il1-1)
  jpd=0
  do 43  i=1,2
    jipl=jipl+1
    idp=ipl(jipl)
    x(i)=xd(idp)
    y(i)=yd(idp)
    z(i)=zd(idp)
    jpdd=5*(idp-1)
    do 42  kpd=1,5
      jpd=jpd+1
      jpdd=jpdd+1
      pd(jpd)=pdd(jpdd)
   42   continue
   43 continue
! determines the coefficients for the coordinate system
! transformation from the x-y system to the u-v system
! and vice versa.
  x0=x(1)
  y0=y(1)
  a=y(2)-y(1)
  b=x(2)-x(1)
  c=-b
  d=a
  ad=a*d
  bc=b*c
  dlt=ad-bc
  ap= d/dlt
  bp=-b/dlt
  cp=-bp
  dp= ap
! converts the partial derivatives at the end points of the
! border line segment for the u-v coordinate system.
  aa=a*a
  act2=2.0*a*c
  cc=c*c
  ab=a*b
  adbc=ad+bc
  cd=c*d
  bb=b*b
  bdt2=2.0*b*d
  dd=d*d
  do 46  i=1,2
    jpd=5*i
    zu(i)=a*pd(jpd-4)+c*pd(jpd-3)
    zv(i)=b*pd(jpd-4)+d*pd(jpd-3)
    zuu(i)=aa*pd(jpd-2)+act2*pd(jpd-1)+cc*pd(jpd)
    zuv(i)=ab*pd(jpd-2)+adbc*pd(jpd-1)+cd*pd(jpd)
    zvv(i)=bb*pd(jpd-2)+bdt2*pd(jpd-1)+dd*pd(jpd)
   46 continue
! calculates the coefficients of the polynomial.
  p00=z(1)
  p10=zu(1)
  p01=zv(1)
  p20=0.5*zuu(1)
  p11=zuv(1)
  p02=0.5*zvv(1)
  h1=z(2)-p00-p01-p02
  h2=zv(2)-p01-zvv(1)
  h3=zvv(2)-zvv(1)
  p03= 10.0*h1-4.0*h2+0.5*h3
  p04=-15.0*h1+7.0*h2    -h3
  p05=  6.0*h1-3.0*h2+0.5*h3
  h1=zu(2)-p10-p11
  h2=zuv(2)-p11
  p12= 3.0*h1-h2
  p13=-2.0*h1+h2
  p21=0.0
  p23=-zuu(2)+zuu(1)
  p22=-1.5*p23
  itpv=it0
! converts xii and yii to u-v system.
   50 dx=xii-x0
  dy=yii-y0
  u=ap*dx+bp*dy
  v=cp*dx+dp*dy
! evaluates the polynomial.
  p0=p00+v*(p01+v*(p02+v*(p03+v*(p04+v*p05))))
  p1=p10+v*(p11+v*(p12+v*p13))
  p2=p20+v*(p21+v*(p22+v*p23))
  zii=p0+u*(p1+u*p2)
  return
! calculation of zii by extrapolation in the triangle.
! checks if the necessary coefficients have been calculated.
   60 if(it0==itpv)     go to 70
! loads coordinate and partial derivative values at the vertex
! of the triangle.
  jipl=3*il2-2
  idp=ipl(jipl)
  x0=xd(idp)
  y0=yd(idp)
  z0=zd(idp)
  jpdd=5*(idp-1)
  do 62  kpd=1,5
    jpdd=jpdd+1
    pd(kpd)=pdd(jpdd)
   62 continue
! calculates the coefficients of the polynomial.
  p00=z0
  p10=pd(1)
  p01=pd(2)
  p20=0.5*pd(3)
  p11=pd(4)
  p02=0.5*pd(5)
  itpv=it0
! converts xii and yii to u-v system.
   70 u=xii-x0
  v=yii-y0
! evaluates the polynomial.
  p0=p00+v*(p01+v*p02)
  p1=p10+v*p11
  zii=p0+u*(p1+u*p20)
  return
end
subroutine idtang(ndp,xd,yd,nt,ipt,nl,ipl,iwl,iwp,wk,ierr)
!
!*******************************************************************************
!
!! IDTANG performs triangulation.
!
!
!  it divides the x-y
! plane into a number of triangles according to given data
! points in the plane, determines line segments that form the
! border of data area, and determines the triangle numbers
! corresponding to the border line segments.
! at completion, point numbers of the vertices of each triangle
! are listed counter-clockwise.  point numbers of the end points
! of each border line segment are listed counter-clockwise,
! listing order of the line segments being counter-clockwise.
! this subroutine calls the idxchg function.
! the input parameters are
!     ndp = number of data points,
!     xd  = array of dimension ndp containing the
!           x coordinates of the data points,
!     yd  = array of dimension ndp containing the
!           y coordinates of the data points.
! the output parameters are
!     nt  = number of triangles,
!     ipt = integer array of dimension 6*ndp-15, where the
!           point numbers of the vertices of the (it)th
!           triangle are to be stored as the (3*it-2)nd,
!           (3*it-1)st, and (3*it)th elements,
!           it=1,2,...,nt,
!     nl  = number of border line segments,
!     ipl = integer array of dimension 6*ndp, where the
!           point numbers of the end points of the (il)th
!           border line segment and its respective triangle
!           number are to be stored as the (3*il-2)nd,
!           (3*il-1)st, and (3*il)th elements,
!           il=1,2,..., nl.
!     ierr = error indicator. ierr is set to 0 if no errors
!           are detected.
! the other parameters are
!     iwl = integer array of dimension 18*ndp used
!           internally as a work area,
!     iwp = integer array of dimension ndp used
!           internally as a work area,
!     wk  = array of dimension ndp used internally as a
!           work area.
!
  dimension xd(ndp), yd(ndp), ipt(*), ipl(*), &
            iwl(*), iwp(ndp), wk(ndp)
  dimension itf(2)
  data  ratio/1.0e-6/, nrep/100/
!
! statement functions
!
  dsqf(u1,v1,u2,v2)=(u2-u1)**2+(v2-v1)**2
  side(u1,v1,u2,v2,u3,v3)=(v3-v1)*(u2-u1)-(u3-u1)*(v2-v1)
!
! preliminary processing
  ndp0=ndp
  ndpm1=ndp0-1
  ierr=0
  if(ndp0 < 4)       go to 90
! determines the closest pair of data points and their midpoint.
  dsqmn=dsqf(xd(1),yd(1),xd(2),yd(2))
  ipmn1=1
  ipmn2=2
  do 22  ip1=1,ndpm1
    x1=xd(ip1)
    y1=yd(ip1)
    ip1p1=ip1+1
    do 21  ip2=ip1p1,ndp0
      dsqi=dsqf(x1,y1,xd(ip2),yd(ip2))
      if(dsqi==0.0)      go to 91
      if(dsqi >= dsqmn)    go to 21
      dsqmn=dsqi
      ipmn1=ip1
      ipmn2=ip2
   21   continue
   22 continue
  dsq12=dsqmn
  xdmp=(xd(ipmn1)+xd(ipmn2))/2.0
  ydmp=(yd(ipmn1)+yd(ipmn2))/2.0
! sorts the other (ndp-2) data points in ascending order of
! distance from the midpoint and stores the sorted data point
! numbers in the iwp array.
  jp1=2
  do 31  ip1=1,ndp0
    if(ip1==ipmn1.or.ip1==ipmn2)      go to 31
    jp1=jp1+1
    iwp(jp1)=ip1
    wk(jp1)=dsqf(xdmp,ydmp,xd(ip1),yd(ip1))
   31 continue
  do 33  jp1=3,ndpm1
    dsqmn=wk(jp1)
    jpmn=jp1
    do 32  jp2=jp1,ndp0
      if(wk(jp2) >= dsqmn)      go to 32
      dsqmn=wk(jp2)
      jpmn=jp2
   32   continue
    its=iwp(jp1)
    iwp(jp1)=iwp(jpmn)
    iwp(jpmn)=its
    wk(jpmn)=wk(jp1)
   33 continue
! if necessary, modifies the ordering in such a way that the
! first three data points are not collinear.
  ar=dsq12*ratio
  x1=xd(ipmn1)
  y1=yd(ipmn1)
  dx21=xd(ipmn2)-x1
  dy21=yd(ipmn2)-y1
  do 36  jp=3,ndp0
    ip=iwp(jp)
    if(abs((yd(ip)-y1)*dx21-(xd(ip)-x1)*dy21) > ar) &
                 go to 37
   36 continue
  go to 92
   37 if(jp==3)    go to 40
  jpmx=jp
  jp=jpmx+1
  do 38  jpc=4,jpmx
    jp=jp-1
    iwp(jp)=iwp(jp-1)
   38 continue
  iwp(3)=ip
! forms the first triangle.  stores point numbers of the ver-
! texes of the triangle in the ipt array, and stores point num-
! bers of the border line segments and the triangle number in
! the ipl array.
   40 ip1=ipmn1
  ip2=ipmn2
  ip3=iwp(3)
  if(side(xd(ip1),yd(ip1),xd(ip2),yd(ip2),xd(ip3),yd(ip3)) &
        >= 0.0)       go to 41
  ip1=ipmn2
  ip2=ipmn1
   41 nt0=1
  ntt3=3
  ipt(1)=ip1
  ipt(2)=ip2
  ipt(3)=ip3
  nl0=3
  nlt3=9
  ipl(1)=ip1
  ipl(2)=ip2
  ipl(3)=1
  ipl(4)=ip2
  ipl(5)=ip3
  ipl(6)=1
  ipl(7)=ip3
  ipl(8)=ip1
  ipl(9)=1
! adds the remaining (ndp-3) data points, one by one.
  do 79  jp1=4,ndp0
    ip1=iwp(jp1)
    x1=xd(ip1)
    y1=yd(ip1)
! - determines the visible border line segments.
    ip2=ipl(1)
    jpmn=1
    dxmn=xd(ip2)-x1
    dymn=yd(ip2)-y1
    dsqmn=dxmn**2+dymn**2
    armn=dsqmn*ratio
    jpmx=1
    dxmx=dxmn
    dymx=dymn
    dsqmx=dsqmn
    armx=armn
    do 52  jp2=2,nl0
      ip2=ipl(3*jp2-2)
      dx=xd(ip2)-x1
      dy=yd(ip2)-y1
      ar=dy*dxmn-dx*dymn
      if(ar > armn)       go to 51
      dsqi=dx**2+dy**2
      if(ar >= (-armn).and.dsqi >= dsqmn)      go to 51
      jpmn=jp2
      dxmn=dx
      dymn=dy
      dsqmn=dsqi
      armn=dsqmn*ratio
   51     ar=dy*dxmx-dx*dymx
      if(ar < (-armx))    go to 52
      dsqi=dx**2+dy**2
      if(ar <= armx.and.dsqi >= dsqmx)    go to 52
      jpmx=jp2
      dxmx=dx
      dymx=dy
      dsqmx=dsqi
      armx=dsqmx*ratio
   52   continue
    if(jpmx < jpmn)  jpmx=jpmx+nl0
    nsh=jpmn-1
    if(nsh <= 0)      go to 60
! - shifts (rotates) the ipl array to have the invisible border
! - line segments contained in the first part of the ipl array.
    nsht3=nsh*3
    do 53  jp2t3=3,nsht3,3
      jp3t3=jp2t3+nlt3
      ipl(jp3t3-2)=ipl(jp2t3-2)
      ipl(jp3t3-1)=ipl(jp2t3-1)
      ipl(jp3t3)  =ipl(jp2t3)
   53   continue
    do 54  jp2t3=3,nlt3,3
      jp3t3=jp2t3+nsht3
      ipl(jp2t3-2)=ipl(jp3t3-2)
      ipl(jp2t3-1)=ipl(jp3t3-1)
      ipl(jp2t3)  =ipl(jp3t3)
   54   continue
    jpmx=jpmx-nsh
! - adds triangles to the ipt array, updates border line
! - segments in the ipl array, and sets flags for the border
! - line segments to be reexamined in the iwl array.
   60   jwl=0
    do 64  jp2=jpmx,nl0
      jp2t3=jp2*3
      ipl1=ipl(jp2t3-2)
      ipl2=ipl(jp2t3-1)
      it  =ipl(jp2t3)
! - - adds a triangle to the ipt array.
      nt0=nt0+1
      ntt3=ntt3+3
      ipt(ntt3-2)=ipl2
      ipt(ntt3-1)=ipl1
      ipt(ntt3)  =ip1
! - - updates border line segments in the ipl array.
      if(jp2/=jpmx)      go to 61
      ipl(jp2t3-1)=ip1
      ipl(jp2t3)  =nt0
   61     if(jp2/=nl0)       go to 62
      nln=jpmx+1
      nlnt3=nln*3
      ipl(nlnt3-2)=ip1
      ipl(nlnt3-1)=ipl(1)
      ipl(nlnt3)  =nt0
! - - determines the vertex that does not lie on the border
! - - line segments.
   62     itt3=it*3
      ipti=ipt(itt3-2)
      if(ipti/=ipl1.and.ipti/=ipl2)   go to 63
      ipti=ipt(itt3-1)
      if(ipti/=ipl1.and.ipti/=ipl2)   go to 63
      ipti=ipt(itt3)
! - - checks if the exchange is necessary.
   63     if(idxchg(xd,yd,ip1,ipti,ipl1,ipl2)==0)     go to 64
! - - modifies the ipt array when necessary.
      ipt(itt3-2)=ipti
      ipt(itt3-1)=ipl1
      ipt(itt3)  =ip1
      ipt(ntt3-1)=ipti
      if(jp2==jpmx)      ipl(jp2t3)=it
      if(jp2==nl0.and.ipl(3)==it)     ipl(3)=nt0
! - - sets flags in the iwl array.
      jwl=jwl+4
      iwl(jwl-3)=ipl1
      iwl(jwl-2)=ipti
      iwl(jwl-1)=ipti
      iwl(jwl)  =ipl2
   64   continue
    nl0=nln
    nlt3=nlnt3
    nlf=jwl/2
    if(nlf==0)      go to 79
! - improves triangulation.
    ntt3p3=ntt3+3
    do 78  irep=1,nrep
      do 76  ilf=1,nlf
        ilft2=ilf*2
        ipl1=iwl(ilft2-1)
        ipl2=iwl(ilft2)
! - - locates in the ipt array two triangles on both sides of
! - - the flagged line segment.
        ntf=0
        do 71  itt3r=3,ntt3,3
          itt3=ntt3p3-itt3r
          ipt1=ipt(itt3-2)
          ipt2=ipt(itt3-1)
          ipt3=ipt(itt3)
          if(ipl1/=ipt1.and.ipl1/=ipt2.and. &
             ipl1/=ipt3)      go to 71
          if(ipl2/=ipt1.and.ipl2/=ipt2.and. &
             ipl2/=ipt3)      go to 71
          ntf=ntf+1
          itf(ntf)=itt3/3
          if(ntf==2)     go to 72
   71       continue
        if(ntf < 2)       go to 76
! - - determines the vertices of the triangles that do not lie
! - - on the line segment.
   72       it1t3=itf(1)*3
        ipti1=ipt(it1t3-2)
        if(ipti1/=ipl1.and.ipti1/=ipl2)    go to 73
        ipti1=ipt(it1t3-1)
        if(ipti1/=ipl1.and.ipti1/=ipl2)    go to 73
        ipti1=ipt(it1t3)
   73       it2t3=itf(2)*3
        ipti2=ipt(it2t3-2)
        if(ipti2/=ipl1.and.ipti2/=ipl2)    go to 74
        ipti2=ipt(it2t3-1)
        if(ipti2/=ipl1.and.ipti2/=ipl2)    go to 74
        ipti2=ipt(it2t3)
! - - checks if the exchange is necessary.
   74       if(idxchg(xd,yd,ipti1,ipti2,ipl1,ipl2)==0) &
           go to 76
! - - modifies the ipt array when necessary.
        ipt(it1t3-2)=ipti1
        ipt(it1t3-1)=ipti2
        ipt(it1t3)  =ipl1
        ipt(it2t3-2)=ipti2
        ipt(it2t3-1)=ipti1
        ipt(it2t3)  =ipl2
! - - sets new flags.
        jwl=jwl+8
        iwl(jwl-7)=ipl1
        iwl(jwl-6)=ipti1
        iwl(jwl-5)=ipti1
        iwl(jwl-4)=ipl2
        iwl(jwl-3)=ipl2
        iwl(jwl-2)=ipti2
        iwl(jwl-1)=ipti2
        iwl(jwl)  =ipl1
        do 75  jlt3=3,nlt3,3
          iplj1=ipl(jlt3-2)
          iplj2=ipl(jlt3-1)
          if((iplj1==ipl1.and.iplj2==ipti2).or. &
             (iplj2==ipl1.and.iplj1==ipti2)) &
                           ipl(jlt3)=itf(1)
          if((iplj1==ipl2.and.iplj2==ipti1).or. &
             (iplj2==ipl2.and.iplj1==ipti1)) &
                           ipl(jlt3)=itf(2)
   75       continue
   76     continue
      nlfc=nlf
      nlf=jwl/2
      if(nlf==nlfc)      go to 79
!
!  Resets the iwl array for the next round.
!
      jwl=0
      jwl1mn=(nlfc+1)*2
      nlft2=nlf*2
      do 77  jwl1=jwl1mn,nlft2,2
        jwl=jwl+2
        iwl(jwl-1)=iwl(jwl1-1)
        iwl(jwl)  =iwl(jwl1)
   77     continue
      nlf=jwl/2
   78   continue
   79 continue
! rearranges the ipt array so that the vertices of each triangle
! are listed counter-clockwise.
  do 81  itt3=3,ntt3,3
    ip1=ipt(itt3-2)
    ip2=ipt(itt3-1)
    ip3=ipt(itt3)
    if(side(xd(ip1),yd(ip1),xd(ip2),yd(ip2),xd(ip3),yd(ip3)) &
          >= 0.0)     go to 81
    ipt(itt3-2)=ip2
    ipt(itt3-1)=ip1
   81 continue
  nt=nt0
  nl=nl0
  return
!
!                        error return
!
!                     ndp is less than 4
   90 ierr=3
  nt=0
  return
!         points (xd(ip1),yd(ip1)) and (xd(ip2),yd(ip2))
!                 are equal or are too close
   91 ierr=7
  iwp(1)=ip1
  iwp(2)=ip2
  nt=0
  return
!             the points in xd,yd,zd are collinear
   92 ierr=8
  nt=0
  return
end
function idxchg(x,y,i1,i2,i3,i4)
!
!*******************************************************************************
!
!! IDXCHG determines whether or not the exchange of two triangles is necessary
!  on the basis of max-min-angle criterion
! by c. l. lawson.
! the input parameters are
!     x,y = arrays containing the coordinates of the data
!           points,
!     i1,i2,i3,i4 = point numbers of four points p1, p2,
!           p3, and p4 that form a quadrilateral with p3
!           and p4 connected diagonally.
! this function returns an integer value 1 (one) when an ex-
! change is necessary, and 0 (zero) otherwise.
!
  dimension   x(*), y(*)
  equivalence (c2sq,c1sq),(a3sq,b2sq),(b3sq,a1sq), &
              (a4sq,b1sq),(b4sq,a2sq),(c4sq,c3sq)
!
! preliminary processing
  x1=x(i1)
  y1=y(i1)
  x2=x(i2)
  y2=y(i2)
  x3=x(i3)
  y3=y(i3)
  x4=x(i4)
  y4=y(i4)
! calculation
  idx=0
  u3=(y2-y3)*(x1-x3)-(x2-x3)*(y1-y3)
  u4=(y1-y4)*(x2-x4)-(x1-x4)*(y2-y4)
  if(u3*u4 <= 0.0)    go to 10
  u1=(y3-y1)*(x4-x1)-(x3-x1)*(y4-y1)
  u2=(y4-y2)*(x3-x2)-(x4-x2)*(y3-y2)
  a1sq=(x1-x3)**2+(y1-y3)**2
  b1sq=(x4-x1)**2+(y4-y1)**2
  c1sq=(x3-x4)**2+(y3-y4)**2
  a2sq=(x2-x4)**2+(y2-y4)**2
  b2sq=(x3-x2)**2+(y3-y2)**2
  c3sq=(x2-x1)**2+(y2-y1)**2
  s1sq=u1*u1/(c1sq*max ( a1sq,b1sq))
  s2sq=u2*u2/(c2sq*max ( a2sq,b2sq))
  s3sq=u3*u3/(c3sq*max ( a3sq,b3sq))
  s4sq=u4*u4/(c4sq*max ( a4sq,b4sq))
  if(amin1(s1sq,s2sq) < amin1(s3sq,s4sq))     idx=1
   10 idxchg=idx
  return
end
subroutine iegs(kernel,rhfcn,a,b,ep,iflag,x,t,nt,nup,mup,ier, &
     cutoff,rootrt,unitrd,nhalf,lufact,kmm,kmn,knm,rhs,r,rh, &
     deln,tm,tn,xm,xmz,wm,wn,oldx,save,xn,save2,aside,aside3, &
     imknn)
!
!*******************************************************************************
!
!! IEGS controls the solution of the integral equation.
!
!
  real kernel,lufact,kmm,kmn,knm,imknn,normk,numr1,numr2
  integer flag,oldm,pivot(128)
  dimension x(*),t(*),lufact(nup,nup),kmm(nup,nup),rhs(mup), &
     knm(nhalf,nup),kmn(nup,nhalf),r(mup),rh(nup),deln(nup), &
     tm(mup),tn(nup),xm(mup),xmz(mup),wm(mup),wn(nup),oldx(mup), &
     save(mup),xn(nup),save2(mup),aside(nup,*),aside2(5), &
     aside3(nup,nup),imknn(nup,nup)
  common/xxlin/elinsy,relrsd,pivot
  common/xxinfo/r1,r2,finlep,normk,nfinal,mfinal
  external kernel,rhfcn
!
!   initialization
!
  loop=1
  n=2
  r2=0.5
  m=2*n
  r1rat=rootrt
  cond=1.0
  pastc=1.0
  pastre=0.0
  eps=ep
!
!   stage a. direct solution of linear system (i-kn)*xn=rhs, while
!   trying to find a good approximate inverse to implement
!   iterative method of solution.
!
!   create the nodes and weights tn(i) and wn(i), i=1,...,n
  call wandt(wn,tn,n,a,b)
!   set up matrix for (i-kn)*xn=rhfcn
  do 2 j=1,n
  do 1 i=1,n
1     imknn(i,j)=-wn(j)*kernel(tn(i),tn(j))
  xmz(j)=rhfcn(tn(j))
2     imknn(j,j)=imknn(j,j)+1.0
  go to 6
!   this is entrance for an increased value of n, using previously
!   stored values in kmm to define matrix for (i-kn)*xn=rhfcn with
!   new value of n.
3     do 5 j=1,n
  do 4 i=1,n
4     imknn(i,j)=-kmm(i,j)
  wn(j)=wm(j)
  tn(j)=tm(j)
  xmz(j)=rhs(j)
5     imknn(j,j)=imknn(j,j)+1.0
!   this is the entrance when iteration in stage b fails and we need
!   to increase n to obtain a better iterative rate.
6     continue
!   solve (i-kn)*xn=rhfcn at all tn(i).also obtain the lu
!   decomposition for later use in the stage b iterative method.
!
  call lnsys(imknn,lufact,nup,n,xmz,xn,2,ind)
!
!   lnsys is a general linear equation solver. it has special
!   options which are used in the following program. thus it
!   should not be replaced with another solver. lnsys is also
!   used in the subroutine itert.
!
  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  relmin=rmin(n,n,cond,unitrd,averr)
  if(loop == 1) go to 11
  if(loop == 2) go to 9
!   set up approximate rate of convergence of solutions xn to true
!   solution x. also set up desired ratio for iterative method.
  numr2=rnrm(xn,oldx,n,1)
  r2=amin1(0.5,max ( numr2/denr2,1.0e-4))
  r1rat=amin1(rootrt,sqrt(r2))
!   check for error in xn using test involving r2 and oldx,according
!   to theory for asymptotic error bounds. modify error if it is
!   outside precision range of computer, possibly due to
!   ill-conditioning.
8     error=(r2/(1.0-r2))*numr2
  xnorm=rnrm(xn,xn,n,0)
  relerr=error/xnorm
  if(iflag == 0) eps=max ( ep,xnorm*relmin)
  if(iflag == 1) eps=max ( ep,relmin)
  if(iflag == 1)error=max ( relerr,relmin)
  if((iflag == 0) .and. (relerr < relmin)) &
     error=relmin*xnorm
  if(error <= eps) go to 10
  denr2=numr2
  go to 11
!   entrance for loop=2.
9     numr2=rnrm(xn,oldx,n,1)
  denr2=0.0
  go to 8
!   exit for successful return. iteration was not necessary.
10    call leave(0,n,n,xn,tn,wn,error, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
!
!   attempt to solve (i-km)*xm=rhfcn iteratively, checking to see if
!   the rate of convergence is sufficiently fast so as to enter
!   stage b.
!
!   calculate tm(i) and wm(i), i=1,...,m.
11    call wandt(wm,tm,m,a,b)
  flag=0
!   calculate initial guess xmz for iteration method.
  call nsterp(tm,wm,xmz,m,tn,wn,xn,n, &
     kernel,rhfcn,rhs,kmn,nhalf,nup)
  do 12 i=1,m
12    oldx(i)=xmz(i)
!
!   calculate first iterate.
!
  call itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,flag)

  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  denr1=rnrm(xm,xmz,m,1)
  flag=1
  do 13 i=1,m
13    xmz(i)=xm(i)
!
!   calculate second iterate.
!
  call itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,flag)
  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  numr1=rnrm(xm,xmz,m,1)
!   check on the speed of convergence of iterative method. if it is
!   sufficiently rapid, then fix n and go to stage b.
  r1=max ( numr1/denr1,.0001)
  rate=r1
  if(m > nup) go to 19
  if(r1 <= r1rat) go to 15
!   the iteration did not work well enough, and stage a is to be
!   repeated. re-initialize for solving (i-kn)*xn=rhfcn again
!   with a larger n.
14    n=m
  loop=loop+1
  m=2*n
  go to 3
!   the iterative rate is sufficiently rapid, and control will go to
!   stage b. save information in case stage b aborts at a larger
!   value of m and stage a has to be returned to.
15    do 16 i=1,m
  aside(i,1)=oldx(i)
  aside(i,2)=wm(i)
  aside(i,3)=tm(i)
16    aside(i,4)=rhs(i)
  aside2(1)=loop
  aside2(3)=r2
  aside2(4)=denr2
  aside2(5)=r1rat
  do 17 j=1,m
  do 17 i=1,m
17    aside3(i,j)=kmm(i,j)
!
!   stage b. iterative method of solution of (i-km)*xm=rhs.
!
19    oldm=n
  aside2(2)=m
  if(r1 <= cutoff) go to 22
!   the iterates are converging very slowly or not at all. thus
!   return without further attempts to lessen the error.
  if(loop /= 1) go to 21
20    call leave(2,n,n,xn,tn,wn,0.0, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
21    call leave(1,n,n,xn,tn,wn,error, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
!   test to see if the current iterate xm is sufficiently accurate
!   compared to the true xm.
22    rate=r1*rate
  temp=rnrm(xm,oldx,m,1)
  if(loop == 1) temp2=0.5
  if(loop > 1) temp2=temp/denr2
  rt=  amin1(0.01,max ( temp2,0.0001))/2.0
  xnorm=rnrm(xm,xm,m,0)
  esterr=(rt/(1.0-rt))*temp/xnorm
  if(esterr < relmin) esterr=relmin
  esterr=esterr*xnorm
  test=((1.0-r1)/r1)*esterr
  if(numr1 <= test) go to 33
!   iterate not sufficiently accurate. initialize for computation
!   of another iterate.
25    denr1=numr1
  do 26 i=1,m
26    xmz(i)=xm(i)

  call itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,flag)
  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  numr1=rnrm(xm,xmz,m,1)
  r1=max ( numr1/denr1,.0001)
  if(r1 <= cutoff) go to 22
!   this is entrance for case where iteration fails in stage b.
!   parameters must be reset for a return to stage a or for an
!   abortive exit if n cannot be increased any further.
27    mnew=aside2(2)
  if(mnew > nup) go to 30
  n=mnew
  do 29 j=1,n
  do 28 i=1,n
28    imknn(i,j)=-aside3(i,j)
  oldx(j)=aside(j,1)
  wn(j)=aside(j,2)
  tn(j)=aside(j,3)
  xmz(j)=aside(j,4)
29    imknn(j,j)=imknn(j,j)+1.0
  m=2*n
  loop=aside2(1)+1.0
  r2=aside2(3)
  denr2=aside2(4)
  r1rat=aside2(5)
  go to 6
!   abortive exit from stage b. n cannot be increased further, and
!   r1 is not sufficiently small.
30    if(loop == 1) go to 20
  call wandt(wm,tm,oldm,a,b)
  call leave(1,n,oldm,save,tm,wm,error, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
!   an accurate value of xm has been obtained. r2 is to be tested as
!   to whether it should be reset. then check error in xm compared
!   with the true solution x.
33    if(loop == 1) go to 37
  numr2=temp
  r2=max ( 1.0e-4,rate,amin1(numr2/denr2,0.5))
  denr2=numr2
34    error=(r2/(1.0-r2))*temp
  xnorm=rnrm(xm,xm,m,0)
  relerr=error/xnorm
  relmin=rmin(n,m,cond,unitrd,averr)
  if(iflag == 0) eps=max ( ep,xnorm*relmin)
  if(iflag == 1) eps=max ( ep,relmin)
  if(iflag == 1)error=max ( relerr,relmin)
  if((iflag == 0) .and. (relerr < relmin)) &
     error=relmin*xnorm
  if(error > eps) go to 35
  call leave(0,n,m,xm,tm,wm,error, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
35    mnew=2*m
  if(mnew <= mup) go to 39
!   m cannot be increased any further.
  call leave(1,n,m,xm,tm,wm,error, &
     kernel,rhfcn,ep,iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm, &
     xmz,kmm,kmn,knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
  return
37    denr2=temp
  loop=2
  go to 34
!   error not sufficiently small. m is increased and two more
!   more iterates are computed with the new m.
39    oldm=m
  m=mnew
  do 41 i=1,oldm
  save2(i)=wm(i)
41    save(i)=tm(i)
  call wandt(wm,tm,m,a,b)
  flag=0
  call nsterp(tm,wm,xmz,m,save,save2,xm,oldm, &
     kernel,rhfcn,rhs,kmn,nhalf,nup)
  do 43 i=1,oldm
43    save(i)=xm(i)
  do 45 i=1,m
45    oldx(i)=xmz(i)
  call itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,flag)
  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  denr1=rnrm(xm,xmz,m,1)
  flag=1
  xmz(1:m) = xm(1:m)

  call itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,flag)
  cond=conew(cond,elinsy,relrsd,averr,pastc,pastre)
  numr1=rnrm(xm,xmz,m,1)
  r1=max ( numr1/denr1,.0001)
  rate=r1
  if(r1 <= cutoff) go to 22
  go to 27
end
subroutine ieslv (kernel,rhfcn,a,b,ep,iflag,t,x,nt,nupper, &
                       mupper,nf,mf,norm,w,ier)
!
!*******************************************************************************
!
!! IESLV solves an integral equation.
!
!
!   the integral equation being solved is
!
!                     b
!          x(s) -  int  kernel(s,t)*x(t)*dt = rhfcn(s)
!                     a
!
!   the method being used is based on the nystrom method with
!   gaussian quadrature, with an iterative technique of solution
!   for the resulting linear system.
!
!   kernel     these are real functions of two and one
!   rhfcn      variables, respectively. they must be declared in an
!              external statement in the program calling ieslv.
!   ep         the desired error. the variable ep is changed on
!              completion of the program. see the discussion of ier
!              and iflag for more information.
!   iflag =0   ep is interpreted as an absolute error tolerance.
!         =1   ep is interpreted as a relative error tolerance.
!   t          contains the node points at which the solution of the
!              integral equation is desired. see the variable nt for
!              more information.
!   x          the computed approximate solution of the integral
!              equation, evaluated at the node points in t, is
!              stored in x on completion of the routine. this is
!              true irregardless of whether or not the desired error
!              tolerance was attained.
!   nt         if nt=0, then t and x will be set equal to the final
!              gaussian nodes and the corresponding solution values,
!              and nt will be set to the number of the solution
!              values stored in x and t. the arrays t and x should
!              have dimension at least mupper, assigned in the
!              calling program.
!              if nt > 0, then t contains nt user supplied nodes
!              at which the solution x is desired.
!   nupper     an upper limit on the variable n in this program.
!              n is the order of a linear system which is being
!              used to iteratively solve a larger linear system of
!              order m which approximates the integral equation.
!              (for further details concerning the maximum value
!              that n can take, see the description of nmax below.)
!   mupper     an upper limit on the variable m in the program.
!              n and m are always powers of two.
!   nf         same as nfinal (see below)
!   mf         same as mfinal (see below)
!   norm       same as normk (see below)
!   w          temporary working storage for the program. it must
!              contain at least 5*nu*nu+9*(nu+mu) positions, with
!              nu=nupper, mu=mupper.
!   ier =0     this error completion code means the routine was
!              completed satisfactorily. ep contains the predicted
!              error.
!       =1     the error test was not satisfied. ep contains the
!              predicted error.
!       =2     the error test was not satisfied. ep has been set
!              to zero.
!       =3     the original value of ep was too small, due to
!              possible ill-conditioning problems in the integral
!              equation. the value of ep was reset to a more
!              realistic value, and that tolerance was attained.
!       =4     the error was satisfactory at the gaussian node
!              points (ier=0), but the interpolation process(due to
!              nt > 0) may not preserve this accuracy. check the
!              value of norm(k) for possible indications that the
!              integral equation may be almost first kind. such
!              equations are quite ill-conditioned. the error in ep
!              is the predicted error for the solution at the
!              gaussian node points of order mfinal.
!       =5     the analogue of ier=4, but with ier=1 at the
!              gaussian node points.
!       =6     the analogue of ier=4, but with ier=3 at the
!              gaussian node points.
!
!
!   *** references ***
!   (1) an automatic program for fredholm integral equations of the
!       second kind, acm trans. math software 2(1976), pp.154-171.
!   (2) a survey of numerical methods for the solution of fredholm
!       integral equations of the second kind, siam pub., 1976,
!       part ii, chap. 5.
!
  real kernel,norm,normk
  dimension x(*),t(*),w(*)
  external kernel,rhfcn
!
!                                                                  
  common/xxinfo/r1,r2,finlep,normk,nfinal,mfinal
!                                                                  
!   the numbers in xxinfo give additional information about the    
!   functioning of ieslv. r1 is the iterative rate of convergence  
!   in the most recently computed linear system. r2 is the rate of 
!   convergence of the gaussian quadrature variant of the nystrom  
!   method. finlep is the final value of ep used as the desired    
!   error tolerance. usually finlep will equal the input value of  
!   ep, unless ep was much too small. normk is an approximate      
!   value for the norm of the integral operator k, and it is       
!   calculated only if nt > 0.                                  
!   nfinal and mfinal are the final values of n and m used in      
!   ieslv.  if nfinal=mfinal, then iteration was not invoked       
!   successfully.                                                  
!                                                                  
!                                                                  
!   nmax is the maximum value for n that is permitted by ieslv.    
!   thus min (nupper,nmax) is the maximum value for n that can be  
!   used. there is also an upper limit of 128 on n imposed by the  
!   subroutine lnsys.                                              
!                                                                  
          data nmax /64/
!                                                                  
  unitrd = epsilon ( unitrd )
  cutoff = 0.5
  rootrt = 0.1
  nup = min (nupper,nmax)
!
!   set up the relative base addresses for the various arrays into
!   which w is to be split.
!
  n=nup
  m=mupper
  nsq=n*n
  i1=1
  i2=i1+nsq
  i3=i2+nsq
  i4=i3+nsq/2
  i5=i4+nsq/2
  i6=i5+m
  i7=i6+m
  i8=i7+n
  i9=i8+n
  i10=i9+m
  i11=i10+n
  i12=i11+m
  i13=i12+m
  i14=i13+m
  i15=i14+n
  i16=i15+m
  i17=i16+m
  i18=i17+n
  i19=i18+m
  i20=i19+4*n
  i21=i20+nsq
  nhalf=n/2
  call iegs(kernel,rhfcn,a,b,ep,iflag,x,t,nt,nup,mupper,ier, &
     cutoff,rootrt,unitrd,nhalf,w(i1),w(i2),w(i3),w(i4),w(i5), &
     w(i6),w(i7),w(i8),w(i9),w(i10),w(i11),w(i12),w(i13), &
     w(i14),w(i15),w(i16),w(i17),w(i18),w(i19),w(i20),w(i21))
  norm=normk
  nf=nfinal
  mf=mfinal
  return
end
subroutine imc(z, i1, i2, i1m, i2m)
!
!*******************************************************************************
!
!! IMC calculates the modified Bessel function of the first kind
!  for orders 1/3, 2/3, -1/3, and -2/3 and for complex
!     argument z. the maclaurin expansion and backward recurrence
!     are used. i1 and i2 are replaced by the functions of orders
!     1/3 and 2/3, respectively, and i1m and i2m by the functions
!     of orders -1/3 and -2/3, respectively.  for greatest
!     accuracy, z should lie in the region real(z) >= 0.
!
  complex z,ia1,ia2,ia3,ib1,ib2,ib3,i1,i2,i1m,i2m,sz,zh,e, &
          cf1,cf2,cf3,cf4
  real m
!
!     gm1 = gamma(4.0/3.0)
!     gm2 = gamma(5.0/3.0)
!
  data c1/.333333333333333e+00/
  data c2/.666666666666667e+00/
  data gm1/.892979511569248e+00/
  data gm2/.902745292950932e+00/
  zh = 0.5*z
  sz = zh*zh
  a = real(zh)
  b = aimag(zh)
  an = aint(a*a + b*b)
  cn1 = c1 + an
  cn2 = c2 + an
!
!     calculation of initial values for backward recurrence by
!     use of the maclaurin expansion.
!
  call bim(z, cn1, ia1)
  call bim(z, cn1 + 1.0, ia2)
  call bim(z, cn2, ib1)
  call bim(z, cn2 + 1.0, ib2)
!
!     backward recurrence
!
  n = an
  m = an
  n1 = n + 1
  do 10 i = 1, n1
     ia3 = ia2
     ia2 = ia1
     ib3 = ib2
     ib2 = ib1
     cfa = (m + c1)*(m + c1 + 1.0)
     cfb = (m + c2)*(m + c2 + 1.0)
     m = m - 1.0
     ia1 = ia2 + (sz/cfa)*ia3
   10    ib1 = ib2 + (sz/cfb)*ib3
  e = cexp(c1*clog(zh))
  cf1 = e/gm1
  cf2 = e*e/gm2
  cf3 = c2*cf2/zh
  cf4 = c1*cf1/zh
  i1 = cf1*ia2
  i2 = cf2*ib2
  i1m = cf3*ib1
  i2m = cf4*ia1
  return
end
subroutine imtql1(n,d,e,ierr)
!
!*******************************************************************************
!
!! IMTQL1 finds the eigenvalues of a symmetric tridiagonal matrix
!  by the implicit ql method.
!
!     on input-
!
!        n is the order of the matrix,
!
!        d contains the diagonal elements of the input matrix,
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!      on output-
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct and
!          ordered for indices 1,2,...ierr-1, but may not be
!          the smallest eigenvalues,
!
!        e has been destroyed,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
  integer i,j,l,m,n,ii,mml,ierr
  real d(n),e(n)
  real b,c,f,g,p,r,s,machep
!
  machep = epsilon ( machep )
  ierr = 0
  if (n == 1) go to 1001
!
  do 100 i = 2, n
  100 e(i-1) = e(i)
!
  e(n) = 0.0
!
  do 290 l = 1, n
     j = 0
! look for small sub-diagonal element
  105    do 110 m = l, n
        if (m == n) go to 120
        if (abs(e(m)) <= machep * (abs(d(m)) + abs(d(m+1)))) &
           go to 120
  110    continue
!
  120    p = d(l)
     if (m == l) go to 215
     if (j == 30) go to 1000
     j = j + 1
! form shift
     g = (d(l+1) - p) / (2.0 * e(l))
     r = sqrt(g*g+1.0)
     if (g < 0.0) r = -r
     g = d(m) - p + e(l) / (g + r)
     s = 1.0
     c = 1.0
     p = 0.0
     mml = m - l
!   for i=m-1 step -1 until l do --
     do 200 ii = 1, mml
        i = m - ii
        f = s * e(i)
        b = c * e(i)
        if (abs(f) < abs(g)) go to 150
        c = g / f
        r = sqrt(c*c+1.0)
        e(i+1) = f * r
        s = 1.0 / r
        c = c * s
        go to 160
  150       s = f / g
        r = sqrt(s*s+1.0)
        e(i+1) = g * r
        c = 1.0 / r
        s = s * c
  160       g = d(i+1) - p
        r = (d(i) - g) * s + 2.0 * c * b
        p = s * r
        d(i+1) = g + p
        g = c * r - b
  200    continue
!
     d(l) = d(l) - p
     e(l) = g
     e(m) = 0.0
     go to 105
!  order eigenvalues
  215    if (l == 1) go to 250
!   for i=l step -1 until 2 do --
     do 230 ii = 2, l
        i = l + 2 - ii
        if (p >= d(i-1)) go to 270
        d(i) = d(i-1)
  230    continue
!
  250    i = 1
  270    d(i) = p
  290 continue
!
  go to 1001
! set error -- no convergence to an
!                eigenvalue after 30 iterations
 1000 ierr = l
 1001 return
end
subroutine imtql2(nm,n,d,e,z,ierr)
!
!*****************************************************************************80
!
!! IMTQL2 finds eigenvalues and eigenvectors of a symmetric tridiagonal matrix
!  by the implicit ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        d contains the diagonal elements of the input matrix,
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary,
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output-
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1,
!
!        e has been destroyed,
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
  integer i,j,k,l,m,n,ii,nm,mml,ierr
  real d(n),e(n),z(nm,n)
  real b,c,f,g,p,r,s,machep
!
  machep = epsilon ( machep )
  ierr = 0
  if (n == 1) go to 1001
!
  do 100 i = 2, n
  100 e(i-1) = e(i)
!
  e(n) = 0.0
!
  do 240 l = 1, n
     j = 0
!    look for small sub-diagonal element
  105    do 110 m = l, n
        if (m == n) go to 120
        if (abs(e(m)) <= machep * (abs(d(m)) + abs(d(m+1)))) &
           go to 120
  110    continue
!
  120    p = d(l)
     if (m == l) go to 240
     if (j == 30) go to 1000
     j = j + 1
!    form shift
     g = (d(l+1) - p) / (2.0 * e(l))
     r = sqrt(g*g+1.0)
     if (g < 0.0) r = -r
     g = d(m) - p + e(l) / (g + r)
     s = 1.0
     c = 1.0
     p = 0.0
     mml = m - l
!   for i=m-1 step -1 until l do
     do 200 ii = 1, mml
        i = m - ii
        f = s * e(i)
        b = c * e(i)
        if (abs(f) < abs(g)) go to 150
        c = g / f
        r = sqrt(c*c+1.0)
        e(i+1) = f * r
        s = 1.0 / r
        c = c * s
        go to 160
  150       s = f / g
        r = sqrt(s*s+1.0)
        e(i+1) = g * r
        c = 1.0 / r
        s = s * c
  160       g = d(i+1) - p
        r = (d(i) - g) * s + 2.0 * c * b
        p = s * r
        d(i+1) = g + p
        g = c * r - b
!   form vector
        do 180 k = 1, n
           f = z(k,i+1)
           z(k,i+1) = s * z(k,i) + c * f
           z(k,i) = c * z(k,i) - s * f
  180       continue
!
  200    continue
!
     d(l) = d(l) - p
     e(l) = g
     e(m) = 0.0
     go to 105
  240 continue
!  order eigenvalues and eigenvectors
  do 300 ii = 2, n
     i = ii - 1
     k = i
     p = d(i)
!
     do 260 j = ii, n
        if (d(j) >= p) go to 260
        k = j
        p = d(j)
  260    continue
!
     if (k == i) go to 300
     d(k) = d(i)
     d(i) = p
!
     do 280 j = 1, n
        p = z(j,i)
        z(j,i) = z(j,k)
        z(j,k) = p
  280    continue
!
  300 continue
!
  go to 1001
!  set error -- no convergence to an
!                eigenvalue after 30 iterations
 1000 ierr = l
 1001 return
end
subroutine incdg(degree,alpha,psi,indexs,newkj, &
                   sumsqs,coord,ncrows,npolys, &
                   dimen,npts,f,z,c,psiwid,weight, &
                   alfl,onplys,sttdeg,error)
!
!*******************************************************************************
!
!! INCDG is a utility routine for gnrtp, and is not called by the user.
!
!
!     the multinomial fit is generated incrementally, a basis  element
!     at a time.  this subroutine continues the process started off by
!      gnrtp .
!
!     this subroutine is called by  gnrtp  and not by the user.
!
!
!     modified by a.h. morris (nswc)
!
  integer jprime,p,j,curdeg,kj,kjp,l,jpm1,jm1
  integer m,start,jindex,jpindx,q,j3,j1,j1mj2,error
  integer j0mj1,j1m1,starta,onplys,onpp1,sttdeg,index1,index2
  integer degree,npolys,npts,dimen,psiwid,alfl
  integer indexs(4,npolys),newkj(dimen,degree)
  real    alpha(alfl),coord(ncrows,dimen),psi(npts,psiwid)
  real    sumsqs(npolys),c(npolys),f(npts),weight(npts)
  real    z(npts)
  real    arc,runtot,rntot1,rntot2
!
  if ( onplys >= 1 .and. sttdeg >= 1 ) go to 10
     error = 6
  return
 10      if ( indexs(2,onplys) == dimen ) go to 20
        curdeg = sttdeg
     go to 30
 20         curdeg = sttdeg + 1
 30   onpp1 = onplys + 1
  do 170 j = onpp1,npolys
     jprime = indexs(1,j)
     jindex = j - ((j - 1) / psiwid) * psiwid
     jpindx = jprime - ((jprime - 1) / psiwid) * psiwid
     kj = indexs(2,j)
     start = indexs(3,j)
     m = start
     starta = indexs(4,j) - start
     if ( curdeg == 1 ) go to 100
     kjp = indexs(2,jprime)
     j1 = newkj(kj,curdeg - 1)
!
!     calculate those  alpha ( j , m ) that can be calculated from
!     previously calculated alphas.
!
     if ( kj < kjp ) go to 50
!
!     first calculate those between  jpp  and the end of 2 rows back.
!     calculate  alpha ( j , jpp )
!
     index1 = indexs(4,j)
     alpha(index1) = sumsqs(jprime) / sumsqs(start)
!
     m = start + 1
     j3 = newkj(1,curdeg - 1) - 1
     if ( m > j3 ) go to 50
!
!     curdeg > 2 if control has passed the branches in the 3-rd
!     previous and 8-th previous statements.
!
        j1mj2 = j1 - newkj(kj,curdeg - 2)
!
        do 40 l = m,j3
           q = j1mj2 + l
           index1 = starta + l
           index2 = indexs(4,q) - indexs(3,q) + jprime
 40            alpha(index1) = alpha(index2) * sumsqs(jprime) / &
           sumsqs(l)
!
!     calculate  alpha ( j , m ) for  m  between the 2
!     ranges calculated before using
!
!        alpha ( j , l ) = (x(k(j))  *  psi(jp)  ,psi(l) )  / (psi(l) ,psi(l) )
!
     m = j3 + 1
 50      if ( jprime == j1 ) go to 100
        if ( kj == 1 ) go to 80
        j1m1 = j1 - 1
        do 70 l = m,j1m1
           runtot = 0.0
           do 60 p = 1,npts
              index1 = l - ((l - 1) / psiwid) * psiwid
 60               runtot = runtot + coord(p,kj) * psi(p,jpindx) * &
              psi(p,index1) * weight(p)
           index1 = starta + l
 70            alpha(index1) = runtot / sumsqs(l)
!
!     calculate  alpha ( j , m ) for  m  between
!      newkj ( kj , curdeg  - 1)  and
!      jp  - 1.
!
 80         j0mj1 = newkj(kj,curdeg) - j1
        jpm1 = jprime - 1
        do 90 l = j1,jpm1
           q = j0mj1 + l
           index1 = starta + l
           index2 = indexs(4,q) - indexs(3,q) + jprime
 90            alpha(index1) = alpha(index2) * sumsqs(jprime) / &
           sumsqs(l)
        m = jprime
!
!     calculate the remaining  alpha ( j , m ) from
!
!      alpha ( j , l ) = (x(k(j))  * psi(jp)  ,psi(l) ) / (psi(l) ,psi(l) )
!
 100     jm1 = j - 1
     do 120 l = m,jm1
        runtot = 0.0
        do 110 p = 1,npts
           index1 = l - ((l - 1) / psiwid) * psiwid
 110           runtot = runtot + coord(p,kj) * psi(p,jpindx) * &
           psi(p,index1) * weight(p)
        index1 = starta + l
 120        alpha(index1) = runtot / sumsqs(l)
!
!     now calculate the  psi (p,j),  sumsqs (j) and  c (j) using
!
!     psi(j) = x(k) * psi(jp)   -  sum jpp <= l <= j-1 ) alpha(j,l) * psi(l)
!     sumsqs(j)  = (psi(j) ,psi(j) )
!     c(j)  = (z,psi(j) )
!
 130      jm1 = j - 1
      arc = 0.0
      rntot1 = 0.0
      rntot2 = 0.0
      do 150 p = 1,npts
          runtot = coord(p,kj) * psi(p,jpindx)
          do 140 l = start,jm1
             index1 = starta + l
             index2 = l - ((l - 1) / psiwid) * psiwid
 140             runtot = runtot - alpha(index1) * psi(p,index2)
          psi(p,jindex) = runtot
          arc = arc + psi(p,index2) * psi(p,jindex) * &
                            weight(p)
          rntot1 = rntot1 + psi(p,jindex) * psi(p,jindex) * &
                            weight(p)
 150          rntot2 = rntot2 + z(p) * psi(p,jindex) * weight(p)
      if (arc * arc >= sumsqs(jm1) * rntot1 * 1.e-03) &
          go to 200
      sumsqs(j) = rntot1
      c(j) = rntot2 / rntot1
!
!     calculate the new  z ( p ) and the new  ssres  using
!
!     z = z - c(j)  * psi(j)
!
      do 160 p = 1,npts
 160          z(p) = z(p) - c(j) * psi(p,jindex)
      sttdeg = curdeg
 170      if ( kj == dimen ) curdeg = curdeg + 1
  return
!
!     the j-th basis multinomial cannot be computed accurately.
!     only j - 1 basis multinomials are generated.
!
 200  error = -1
  degree = sttdeg
  npolys = jm1
  return
end
subroutine indxa (i,ir,idxa,na)
!
!*******************************************************************************
!
!! INDXA ???
!
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  na = 2**ir
  idxa = i-na+1
  if (i-nm)  20, 20, 10
   10 na = 0
   20 return
end
subroutine indxb (i,ir,idx,idp)
!
!*******************************************************************************
!
!! INDXB ???
!
! b(idx) is the location of the first root of the b(i,ir) polynomial
!
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  idp = 0
  if (ir)  70, 10, 30
   10 if (i-nm)  20, 20, 70
   20 idx = i
  idp = 1
  return
   30 izh = 2**ir
  id = i-izh-izh
  idx = id+id+(ir-1)*ik+ir+(ik-i)/izh+4
  ipl = izh-1
  idp = izh+izh-1
  if (i-ipl-nm)  50, 50, 40
   40 idp = 0
  return
   50 if (i+ipl-nm)  70, 70, 60
   60 idp = nm+ipl-i+1
   70 return
end
subroutine indxc (i,ir,idxc,nc)
!
!*******************************************************************************
!
!! INDXC ???
!
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  nc = 2**ir
  idxc = i
  if (idxc+nc-1-nm)  20, 20, 10
   10 nc = 0
   20 return
end
subroutine infctr ( n, ifact, ipower, nexp, npower)
!
!*******************************************************************************
!
!! INFCTR factors n into its prime powers, npower in number.
!
!
! e.g., for n=1960=2**3 *5 *7**2, npower=3, ifact=2,5,7,
! ipower=8,5,49, and nexp=3,1,2.
!
!  Parameters:
!
!    Input, integer N, the number to be factored.
!
  integer ifact(*)
  integer ip
  integer ipower(*)
  integer n
  integer nexp(*)
!
  ip = 0
  ifcur = 0
  npart = n
  idiv = 2
   10 iquot = npart/idiv
  if (npart-idiv*iquot) 60, 20, 60
   20 if (idiv-ifcur) 40, 40, 30
   30 ip = ip + 1
  ifact(ip) = idiv
  ipower(ip) = idiv
  ifcur = idiv
  nexp(ip) = 1
  go to 50
   40 ipower(ip) = idiv*ipower(ip)
  nexp(ip) = nexp(ip) + 1
   50 npart = iquot
  go to 10
   60 if (iquot-idiv) 100, 100, 70
   70 if (idiv-2) 80, 80, 90
   80 idiv = 3
  go to 10
   90 idiv = idiv + 2
  go to 10
  100 if (npart-1) 140, 140, 110
  110 if (npart-ifcur) 130, 130, 120
  120 ip = ip + 1
  ifact(ip) = npart
  ipower(ip) = npart
  nexp(ip) = 1
  go to 140
  130 ipower(ip) = npart*ipower(ip)
  nexp(ip) = nexp(ip) + 1
  140 npower = ip
  return
end
subroutine intrp(x,y,xout,yout,ypout,neqn,kold,phi,psi)
!
!*******************************************************************************
!
!! INTRP is used by step1 to evaluate the interpolating polynomial at a point.
!
!
!   written by l. f. shampine and m. k. gordon
!
!   abstract
!
!   the methods in subroutine  step1  approximate the solution near  x
!   by a polynomial.  subroutine  intrp  approximates the solution at
!   xout  by evaluating the polynomial there.  information defining this
!   polynomial is passed from  step1  so  intrp  cannot be used alone.
!
!   this code is completely explained and documented in the text,
!   computer solution of ordinary differential equations,  the initial
!   value problem  by l. f. shampine and m. k. gordon.
!
!   input to intrp --
!
!   the user provides storage in the calling program for the arrays in
!   the call list
!      dimension y(neqn),yout(neqn),ypout(neqn),phi(neqn,16),psi(12)
!   and defines
!      xout -- point at which solution is desired.
!   the remaining parameters are defined in  step1  and passed to  intrp
!   from that subroutine.
!
!   output from  intrp --
!
!      yout(*) -- solution at  xout
!      ypout(*) -- derivative of solution at  xout
!   the remaining parameters are returned unaltered from their input
!   values.  integration with  step1  may be continued.
!
  dimension y(neqn),yout(neqn),ypout(neqn),phi(neqn,16),psi(12)
  dimension g(13),w(13),rho(13)
  data g(1)/1.0/,rho(1)/1.0/
!
  hi = xout - x
  ki = kold + 1
  kip1 = ki + 1
!
!   initialize w(*) for computing g(*)
!
  do 5 i = 1,ki
    temp1 = i
 5      w(i) = 1.0/temp1
  term = 0.0
!
!   compute g(*)
!
  do 15 j = 2,ki
    jm1 = j - 1
    psijm1 = psi(jm1)
    gamma = (hi + term)/psijm1
    eta = hi/psijm1
    limit1 = kip1 - j
    do 10 i = 1,limit1
 10       w(i) = gamma*w(i) - eta*w(i+1)
    g(j) = w(1)
    rho(j) = gamma*rho(jm1)
 15     term = psijm1
!
!   interpolate
!
  do 20 l = 1,neqn
    ypout(l) = 0.0
 20     yout(l) = 0.0
  do 30 j = 1,ki
    i = kip1 - j
    temp2 = g(i)
    temp3 = rho(i)
    do 25 l = 1,neqn
      yout(l) = yout(l) + temp2*phi(l,i)
 25       ypout(l) = ypout(l) + temp3*phi(l,i)
 30     continue
  do 35 l = 1,neqn
 35     yout(l) = y(l) + hi*yout(l)
  return
end
function intrvl (t,x,n)
!
!*******************************************************************************
!
!! INTRVL seeks to bracket a value using an array of increasing values.
!
!
! on input--
!
!   t is a real number.
!
!   x is a vector of strictly increasing values.
!
!   n is the length of x (n >= 2).
!
! on output--
!
!   intrvl returns an integer i such that
!
!          i = 1       if             t < x(2)
!          i = n-1     if x(n-1) <= t
!          otherwise       x(i)  <= t < x(i+1)
!
! none of the input parameters are altered.
!
  integer n
  real t,x(n)
!
  nm1 = n-1
  if (t < x(2)) go to 50
  if (t >= x(nm1)) go to 60
  il = 2
  ir = nm1
!
! bisection search
!
   10 i = (il+ir)/2
  if (i==il) go to 40
  if (t-x(i)) 20,40,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
   40 intrvl = i
  return
!
! left end
!
   50 intrvl = 1
  return
!
! right end
!
   60 intrvl = nm1
  return
end
subroutine intyd (t, k, yh, nyh, dky, iflag)
!
!*****************************************************************************80
!
!! INTYD approximates solution and derivatives at t by polynomial interpolation.
!
!  must be used in conjunction with the integrator
!   package sfode.
!
! intyd computes interpolated values of the k-th derivative of the
! dependent variable vector y, and stores it in dky.
! this routine is called by stfode with k = 0,1 and t = tout, but may
! also be called by the user for any k up to the current order.
! (see detailed instructions in lsode usage documentation.)
!
! the computed values in dky are gotten by interpolation using the
! nordsieck history array yh.  this array corresponds uniquely to a
! vector-valued polynomial of degree nqcur or less, and dky is set
! to the k-th derivative of this polynomial at t.
! the formula for dky is..
!              q
!  dky(i)  =  sum  c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1)
!             j=k
! where  c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur.
! the quantities  nq = nqcur, l = nq+1, n = neq, tn, and h are
! communicated by common.  the above sum is done in reverse order.
! iflag is returned negative if either k or t is out of bounds.
!
  integer k, nyh, iflag, i, ic, ier, iownd, iowns, j, jb, jb2, &
     jj, jj1, jp1, jstart, kflag, l, maxord, meth, miter, n, nfe, &
     nje, nq, nqu, nst
  real t, yh, dky, &
     rownd, rowns, el0, h, hmin, hmxi, hu, tn, uround, &
     c, r, s, tp
  dimension yh(nyh,*), dky(*)
  common /debdf1/ rownd, rowns(210), &
     el0, h, hmin, hmxi, hu, tn, uround, iownd(14), iowns(6), &
     ier, jstart, kflag, l, meth, miter, maxord, n, nq, nst, nfe, &
     nje, nqu
!
  iflag = 0
  if (k < 0 .or. k > nq) go to 80
  tp = tn - hu*(1.0e0 + 100.0e0*uround)
  if ((t-tp)*(t-tn) > 0.0e0) go to 90
!
  s = (t - tn)/h
  ic = 1
  if (k == 0) go to 15
  jj1 = l - k
  do 10 jj = jj1,nq
 10     ic = ic*jj
 15   c = real(ic)
  do 20 i = 1,n
 20     dky(i) = c*yh(i,l)
  if (k == nq) go to 55
  jb2 = nq - k
  do 50 jb = 1,jb2
    j = nq - jb
    jp1 = j + 1
    ic = 1
    if (k == 0) go to 35
    jj1 = jp1 - k
    do 30 jj = jj1,j
 30       ic = ic*jj
 35     c = real(ic)
    do 40 i = 1,n
 40       dky(i) = c*yh(i,jp1) + s*dky(i)
 50     continue
  if (k == 0) return
 55   r = h**(-k)
  do 60 i = 1,n
 60     dky(i) = r*dky(i)
  return
!
 80   iflag = -1
  return
 90   iflag = -2
  return
end
subroutine ipath (i, j, subr, rbus, ar, pr, s, n, np, i1, i2, k, &
   jr, m, np1)
!
!*******************************************************************************
!
!! IPATH finds the start and end vertices of the largest path of implied arcs.
!
!
!  i1 and i2 are the start and end.  the arc (i,j) is to be contained in
!  the path.
!
!
! meaning of the output parameter  np ...
!
! np =  0  if the path contains  l < n  vertices.
!    =  1  if the path contains  n  vertices and arc (i2,i1)
!          exists (the hamiltonian circuit is stored in  s )
!    = -1  if the path contains  n  vertices but arc (i2,i1)
!          does not exist.
!
  integer m
  integer n
!
  integer ar(m)
  integer subr(n), rbus(n), pr(np1), s(n)
!
  np = 0
  l = 1
  i1 = i

  do while ( rbus(i1) /= 0 ) 
    i1 = rbus(i1)
    l = l + 1
  end do

  i2 = j
  l = l + 1

30 continue

  if (subr(i2)==0) go to 40
  i2 = -subr(i2) + (subr(i2)/np1)*np1
  l = l + 1
  go to 30

40 continue

  if ( l < n ) then
    return
  end if
!
!  The path contains  n  vertices.
!
  k1 = -k*np1
  l1 = pr(i2) + 1
  l2 = pr(i2+1)

  do 60 l=l1,l2
    if (ar(l) < 0) go to 50
    if (ar(l)==i1) go to 70
    go to 60
   50   if (k1-ar(l)==i1) go to 70
   60 continue
!
!  No hamiltonian circuit can be determined.
!
  np = -1
  return
!
! a hamiltonian circuit exists. store it in  s .
!
70 continue

  np = 1
  rbus(j) = i
  rbus(i1) = i2
  s(n) = rbus(jr)
  l = n - 1

   80 continue

  if (l==k) go to 90
  ja = s(l+1)
  s(l) = rbus(ja)
  l = l - 1
  go to 80

   90 rbus(i1) = 0
  rbus(j) = 0

  return
end
function ipmpar (i)
!
!*******************************************************************************
!
!! IPMPAR provides the integer machine constants for the computer that is used.
!  it is assumed that the argument i is an integer
!     having one of the values 1-10. ipmpar(i) has the value ...
!
!  integers.
!
!     assume integers are represented in the n-digit, base-a form
!
!               sign ( x(n-1)*a**(n-1) + ... + x(1)*a + x(0) )
!
!               where 0 <= x(i) < a for i=0,...,n-1.
!
!     ipmpar(1) = a, the base.
!
!     ipmpar(2) = n, the number of base-a digits.
!
!     ipmpar(3) = a**n - 1, the largest magnitude.
!
!  floating-point numbers.
!
!     it is assumed that the single and double precision floating
!     point arithmetics have the same base, say b, and that the
!     nonzero numbers are represented in the form
!
!               sign (b**e) * (x(1)/b + ... + x(m)/b**m)
!
!               where x(i) = 0,1,...,b-1 for i=1,...,m,
!               x(1) >= 1, and emin <= e <= emax.
!
!     ipmpar(4) = b, the base.
!
!  single-precision
!
!     ipmpar(5) = m, the number of base-b digits.
!
!     ipmpar(6) = emin, the smallest exponent e.
!
!     ipmpar(7) = emax, the largest exponent e.
!
!  double-precision
!
!     ipmpar(8) = m, the number of base-b digits.
!
!     ipmpar(9) = emin, the smallest exponent e.
!
!     ipmpar(10) = emax, the largest exponent e.
!
!
!
!     to define this function for the computer being used, activate
!     the data statments for the computer by removing the c from
!     column 1. (all the other data statements should have c in
!     column 1.)
!
!     if data statements are not given for the computer being used,
!     then the fortran manual for the computer normally gives the
!     constants ipmpar(1), ipmpar(2), and ipmpar(3) for the integer
!     arithmetic. however, help may be needed to obtain the constants
!     ipmpar(4),...,ipmpar(10) for the single and double precision
!     arithmetics. the subroutines mach and radix are provided for
!     this purpose.
!
!
!
!     ipmpar is an adaptation of the function i1mach, written by
!     p.a. fox, a.d. hall, and n.l. schryer (bell laboratories).
!     ipmpar was formed by a.h. morris (nswc). the constants are
!     from bell laboratories, nswc, and other sources.
!
  integer imach(10)
  integer ipmpar 
!
!     machine constants for the burroughs 1700 system.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   33 /
!     data imach( 3) / 8589934591 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -256 /
!     data imach( 7) /  255 /
!     data imach( 8) /   60 /
!     data imach( 9) / -256 /
!     data imach(10) /  255 /
!
!     machine constants for the burroughs 5700 system.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   39 /
!     data imach( 3) / 549755813887 /
!     data imach( 4) /    8 /
!     data imach( 5) /   13 /
!     data imach( 6) /  -50 /
!     data imach( 7) /   76 /
!     data imach( 8) /   26 /
!     data imach( 9) /  -50 /
!     data imach(10) /   76 /
!
!     machine constants for the burroughs 6700/7700 systems.
!
!     data imach( 1) /      2 /
!     data imach( 2) /     39 /
!     data imach( 3) / 549755813887 /
!     data imach( 4) /      8 /
!     data imach( 5) /     13 /
!     data imach( 6) /    -50 /
!     data imach( 7) /     76 /
!     data imach( 8) /     26 /
!     data imach( 9) / -32754 /
!     data imach(10) /  32780 /
!
!     machine constants for the cdc 6000/7000 series
!     60 bit arithmetic, and the cdc cyber 995 64 bit
!     arithmetic (nos operating system).
!
!     data imach( 1) /    2 /
!     data imach( 2) /   48 /
!     data imach( 3) / 281474976710655 /
!     data imach( 4) /    2 /
!     data imach( 5) /   48 /
!     data imach( 6) / -974 /
!     data imach( 7) / 1070 /
!     data imach( 8) /   95 /
!     data imach( 9) / -926 /
!     data imach(10) / 1070 /
!
!     machine constants for the cdc cyber 995 64 bit
!     arithmetic (nos/ve operating system).
!
!     data imach( 1) /     2 /
!     data imach( 2) /    63 /
!     data imach( 3) / 9223372036854775807 /
!     data imach( 4) /     2 /
!     data imach( 5) /    48 /
!     data imach( 6) / -4096 /
!     data imach( 7) /  4095 /
!     data imach( 8) /    96 /
!     data imach( 9) / -4096 /
!     data imach(10) /  4095 /
!
!     machine constants for the cray 1.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    63 /
!     data imach( 3) / 9223372036854775807 /
!     data imach( 4) /     2 /
!     data imach( 5) /    48 /
!     data imach( 6) / -8192 /
!     data imach( 7) /  8191 /
!     data imach( 8) /    96 /
!     data imach( 9) / -8192 /
!     data imach(10) /  8191 /
!
!     machine constants for the data general eclipse s/200.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /   16 /
!     data imach( 5) /    6 /
!     data imach( 6) /  -64 /
!     data imach( 7) /   63 /
!     data imach( 8) /   14 /
!     data imach( 9) /  -64 /
!     data imach(10) /   63 /
!
!     machine constants for the harris 220.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   23 /
!     data imach( 3) / 8388607 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   38 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     machine constants for the honeywell 600/6000 series.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   63 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     machine constants for the hp 2100
!     3 word double precision option with ftn4
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   39 /
!     data imach( 9) / -128 /
!     data imach(10) /  127 /
!
!     machine constants for the hp 2100
!     4 word double precision option with ftn4
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /    2 /
!     data imach( 5) /   23 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   55 /
!     data imach( 9) / -128 /
!     data imach(10) /  127 /
!
!     machine constants for the hp 9000.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -126 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     machine constants for the ibm 360/370 series,
!     the amdahl 470/v6, the icl 2900, the itel as/6,
!     the xerox sigma 5/7/9 and the sel systems 85/86.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /   16 /
!     data imach( 5) /    6 /
!     data imach( 6) /  -64 /
!     data imach( 7) /   63 /
!     data imach( 8) /   14 /
!     data imach( 9) /  -64 /
!     data imach(10) /   63 /
!
!     machine constants for the ibm pc - microsoft fortran,
!     rm fortran, professional fortran, and lahey fortran.
!
  data imach( 1) /     2 /
  data imach( 2) /    31 /
  data imach( 3) / 2147483647 /
  data imach( 4) /     2 /
  data imach( 5) /    24 /
  data imach( 6) /  -125 /
  data imach( 7) /   128 /
  data imach( 8) /    53 /
  data imach( 9) / -1021 /
  data imach(10) /  1024 /
!
!     machine constants for the microvax - vms fortran.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     machine constants for the pdp-10 (ka processor).
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   54 /
!     data imach( 9) / -101 /
!     data imach(10) /  127 /
!
!     machine constants for the pdp-10 (ki processor).
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   62 /
!     data imach( 9) / -128 /
!     data imach(10) /  127 /
!
!     machine constants for the pdp-11 fortran supporting
!     32-bit integer arithmetic.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     machine constants for the pdp-11 fortran supporting
!     16-bit integer arithmetic.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   15 /
!     data imach( 3) / 32767 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
!     machine constants for the sun 3.
!
!     data imach( 1) /     2 /
!     data imach( 2) /    31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /     2 /
!     data imach( 5) /    24 /
!     data imach( 6) /  -125 /
!     data imach( 7) /   128 /
!     data imach( 8) /    53 /
!     data imach( 9) / -1021 /
!     data imach(10) /  1024 /
!
!     machine constants for the univac 1100 series.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   35 /
!     data imach( 3) / 34359738367 /
!     data imach( 4) /    2 /
!     data imach( 5) /   27 /
!     data imach( 6) / -128 /
!     data imach( 7) /  127 /
!     data imach( 8) /   60 /
!     data imach( 9) /-1024 /
!     data imach(10) / 1023 /
!
!     machine constants for the vax 11/780.
!
!     data imach( 1) /    2 /
!     data imach( 2) /   31 /
!     data imach( 3) / 2147483647 /
!     data imach( 4) /    2 /
!     data imach( 5) /   24 /
!     data imach( 6) / -127 /
!     data imach( 7) /  127 /
!     data imach( 8) /   56 /
!     data imach( 9) / -127 /
!     data imach(10) /  127 /
!
  ipmpar = imach(i)
  return
end
function isamax ( n, x, incx )
!
!*******************************************************************************
!
!! ISAMAX finds the index of the vector element of maximum absolute value.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be examined.
!
!    Input, integer INCX, the increment between successive entries of SX.
!
!    Output, integer ISAMAX, the index of the element of SX of maximum
!    absolute value.
!
  integer i
  integer incx
  integer isamax
  integer ix
  integer n
  real samax
  real x(*)
!
  if ( n <= 0 ) then

    isamax = 0

  else if ( n == 1 ) then

    isamax = 1

  else if ( incx == 1 ) then

    isamax = 1
    samax = abs ( x(1) )

    do i = 2, n

      if ( abs ( x(i) ) > samax ) then
        isamax = i
        samax = abs ( x(i) )
      end if

    end do

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    isamax = 1
    samax = abs ( x(ix) )

    ix = ix + incx

    do i = 2, n
      if ( abs ( x(ix) ) > samax ) then
        isamax = i
        samax = abs ( x(ix) )
      end if
      ix = ix + incx
    end do

  end if

  return
end
subroutine ishell (a, n)
!
!*******************************************************************************
!
!! ISHELL uses the shell sort to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. it is assumed that n >= 1.
!
  integer a(n), k(10), s
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31    a(ll) = s
!
   40 i = i - 1
  return
end
subroutine isubx ( a0, b0, x0, p, ierr, eps )
!
!*******************************************************************************
!
!! ISUBX evalues the incomplete Beta function for A and B >= 0.5.
!
!
!  Parameters:
!
!    Input, A0
!
!    Input, B0
!
!    Input, X0
!
!    Output, P
!
!    Output, integer IERR, error flag.
!
!    Input, real EPS, ?
!
  real a0
  real b0
  real i
  integer ierr
  integer imax
  real j
  real k
  real lambda
  real m
  real n
  real p
  real pihalf
  real w(10)
  real x0
  real z(10)
!
  data w(1) /6.6671344308688e-2/,  w(2) /1.4945134915058e-1/, &
       w(3) /2.1908636251598e-1/,  w(4) /2.6926671931000e-1/, &
       w(5) /2.9552422471475e-1/,  w(6) /2.9552422471475e-1/, &
       w(7) /2.6926671931000e-1/,  w(8) /2.1908636251598e-1/, &
       w(9) /1.4945134915058e-1/,  w(10)/6.6671344308688e-2/
  data z(1) /1.3046735791414e-2/,  z(2) /6.7468316655507e-2/, &
       z(3) /1.6029521585049e-1/,  z(4) /2.8330230293538e-1/, &
       z(5) /4.2556283050918e-1/,  z(6) /5.7443716949081e-1/, &
       z(7) /7.1669769706462e-1/,  z(8) /8.3970478414951e-1/, &
       z(9) /9.3253168334449e-1/,  z(10)/9.8695326420859e-1/
!
!     rpinv = 1/sqrt(pi)
!
  data pihalf /1.5707963267949/
  data rpinv  /.56418958354776/
!
  imax = huge ( imax )
  a = a0
  b = b0
  x = x0
  y = 0.5 + ( 0.5 - x )
!
!  Check the arguments.
!
  p = 0.0

  if ( a <= 0.0 .or. b <= 0.0 ) then
    ierr = 2
    return
  end if

  ierr = 1

  if ( a < 0.5 .or. b < 0.5 ) then
    ierr = 3
    return
  end if

  if ( x == 0.0 ) then
    p = 0.0
    return
  end if

  if ( x == 1.0 ) then
    p = 1.0
    return
  end if

  if ( x < 0.0 ) then
    ierr = 2
    return
  end if

  m = imax
  if (a >= m .or. b > 70.0 .or. y < 0.0) go to 411
  k = int(a)
  j = int(b)
  afrac = a - k
  bfrac = b - j
  if ((afrac /= 0.0 .and. afrac /= 0.5) .or. &
      (bfrac /= 0.0 .and. bfrac /= 0.5)) go to 420
  if (a >= 5000.0 .and. x < 0.96) return
!
!                      check if b is an integer
!
  ind = 0
  tol = 0.5*max ( eps, 1.e-11)
  if (bfrac /= 0.0) go to 100
  if (afrac /= 0.0) go to 20
  if (a >= b) go to 20
!
!                        interchange a and b
!
   10 ind = 1
  t = b
  b = a
  a = t
  t = y
  y = x
  x = t
  t = j
  j = k
  k = t
!
!                        compute expansion 14
!
   20 am1 = a - 1.0
  n = 1.0
  if (am1 < 0.5) go to 30
  n = j
  if (y >= 2.0*j*x) go to 30
  t = am1*y/x + 1.0
  if (t < j) n = int(t)
!
   30 i = n - 1.0
  c = (a*alog(x) + i*alnrel(-x)) - blnd(a,i)
  if (c <= -30) go to 60
  tol = tol/j
  an = exp(c)
  if (an <= tol) go to 60
  if (an >= 1.0 - tol) go to 330
!
  c = an
  sum = 0.0
   40 i = i + 1.0
  if (i >= j) go to 50
  c = ((am1 + i)/i)*y*c
  sum = sum + c
  if (c > tol) go to 40
!
   50 i = n
  c = an
   51 i = i - 1.0
  if (i == 0.0) go to 52
  c = i*c/((i + am1)*y)
  sum = sum + c
  if (c > tol) go to 51
   52 p = an + sum
!
   60 if (p >= 1.0) p = 1.0
  if (ind == 0) return
  p = 0.5 + (0.5 - p)
  if (p < 0.0) p = 0.0
  return
!
!                selection of the appropriate algorithm
!
  100 am1 = a - 1.0
  if (a > 70.0) go to 150
  if (afrac == 0.0) go to 10
!
!                compute p0 = ix(a,1/2) or p0 = ix(1/2,b)
!                           using formula 22
!
  temp = sqrt(x)
  rty  = sqrt(y)
  c = atan(temp/rty)/pihalf
  if (k == 0.0) go to 130
  ind = j
  m = k + k
  temp = -temp
!
  110 i = 0.0
  t = 1.0
  sum = 0.0
  111 i = i + 2.0
  if (i == m) go to 120
  t = x*(i/(i + 1.0))*t
  sum = t + sum
  go to 111
!
  120 p0 = (sum + 1.0)*temp*rty/pihalf + c
  if (ind /= 0) go to 200
  p = p0
  return
!
  130 if (j == 0.0) go to 310
  m = j + j
  x = y
  go to 110
!
!                  compute p0 = ix(a,1/2) for a > 70
!                       using expansion 52 or 53
!
  150 p0 = 0.0
  if (x < 0.7) go to 200
  t = tol**(1.0/am1)
  if (x <= t) go to 200
!
  t = 0.5 + (0.5 - t)
  lambda = sqrt(t)
  rty = sqrt(y)
  gamrat = rpinv*exp(-algdiv(0.5,a))
  if (t >= 4.0*y) go to 170
!
  c = lambda - rty
  temp = 2.0*rty
  sum = 0.0
  do 160 l = 1,10
     t = c*z(l)
  160    sum = sum + w(l)*(x - t*(t + temp))**am1
  p0 = c*gamrat*sum + 0.5*tol
  go to 200
!
  170 sum = 0.0
  do 171 l = 1,10
     t = 1.0 - y*z(l)*z(l)
  171    sum = sum + w(l)*t**am1
  p0 = 1.0 - rty*gamrat*sum
!
!                     compute p using expansion 21
!
  200 if (j == 0.0) go to 251
  n = j
  if (y >= 2.0*j*x) go to 210
  t = am1*y/x + 0.5
  if (t >= 2.0) go to 201
     n = 1.0
     go to 210
  201 if (t < j) n = int(t)
!
  210 t = n - 0.5
  c = (a*alog(x) + t*alnrel(-x)) - blnd(a,t)
  if (c <= -30.0) go to 251
  c = exp(c)
  if (c <= tol/j) go to 251
  if (p0 + c >= 1.0 - tol) go to 320
!
  tol = tol/j
  lambda = c
  sum = 0.0
  220 t = t + 1.0
  if (t > j) go to 240
  lambda = (am1 + t)*y*lambda/t
  sum = sum + lambda
  if (lambda > tol) go to 220
!
  240 lambda = c
  t = a - 0.5
  i = n
  241 i = i - 1.0
  if (i <= 0.0) go to 250
  lambda = ((i + 0.5)/(i + t))*lambda/y
  sum = lambda + sum
  if (lambda > tol) go to 241
!
  250 p = c + sum
  251 p = p + p0
  if (p >= 1.0) p = 1.0
  return
!
!                           special cases
!
  300 p = x
  return
!
  310 p = c
  return
!
  320 p = 1.0
  return
!
  330 p = 1 - ind
  return
!
!                           error return
!
  400 ierr = 2
  return
!
  411 ierr = 3
  return
!
  420 ierr = 4
  return
end
subroutine itert(kernel,rhfcn,n,tn,wn,m,tm,wm,xm,xmz,kmm,kmn, &
     knm,rhs,imknn,lufact,r,rh,deln,nup,nhalf,iflg)
!
!*******************************************************************************
!
!! ITERT computes the next estimate of the solution of an integral equation.
!
!
!  ITERT is used by IEGS.
!  ITERT calculates one iterate xm given the initial guess xmz.
!
!
!  the routine is divided according to whether or not
!   m > nupper.
!
  real kernel,kmm,kmn,knm,imknn,lufact
  dimension tn(n),wn(n),tm(m),wm(m),xm(m),xmz(m),kmm(nup,nup), &
     kmn(nup,nhalf),knm(nhalf,nup),rhs(m),imknn(nup,nup), &
     lufact(nup,nup),r(m),rh(n),deln(n)
  external kernel
!
!   m > nupper means that the matrices kmm,kmn,knm can no longer
!   be stored due to lack of space.
  if (m > nup) go to 13
  if(iflg == 1) go to 3
!   if iflg=0, then the matrices kmm and knm must be computed
!   and stored.
  do 2 j=1,m
  do 1 i=1,m
1     kmm(i,j)=wm(j)*kernel(tm(i),tm(j))
  do 2 i=1,n
2     knm(i,j)=wm(j)*kernel(tn(i),tm(j))
!   compute  residuals r(i)=rhfcn(tm(i))-xmz(i)+km(tm(i))*xmz(i)
3     do 5 i=1,m
  sum=0.0
  do 4 j=1,m
4     sum=sum+kmm(i,j)*xmz(j)
5     r(i)=rhs(i)-(xmz(i)-sum)
!
!   compute rh=km*r at all tn(i).
  do 7 i=1,n
  rh(i)=0.0
  do 7 j=1,m
7     rh(i)=rh(i)+knm(i,j)*r(j)
!   calculate deln=((i-kn)**(-1))*km*r at all tn(i).
!

  call lnsys(imknn,lufact,nup,n,rh,deln,4,ind)
!
!   calculate new xm.
  do 12 i=1,m
  sum=0.0
  do 10 j=1,m
10    sum=sum+kmm(i,j)*r(j)
  do 11 j=1,n
11    sum=sum+kmn(i,j)*deln(j)
12    xm(i)=sum+r(i)+xmz(i)
  return
!   entrance when m > nup.
!   calculate residuals.
13    do 15 i=1,m
  sum=0.0
  do 14 j=1,m
14    sum=sum+wm(j)*kernel(tm(i),tm(j))*xmz(j)
15    r(i)=rhs(i)-(xmz(i)-sum)
!   calculate rh=km*r.
  do 17 i=1,n
  rh(i)=0.0
  do 17 j=1,m
17    rh(i)=rh(i)+wm(j)*kernel(tn(i),tm(j))*r(j)

  call lnsys(imknn,lufact,nup,n,rh,deln,4,ind)
!
!   calculate xm.
  do 22 i=1,m
  sum=0.0
  do 20 j=1,m
20    sum=sum+wm(j)*kernel(tm(i),tm(j))*r(j)
  do 21 j=1,n
21    sum=sum+wn(j)*kernel(tm(i),tn(j))*deln(j)
22    xm(i)=sum+r(i)+xmz(i)
  return
end
subroutine iupd(ia, ib, l, a1, a2, p1, p2, v1, v2, k1, n, m, np1)
!
!*******************************************************************************
!
!! IUPD updates for implied arc
!
  integer a1(m), a2(m), p1(np1), p2(np1), v1(n), v2(n)
!
  m1 = p1(ib) + 1
  m2 = p1(ib+1)
  do 40 mm=m1,m2
    iarc = a1(mm)
    if (iarc < 0) go to 40
    if (v2(iarc)/=1) go to 10
    if (iarc/=ia) go to 50
    jj = l
    go to 30
   10   j1 = p2(iarc) + 1
    j2 = p2(iarc+1)
    do 20 jj=j1,j2
      if (a2(jj)==ib) go to 30
   20   continue
   30   a2(jj) = k1 - a2(jj)
    v2(iarc) = v2(iarc) - 1
    a1(mm) = k1 - iarc
    v1(ib) = v1(ib) - 1
   40 continue
  return
   50 ia = 0
  return
end
subroutine ja(z, i1, i2, i1m, i2m)
!
!*******************************************************************************
!
!! JA: Bessel function of the first kind for orders 1/3, 2/3, -1/3, and -2/3
!  and for complex argument
!     z, where -pi < arg(z) <= pi.  i1 and i2 are replaced
!     by the functions of orders 1/3 and 2/3, respectively, and
!     i1m and i2m by functions of orders -1/3 and -2/3,
!     respectively.
!
  complex z,i1,i2,i1m,i2m,cz,ex13,ex13c,ex23,ex23c
!
!     ex13 = exp(i*pi/3)
!     ex13c = exp(-i*pi/3)
!     ex23 = exp(2*i*pi/3)
!     ex23c = exp(-2*i*pi/3)
!
  data ex13/(5.0e-01, 8.66025403784439e-01)/
  data ex13c/(5.0e-01, -8.66025403784439e-01)/
  data ex23/(-5.0e-01, 8.66025403784439e-01)/
  data ex23c/(-5.0e-01, -8.66025403784439e-01)/
  if(real(z) >= 0.0) go to 20
     cz = -z
!
!     calculation of i1, i2, i1m, and i2m when real(cz) > 0.0
!
     call jmc(cz, i1, i2, i1m, i2m)
!
!     final assembly
!
     if(aimag(z) < 0.0) go to 10
        i1 = ex13*i1
        i2 = ex23*i2
        i1m = ex13c*i1m
        i2m = ex23c*i2m
        return
   10    i1 = ex13c*i1
     i2 = ex23c*i2
     i1m = ex13*i1m
     i2m = ex23*i2m
     return
   20    call jmc(z, i1, i2, i1m, i2m)
  return
end
subroutine jacobi_sn_values ( n, a, x, fx )
!
!*******************************************************************************
!
!! JACOBI_SN_VALUES returns some values of the Jacobi SN function.
!
!
!  Modified:
!
!    09 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real A, X, the arguments of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 20
!
  real a
  real, save, dimension ( nmax ) :: avec = (/ &
    0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, &
    0.0E+00, 0.5E+00, 0.5E+00, 0.5E+00, &
    0.5E+00, 0.5E+00, 1.0E+00, 1.0E+00, &
    1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00, &
    1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00 /)
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.099833E+00,  0.19867E+00,   0.47943E+00,   0.84147E+00, &
    0.90930E+00,   0.099751E+00,  0.19802E+00,   0.47075E+00, &
    0.80300E+00,   0.99466E+00,   0.099668E+00,  0.19738E+00, &
    0.46212E+00,   0.76159E+00,   0.96403E+00,   0.99933E+00, &
   -0.19738E+00,  -0.46212E+00,  -0.76159E+00,  -0.96403E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    0.1E+00,  0.2E+00,  0.5E+00,  1.0E+00, &
    2.0E+00,  0.1E+00,  0.2E+00,  0.5E+00, &
    1.0E+00,  2.0E+00,  0.1E+00,  0.2E+00, &
    0.5E+00,  1.0E+00,  2.0E+00,  4.0E+00, &
   -0.2E+00, -0.5E+00, -1.0E+00, -2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    a = 0.0E+00
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  a = avec(n)
  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine jairy(x,rx,c,ai,dai)
!
!*******************************************************************************
!
!! JAIRY computes the airy function and its derivative for jbess
!
!                                   input
!
!         x - argument, computed by jbess, x unrestricted
!        rx - rx=sqrt(abs(x)), computed by jbess
!         c - c=2.*(abs(x)**1.5)/3., computed by jbess
!
!                                  output
!
!        ai - value of function ai(x)
!       dai - value of the derivative dai(x)
!
!                                written by
!
!                                d. e. amos
!                               s. l. daniel
!                               m. k. weston
!
  dimension ak1(14),ak2(23),ak3(14)
  dimension ajp(19),ajn(19),a(15),b(15)
  dimension dak1(14),dak2(24),dak3(14)
  dimension dajp(19),dajn(19),da(15),db(15)
!
  data n1,n2,n3,n4/14,23,19,15/
  data m1,m2,m3,m4/12,21,17,13/
  data fpi12,con1,con2,con3,con4,con5/ &
   1.30899693899575e+00, 6.66666666666667e-01, 5.03154716196777e+00, &
   3.80004589867293e-01, 8.33333333333333e-01, 8.66025403784439e-01/
!
  data ak1(1) / 2.20423090987793e-01/, &
   ak1(2) /-1.25290242787700e-01/, ak1(3) / 1.03881163359194e-02/, &
   ak1(4) / 8.22844152006343e-04/, ak1(5) /-2.34614345891226e-04/, &
   ak1(6) / 1.63824280172116e-05/, ak1(7) / 3.06902589573189e-07/, &
   ak1(8) /-1.29621999359332e-07/, ak1(9) / 8.22908158823668e-09/, &
   ak1(10)/ 1.53963968623298e-11/, ak1(11)/-3.39165465615682e-11/, &
   ak1(12)/ 2.03253257423626e-12/, ak1(13)/-1.10679546097884e-14/, &
   ak1(14)/-5.16169497785080e-15/
!
  data ak2(1) / 2.74366150869598e-01/, &
   ak2(2) / 5.39790969736903e-03/, ak2(3) /-1.57339220621190e-03/, &
   ak2(4) / 4.27427528248750e-04/, ak2(5) /-1.12124917399925e-04/, &
   ak2(6) / 2.88763171318904e-05/, ak2(7) /-7.36804225370554e-06/, &
   ak2(8) / 1.87290209741024e-06/, ak2(9) /-4.75892793962291e-07/, &
   ak2(10)/ 1.21130416955909e-07/, ak2(11)/-3.09245374270614e-08/, &
   ak2(12)/ 7.92454705282654e-09/, ak2(13)/-2.03902447167914e-09/, &
   ak2(14)/ 5.26863056595742e-10/, ak2(15)/-1.36704767639569e-10/, &
   ak2(16)/ 3.56141039013708e-11/, ak2(17)/-9.31388296548430e-12/, &
   ak2(18)/ 2.44464450473635e-12/, ak2(19)/-6.43840261990955e-13/, &
   ak2(20)/ 1.70106030559349e-13/, ak2(21)/-4.50760104503281e-14/, &
   ak2(22)/ 1.19774799164811e-14/, ak2(23)/-3.19077040865066e-15/
!
  data ak3(1) / 2.80271447340791e-01/, &
   ak3(2) /-1.78127042844379e-03/, ak3(3) / 4.03422579628999e-05/, &
   ak3(4) /-1.63249965269003e-06/, ak3(5) / 9.21181482476768e-08/, &
   ak3(6) /-6.52294330229155e-09/, ak3(7) / 5.47138404576546e-10/, &
   ak3(8) /-5.24408251800260e-11/, ak3(9) / 5.60477904117209e-12/, &
   ak3(10)/-6.56375244639313e-13/, ak3(11)/ 8.31285761966247e-14/, &
   ak3(12)/-1.12705134691063e-14/, ak3(13)/ 1.62267976598129e-15/, &
   ak3(14)/-2.46480324312426e-16/
!
  data ajp(1) / 7.78952966437581e-02/, &
   ajp(2) /-1.84356363456801e-01/, ajp(3) / 3.01412605216174e-02/, &
   ajp(4) / 3.05342724277608e-02/, ajp(5) /-4.95424702513079e-03/, &
   ajp(6) /-1.72749552563952e-03/, ajp(7) / 2.43137637839190e-04/, &
   ajp(8) / 5.04564777517082e-05/, ajp(9) /-6.16316582695208e-06/, &
   ajp(10)/-9.03986745510768e-07/, ajp(11)/ 9.70243778355884e-08/, &
   ajp(12)/ 1.09639453305205e-08/, ajp(13)/-1.04716330588766e-09/, &
   ajp(14)/-9.60359441344646e-11/, ajp(15)/ 8.25358789454134e-12/, &
   ajp(16)/ 6.36123439018768e-13/, ajp(17)/-4.96629614116015e-14/, &
   ajp(18)/-3.29810288929615e-15/, ajp(19)/ 2.35798252031104e-16/
!
  data ajn(1) / 3.80497887617242e-02/, &
   ajn(2) /-2.45319541845546e-01/, ajn(3) / 1.65820623702696e-01/, &
   ajn(4) / 7.49330045818789e-02/, ajn(5) /-2.63476288106641e-02/, &
   ajn(6) /-5.92535597304981e-03/, ajn(7) / 1.44744409589804e-03/, &
   ajn(8) / 2.18311831322215e-04/, ajn(9) /-4.10662077680304e-05/, &
   ajn(10)/-4.66874994171766e-06/, ajn(11)/ 7.15218807277160e-07/, &
   ajn(12)/ 6.52964770854633e-08/, ajn(13)/-8.44284027565946e-09/, &
   ajn(14)/-6.44186158976978e-10/, ajn(15)/ 7.20802286505285e-11/, &
   ajn(16)/ 4.72465431717846e-12/, ajn(17)/-4.66022632547045e-13/, &
   ajn(18)/-2.67762710389189e-14/, ajn(19)/ 2.36161316570019e-15/
!
  data a(1) / 4.90275424742791e-01/, a(2) / 1.57647277946204e-03/, &
       a(3) /-9.66195963140306e-05/, a(4) / 1.35916080268815e-07/, &
       a(5) / 2.98157342654859e-07/, a(6) /-1.86824767559979e-08/, &
       a(7) /-1.03685737667141e-09/, a(8) / 3.28660818434328e-10/, &
       a(9) /-2.57091410632780e-11/, a(10)/-2.32357655300677e-12/, &
       a(11)/ 9.57523279048255e-13/, a(12)/-1.20340828049719e-13/, &
       a(13)/-2.90907716770715e-15/, a(14)/ 4.55656454580149e-15/, &
       a(15)/-9.99003874810259e-16/
!
  data b(1) / 2.78593552803079e-01/, b(2) /-3.52915691882584e-03/, &
       b(3) /-2.31149677384994e-05/, b(4) / 4.71317842263560e-06/, &
       b(5) /-1.12415907931333e-07/, b(6) /-2.00100301184339e-08/, &
       b(7) / 2.60948075302193e-09/, b(8) /-3.55098136101216e-11/, &
       b(9) /-3.50849978423875e-11/, b(10)/ 5.83007187954202e-12/, &
       b(11)/-2.04644828753326e-13/, b(12)/-1.10529179476742e-13/, &
       b(13)/ 2.87724778038775e-14/, b(14)/-2.88205111009939e-15/, &
       b(15)/-3.32656311696166e-16/
!
  data n1d,n2d,n3d,n4d/14,24,19,15/
  data m1d,m2d,m3d,m4d/12,22,17,13/
!
  data dak1(1) / 2.04567842307887e-01/, &
   dak1(2) /-6.61322739905664e-02/, dak1(3) /-8.49845800989287e-03/, &
   dak1(4) / 3.12183491556289e-03/, dak1(5) /-2.70016489829432e-04/, &
   dak1(6) /-6.35636298679387e-06/, dak1(7) / 3.02397712409509e-06/, &
   dak1(8) /-2.18311195330088e-07/, dak1(9) /-5.36194289332826e-10/, &
   dak1(10)/ 1.13098035622310e-09/, dak1(11)/-7.43023834629073e-11/, &
   dak1(12)/ 4.28804170826891e-13/, dak1(13)/ 2.23810925754539e-13/, &
   dak1(14)/-1.39140135641182e-14/
!
  data dak2(1) / 2.93332343883230e-01/, &
   dak2(2) /-8.06196784743112e-03/, dak2(3) / 2.42540172333140e-03/, &
   dak2(4) /-6.82297548850235e-04/, dak2(5) / 1.85786427751181e-04/, &
   dak2(6) /-4.97457447684059e-05/, dak2(7) / 1.32090681239497e-05/, &
   dak2(8) /-3.49528240444943e-06/, dak2(9) / 9.24362451078835e-07/, &
   dak2(10)/-2.44732671521867e-07/, dak2(11)/ 6.49307837648910e-08/, &
   dak2(12)/-1.72717621501538e-08/, dak2(13)/ 4.60725763604656e-09/, &
   dak2(14)/-1.23249055291550e-09/, dak2(15)/ 3.30620409488102e-10/, &
   dak2(16)/-8.89252099772401e-11/, dak2(17)/ 2.39773319878298e-11/, &
   dak2(18)/-6.48013921153450e-12/, dak2(19)/ 1.75510132023731e-12/, &
   dak2(20)/-4.76303829833637e-13/, dak2(21)/ 1.29498241100810e-13/, &
   dak2(22)/-3.52679622210430e-14/, dak2(23)/ 9.62005151585923e-15/, &
   dak2(24)/-2.62786914342292e-15/
!
  data dak3(1) / 2.84675828811349e-01/, &
   dak3(2) / 2.53073072619080e-03/, dak3(3) /-4.83481130337976e-05/, &
   dak3(4) / 1.84907283946343e-06/, dak3(5) /-1.01418491178576e-07/, &
   dak3(6) / 7.05925634457153e-09/, dak3(7) /-5.85325291400382e-10/, &
   dak3(8) / 5.56357688831339e-11/, dak3(9) /-5.90889094779500e-12/, &
   dak3(10)/ 6.88574353784436e-13/, dak3(11)/-8.68588256452194e-14/, &
   dak3(12)/ 1.17374762617213e-14/, dak3(13)/-1.68523146510923e-15/, &
   dak3(14)/ 2.55374773097056e-16/
!
  data dajp(1) / 6.53219131311457e-02/, &
   dajp(2) /-1.20262933688823e-01/, dajp(3) / 9.78010236263823e-03/, &
   dajp(4) / 1.67948429230505e-02/, dajp(5) /-1.97146140182132e-03/, &
   dajp(6) /-8.45560295098867e-04/, dajp(7) / 9.42889620701976e-05/, &
   dajp(8) / 2.25827860945475e-05/, dajp(9) /-2.29067870915987e-06/, &
   dajp(10)/-3.76343991136919e-07/, dajp(11)/ 3.45663933559565e-08/, &
   dajp(12)/ 4.29611332003007e-09/, dajp(13)/-3.58673691214989e-10/, &
   dajp(14)/-3.57245881361895e-11/, dajp(15)/ 2.72696091066336e-12/, &
   dajp(16)/ 2.26120653095771e-13/, dajp(17)/-1.58763205238303e-14/, &
   dajp(18)/-1.12604374485125e-15/, dajp(19)/ 7.31327529515367e-17/
!
  data dajn(1) / 1.08594539632967e-02/, &
   dajn(2) / 8.53313194857091e-02/, dajn(3) /-3.15277068113058e-01/, &
   dajn(4) /-8.78420725294257e-02/, dajn(5) / 5.53251906976048e-02/, &
   dajn(6) / 9.41674060503241e-03/, dajn(7) /-3.32187026018996e-03/, &
   dajn(8) /-4.11157343156826e-04/, dajn(9) / 1.01297326891346e-04/, &
   dajn(10)/ 9.87633682208396e-06/, dajn(11)/-1.87312969812393e-06/, &
   dajn(12)/-1.50798500131468e-07/, dajn(13)/ 2.32687669525394e-08/, &
   dajn(14)/ 1.59599917419225e-09/, dajn(15)/-2.07665922668385e-10/, &
   dajn(16)/-1.24103350500302e-11/, dajn(17)/ 1.39631765331043e-12/, &
   dajn(18)/ 7.39400971155740e-14/, dajn(19)/-7.32887475627500e-15/
!
  data da(1) / 4.91627321104601e-01/, da(2) / 3.11164930427489e-03/, &
       da(3) / 8.23140762854081e-05/, da(4) /-4.61769776172142e-06/, &
       da(5) /-6.13158880534626e-08/, da(6) / 2.87295804656520e-08/, &
       da(7) /-1.81959715372117e-09/, da(8) /-1.44752826642035e-10/, &
       da(9) / 4.53724043420422e-11/, da(10)/-3.99655065847223e-12/, &
       da(11)/-3.24089119830323e-13/, da(12)/ 1.62098952568741e-13/, &
       da(13)/-2.40765247974057e-14/, da(14)/ 1.69384811284491e-16/, &
       da(15)/ 8.17900786477396e-16/
!
  data db(1) /-2.77571356944231e-01/, db(2) / 4.44212833419920e-03/, &
       db(3) /-8.42328522190089e-05/, db(4) /-2.58040318418710e-06/, &
       db(5) / 3.42389720217621e-07/, db(6) /-6.24286894709776e-09/, &
       db(7) /-2.36377836844577e-09/, db(8) / 3.16991042656673e-10/, &
       db(9) /-4.40995691658191e-12/, db(10)/-5.18674221093575e-12/, &
       db(11)/ 9.64874015137022e-13/, db(12)/-4.90190576608710e-14/, &
       db(13)/-1.77253430678112e-14/, db(14)/ 5.55950610442662e-15/, &
       db(15)/-7.11793337579530e-16/
!
  if(x < 0.) go to 300
  if(c > 5.) go to 200
  if(x > 1.2) go to 150
  t=(x+x-1.2)*con4
  tt = t + t
  j=n1
  f1=ak1(j)
  f2=0.
  do 105 i=1,m1
  j=j-1
  temp1=f1
  f1=tt*f1-f2+ak1(j)
  f2=temp1
  105 continue
  ai=t*f1-f2+ak1(1)
!
  j=n1d
  f1=dak1(j)
  f2=0.
  do 106 i=1,m1d
  j=j-1
  temp1=f1
  f1=tt*f1-f2+dak1(j)
  f2=temp1
106   continue
  dai=-(t*f1-f2+dak1(1))
  return
!
  150 continue
  t=(x+x-con2)*con3
  tt = t + t
  j=n2
  f1=ak2(j)
  f2=0.
  do 155 i=1,m2
  j=j-1
  temp1=f1
  f1=tt*f1-f2+ak2(j)
  f2=temp1
  155 continue
  rtrx=sqrt(rx)
  ec=exp(-c)
  ai=ec*(t*f1-f2+ak2(1))/rtrx
  j=n2d
  f1=dak2(j)
  f2=0.
  do 156 i=1,m2d
  j=j-1
  temp1=f1
  f1=tt*f1-f2+dak2(j)
  f2=temp1
156   continue
  dai=-ec*(t*f1-f2+dak2(1))*rtrx
  return
!
  200 continue
  t=10./c-1.
  tt=t+t
  j=n1
  f1=ak3(j)
  f2=0.
  do 205 i=1,m1
  j=j-1
  temp1=f1
  f1=tt*f1-f2+ak3(j)
  f2=temp1
  205 continue
  rtrx=sqrt(rx)
  ec=exp(-c)
  ai=ec*(t*f1-f2+ak3(1))/rtrx
  j=n1d
  f1=dak3(j)
  f2=0.
  do 206 i=1,m1d
  j=j-1
  temp1=f1
  f1=tt*f1-f2+dak3(j)
  f2=temp1
206   continue
  dai=-rtrx*ec*(t*f1-f2+dak3(1))
  return
!
  300 continue
  if(c > 5.) go to 350
  t=.4*c-1.
  tt=t+t
  j=n3
  f1=ajp(j)
  e1=ajn(j)
  f2=0.
  e2=0.
  do 305 i=1,m3
  j=j-1
  temp1=f1
  temp2=e1
  f1=tt*f1-f2+ajp(j)
  e1=tt*e1-e2+ajn(j)
  f2=temp1
  e2=temp2
  305 continue
  ai=(t*e1-e2+ajn(1))-x*(t*f1-f2+ajp(1))
  j=n3d
  f1=dajp(j)
  e1=dajn(j)
  f2=0.
  e2=0.
  do 306 i=1,m3d
  j=j-1
  temp1=f1
  temp2=e1
  f1 = tt*f1-f2+dajp(j)
  e1= tt*e1-e2+dajn(j)
  f2=temp1
  e2=temp2
 306  continue
  dai=x*x*(t*f1-f2+dajp(1))+(t*e1-e2+dajn(1))
  return
!
  350 continue
  t=10./c-1.
  tt=t+t
  j=n4
  f1=a(j)
  e1=b(j)
  f2=0.
  e2=0.
  do 310 i=1,m4
  j=j-1
  temp1=f1
  temp2=e1
  f1=tt*f1-f2+a(j)
  e1=tt*e1-e2+b(j)
  f2=temp1
  e2=temp2
  310 continue
  temp1=t*f1-f2+a(1)
  temp2=t*e1-e2+b(1)
  rtrx=sqrt(rx)
  cv=c-fpi12
  ccv=cos(cv)
  scv=sin(cv)
  ai=(temp1*ccv-temp2*scv)/rtrx
  j=n4d
  f1=da(j)
  e1=db(j)
  f2=0.
  e2=0.
  do 311 i=1,m4d
  j=j-1
  temp1=f1
  temp2=e1
  f1=tt*f1-f2+da(j)
  e1=tt*e1-e2+db(j)
  f2=temp1
  e2=temp2
 311  continue
  temp1=t*f1-f2+da(1)
  temp2=t*e1-e2+db(1)
  e1=ccv*con5+.5*scv
  e2=scv*con5-.5*ccv
  dai=(temp1*e1-temp2*e2)*rtrx
  return
end
subroutine jmc(z, i1, i2, i1m, i2m)
!
!*******************************************************************************
!
!! JMC: Bessel function of the first kind for orders 1/3, 2/3, -1/3, and -2/3
!  and for complex argument z. the maclaurin expansion and backward recurrence
!     are used. i1 and i2 are replaced by the functions of orders
!     1/3 and 2/3, respectively, and i1m and i2m by the functions
!     of orders -1/3 and -2/3, respectively.  for greatest
!     accuracy, z should lie in the region real(z) >= 0.
!
  complex z,ia1,ia2,ia3,ib1,ib2,ib3,i1,i2,i1m,i2m,sz,zh,e, &
          cf1,cf2,cf3,cf4
  real m
!
!     gm1 = gamma(4.0/3.0)
!     gm2 = gamma(5.0/3.0)
!
  data c1/.333333333333333e+00/
  data c2/.666666666666667e+00/
  data gm1/.892979511569248e+00/
  data gm2/.902745292950932e+00/
  zh = 0.5*z
  sz = zh*zh
  a = real(zh)
  b = aimag(zh)
  an = aint(a*a + b*b)
  cn1 = c1 + an
  cn2 = c2 + an
!
!     calculation of initial values for backward recurrence by
!     use of the maclaurin expansion.
!
  call bjm(z, cn1, ia1)
  call bjm(z, cn1 + 1.0, ia2)
  call bjm(z, cn2, ib1)
  call bjm(z, cn2 + 1.0, ib2)
!
!     backward recurrence
!
  n = an
  n1 = n + 1
  m = an
  do 10 i = 1, n1
     ia3 = ia2
     ia2 = ia1
     ib3 = ib2
     ib2 = ib1
     cfa = (m + c1)*(m + c1 + 1.0)
     cfb = (m + c2)*(m + c2 + 1.0)
     m = m - 1.0
     ia1 = ia2 - (sz/cfa)*ia3
   10    ib1 = ib2 - (sz/cfb)*ib3
  e = cexp(c1*clog(zh))
  cf1 = e/gm1
  cf2 = e*e/gm2
  cf3 = c2*cf2/zh
  cf4 = c1*cf1/zh
  i1 = cf1*ia2
  i2 = cf2*ib2
  i1m = cf3*ib1
  i2m = cf4*ia1
  return
end
subroutine jrot (nr,n,h,i,a,b,r)
!
!*******************************************************************************
!
!! JROT premultiplies an upper hessenberg matrix by a jacobian rotation.
!
!
!    the jacobian rotation matrix has the form j(i,i+1,a,b)
!
!     input ...
!
!       nr      row dimension of the matrix
!       n       order of the matrix
!       h(n,n)  upper hessenber matrix
!       i       index of row
!       a,b     scalars
!
!     output ...
!
!       h(n,n)  the modified hessenberg matrix
!       r       r = sqrt(a*a + b*b)
!
  real h(nr,n)
!
!                compute c = a/r  and s = b/r
!
  if (abs(a) <= abs(b)) go to 10
     t = b/a
     z = sqrt(1.0 + t*t)
     c = sign(1.0/z, a)
     s = t*c
     r = z*abs(a)
     go to 20
   10 if (a == 0.0) go to 40
  t = a/b
  z = sqrt(1.0 + t*t)
  s = sign(1.0/z, b)
  c = t*s
  r = z*abs(b)
!
!            apply the rotation when a is nonzero
!
   20 do 30 j = i,n
     t = h(i,j)
     z = h(i+1,j)
     h(i,j) = c*t - s*z
     h(i+1,j) = s*t + c*z
   30 continue
  return
!
!                     case when a = 0
!
   40 s = sign(1.0, b)
  r = abs(b)
  do 50 j = i,n
     t = h(i,j)
     h(i,j) = - s*h(i+1,j)
     h(i+1,j) = s*t
   50 continue
  return
end
subroutine ka(ind, z, k1, k2)
!
!*******************************************************************************
!
!! KA calculates the modified Bessel function of the second
!     kind for orders 1/3 and 2/3 and for complex argument z,
!     where -pi < arg(z) .le pi.  k1 is replaced by the
!     function of order 1/3, and k2 by the function of order
!     2/3.
!
  complex z,k1,k2,i1,i2,i1m,i2m,cz,ex13c,ex23c,j,e
!
!     ex13c = exp(-pi*i/3)
!     ex23c = exp(-2*pi*i/3)
!
  data pi/3.14159265358979e+00/
  data ex13c/(5.0e-01, -8.66025403784439e-01)/
  data ex23c/(-5.0e-01, -8.66025403784439e-01)/
  data j/(0.0, 1.0)/
  a = real(z)
  b = aimag(z)
  if (abs(b) < -0.5*a) go to 10
!
!  abs(b) >= -0.5*a
!
     call kml(ind, z, k1, k2)
     return
!
!  abs(b) < -0.5*a
!
   10    cz = -z
     if(aimag(z) < 0.0) cz = conjg(cz)
     ind1 = 0
     call kml(ind1, cz, k1, k2)
     call imc(cz, i1, i2, i1m, i2m)
     k1 = ex13c*k1 - j*pi*i1
     k2 = ex23c*k2 - j*pi*i2
     if (ind == 0) go to 20
     e = cexp(z)
     k1 = k1*e
     k2 = k2*e
   20    if(aimag(z) >= 0.0) return
        k1 = conjg(k1)
        k2 = conjg(k2)
  return
end
subroutine kl ( l, fk, fl )
!
!*******************************************************************************
!
!! KL computes the complete elliptic integrals f(k) and f(l) for
!     a given value of l, where cabs(l) < 1 and k**2 + l**2 = 1.
!     it is assumed that -pi <= arg(l**2) < pi for the resulting
!     value for f(k) to be meaningful.
!
  complex an,l2,s1,s2,w
  complex l, fk, fl
  real ln4
!
  data hpi /1.5707963267949/
  data ln4 /1.3862943611199/
!
  eps = epsilon ( eps )
  tol = max ( eps,1.e-14)
  l2 = l*l
  s1 = (0.0, 0.0)
  s2 = (0.0, 0.0)
  an = (1.0, 0.0)
  bn = 0.0
  do 10 i = 1,50
     ri = i
     c = ((ri - 0.5)/ri)**2
     an = c*(an*l2)
     bn = bn + 1.0/(ri*(2.0*ri - 1.0))
     s1 = s1 + an
     s2 = s2 + an*bn
     if (abs(real(an)) + abs(aimag(an)) < tol) go to 20
   10 continue
   20 s1 = s1 + (1.0, 0.0)
!
!                   set w = 0.5*clog(16.0/l2)
!
  x = real(l)
  y = aimag(l)
  if (x /= 0.0) go to 30
     w = cmplx(ln4 - alog(abs(y)), hpi)
     go to 50
!
   30 if (abs(x) > abs(y)) go to 31
     u = (ln4 - 0.5*alnrel((x/y)**2)) - alog(abs(y))
     go to 40
   31 u = (ln4 - 0.5*alnrel((y/x)**2)) - alog(abs(x))
!
   40 if (x > 0.0) go to 41
     w = cmplx(u, -atan2(-y,-x))
     go to 50
   41 w = cmplx(u, -atan2(y,x))
!
!                        final assembly
!
   50 fk = w*s1 - s2
  fl = hpi*s1
  return
end
function km ( k2 )
!
!*******************************************************************************
!
!! KM computes the complete elliptic integral f(k) for a given
!     value of k2 = k**2 by use of the maclaurin expansion.
!
  complex an
  complex k2
  complex km
  complex s1
  data hpi /1.5707963267949/
!
  eps = epsilon ( eps )
  tol = max ( eps,1.e-14)
  s1 = (1.0, 0.0)
  an = (1.0, 0.0)
  do 10 i = 1,50
     ri = i
     c = ((ri - 0.5)/ri)**2
     an = c*(an*k2)
     s1 = s1 + an
     if (abs(real(an)) + abs(aimag(an)) < tol) go to 20
   10 continue
!
   20 km = hpi*s1
  return
end
subroutine kml(ind, z, k1, k2)
!
!*******************************************************************************
!
!! KML calculates the modified Bessel function of the second kind for orders
!  1/3 and 2/3 and for complex argument z
!     by use of the miller algorithm.  k1 is replaced by the
!     function of order 1/3, and k2 by the function of order
!     2/3.  for greatest accuracy, z should lie in the region
!     real(z) >= 0.
!
  complex z, k1, k2, bi, u1, u2, u3, s, e
!
!     c1 = sqrt(pi/2)
!
  data c1/1.25331413731550e+00/
  eps = epsilon ( eps )
  x1 = real(z)
  x2 = aimag(z)
!
!     calculation of m for use in miller algorithm.
!
  call capo(x1, x2, r, th)
  a = 3.0/(1.0 + r)
  b = 14.7/(28.0 + r)
  c = 2.0/(c1*eps*(2.0*r)**(0.25))
  m = (0.485/r)*(alog(c) + r*cos(a*th)/(1.0 + 0.008*r))**2/ &
      (2.0*cos(b*th))**2 + 1.5
!
!     backward recurrence in miller algorithm.
!
  s = 0.0
  u2 = 0.0
  u1 = eps
  l = m
  do 10 i = 1, m
     al = l
     u3 = u2
     u2 = u1
     ai = ((al - 0.5)**2 - 1.0/9.0)/(al*(al + 1.0))
     bi = 2.0*(al + z)/(al + 1.0)
     u1 = (bi*u2 - u3)/ai
     s = s + u1
   10    l = l - 1
!
!     final assembly
!
  k1 = c1*u1/(s*csqrt(z))
  k2 = k1*(z  + 1.0/6.0 - u2/u1)/z
  if (ind /= 0) return
     e = cexp(-z)
     k1 = k1*e
     k2 = k2*e
     return
end
subroutine kprod(a,ka,m,n,b,kb,k,l,c,kc)
!
!*******************************************************************************
!
!! KPROD is a kronecker product of real matrices a and b
!
  real a(ka,n),b(kb,l),c(kc,*)
  integer r,s
!
  j = 0
  do 40 s = 1,n
     do 30 jj = 1,l
     j = j + 1
!
!        compute the j-th column of c
!
        i = 0
        do 20 r = 1,m
           do 10 ii = 1,k
           i = i + 1
   10          c(i,j) = a(r,s)*b(ii,jj)
   20       continue
!
   30    continue
   40 continue
  return
end
subroutine krout(mo,n,m,a,ka,b,kb,ierr,index,temp)
!
!*******************************************************************************
!
!! KROUT is a crout procedure for inverting matrices and solving equations
!
!
!     a is a matrix of order n where n is greater than or equal to 1.
!     if mo=0 then the inverse of a is computed and stored in a. if mo
!     is not 0 then the inverse is not computed.
!
!     if m is greater than 0 then b is a matrix having n rows and m
!     columns. in this case ax=b is solved and the solution x is stored
!     in b. if m=0 then there are no equations to be solved.
!
!     ka = the length of the columns of the array a
!     kb = the length of the columns of the array b (if m > 0)
!
!     ierr is a variable that reports the status of the results. when
!     the routine terminates ierr has one of the following values ...
!        ierr =  0   the requested task was performed.
!        ierr = -1   either n, ka, or kb is incorrect.
!        ierr =  k   the k-th pivot element is 0.
!
!     index is an array of dimension n-1 or larger that is used by the
!     routine for keeping track of the row interchanges that are made.
!     if mo is not 0 then this array is not needed.
!
!     temp is an array of dimension n or larger that is used when a
!     is inverted. if mo is not 0 then this array is not needed.
!
  dimension a(ka,n), b(*), index(*), temp(*)
  integer onej
  double precision dsum
!
  if (n < 1 .or. ka  <  n) go to 320
  if (m <= 0) go to 5
  if (kb < n) go to 320
!
5 ierr = 0
  if (n < 2) go to 200
  nm1 = n - 1
  do 70 k = 1,nm1
     kp1 = k + 1
!
!               search for the k-th pivot element
!
     p = abs(a(k,k))
     l = k
     do 10 i = kp1,n
        t = abs(a(i,k))
        if (p >= t) go to 10
        p = t
        l = i
   10    continue
     if (p == 0.0) go to 300
!
     p = a(l,k)
     if (mo == 0) index(k) = l
     if (k == l) go to 40
!
!                  interchanging rows k and l
!
     do 20 j = 1,n
        t = a(k,j)
        a(k,j) = a(l,j)
   20       a(l,j) = t
!
     if (m <= 0) go to 40
     kj = k
     lj = l
     do 30 j = 1,m
        t = b(kj)
        b(kj) = b(lj)
        b(lj) = t
        kj = kj + kb
   30       lj = lj + kb
!
!                  compute the k-th row of u
!
   40    if (k > 1) go to 50
        do 41 j = kp1,n
   41          a(k,j) = a(k,j)/p
        go to 60
!
   50    do 52 j = kp1,n
        dsum = a(k,j)
        do 51 l = 1,km1
   51          dsum = dsum - dble(a(k,l))*dble(a(l,j))
        a(k,j) = sngl(dsum)/p
   52    continue
!
!               compute the (k+1)-st column of l
!
   60    do 62 i = kp1,n
        dsum = a(i,kp1)
        do 61 l = 1,k
   61          dsum = dsum - dble(a(i,l))*dble(a(l,kp1))
        a(i,kp1) = dsum
   62    continue
!
     km1 = k
   70 continue
!
!                 check the n-th pivot element
!
  if (a(n,n) == 0.0) go to 310
!
!                 solving the equation ly = b
!
  if (m <= 0) go to 120
  maxb = kb*m
  do 102 onej = 1,maxb,kb
     kj = onej
     b(kj) = b(kj)/a(1,1)
     do 101 k = 2,n
        kj = kj + 1
        dsum = b(kj)
        km1 = k - 1
        lj = onej
        do 100 l = 1,km1
           dsum = dsum - dble(a(k,l))*dble(b(lj))
  100          lj = lj + 1
  101       b(kj) = sngl(dsum)/a(k,k)
  102 continue
!
!                 solving the equation ux = y
!
  do 112 nj = n,maxb,kb
     kj = nj
     do 111 nmk = 1,nm1
        k = n - nmk
        lj = kj
        kj = kj - 1
        dsum = b(kj)
        kp1 = k + 1
        do 110 l = kp1,n
           dsum = dsum - dble(a(k,l))*dble(b(lj))
  110          lj = lj + 1
        b(kj) = dsum
  111    continue
  112 continue
!
!               replace l with the inverse of l
!
  120 if (mo /= 0) return
  do 132 j = 1,nm1
     a(j,j) = 1.0/a(j,j)
     jp1 = j + 1
     do 131 i = jp1,n
        dsum = 0.d0
        im1 = i - 1
        do 130 l = j,im1
  130          dsum = dsum + dble(a(i,l))*dble(a(l,j))
  131       a(i,j) = -sngl(dsum)/a(i,i)
  132 continue
  a(n,n) = 1.0/a(n,n)
!
!           solve ux = y where y is the inverse of l
!
  do 152 nmk = 1,nm1
     k = n - nmk
     kp1 = k + 1
     do 140 j = kp1,n
        temp(j) = a(k,j)
  140       a(k,j) = 0.0
!
     do 151 j = 1,n
        dsum = a(k,j)
        do 150 l = kp1,n
  150          dsum = dsum - dble(temp(l))*dble(a(l,j))
        a(k,j) = dsum
  151    continue
  152 continue
!
!                    column interchanges
!
  do 161 nmj = 1,nm1
     j = n - nmj
     k = index(j)
     if (j == k) go to 161
     do 160 i = 1,n
        t = a(i,j)
        a(i,j) = a(i,k)
  160       a(i,k) = t
  161 continue
  return
!
!                      case when n = 1
!
  200 d = a(1,1)
  if (d == 0.0) go to 310
  if (mo == 0) a(1,1) = 1.0/d
!
  if (m <= 0) return
  maxb = kb*m
  do 210 kj = 1,maxb,kb
  210    b(kj) = b(kj)/d
  return
!
!                  k-th pivot element is 0
!
  300 ierr = k
  return
  310 ierr = n
  return
!
!                        input error
!
  320 ierr = -1
  return
end
subroutine kurv1 (n,x,y,slp1,slpn,islpsw,xp,yp,temp,s, &
                    sigma,ierr)
!
!*******************************************************************************
!
!! KURV1 determines the parameters  of a spline under tension
!  forming a curve in the plane and passing through a sequence of
!  pairs (x(1),y(1)),
!  ...,(x(n),y(n)). for actual computation of points on the
!  curve it is necessary to call the subroutine kurv2.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   n is the number of points to be interpolated (n >= 2).
!
!   x is an array containing the n x-coordinates of the
!   points.
!
!   y is an array containing the n y-coordinates of the
!   points. (adjacent x-y pairs must be distinct, i. e.
!   either x(i) /= x(i+1) or y(i) /= y(i+1), for
!   i = 1,...,n-1.)
!
!   slp1 and slpn contain the desired values for the angles
!   (in radians) of the slope at (x(1),y(1)) and (x(n),y(n))
!   respectively. the angles are measured counter-clock-
!   wise from the x-axis and the positive sense of the curve
!   is assumed to be that moving from point 1 to point n.
!   the user may omit values for either or both of these
!   parameters and signal this with islpsw.
!
!   islpsw contains a switch indicating which slope data
!   should be used and which should be estimated by this
!   subroutine,
!          = 0 if slp1 and slpn are to be used,
!          = 1 if slp1 is to be used but not slpn,
!          = 2 if slpn is to be used but not slp1,
!          = 3 if both slp1 and slpn are to be estimated
!              internally.
!
!   xp and yp are arrays of length at least n.
!
!   temp is an array of length at least n which is used
!   for scratch storage.
!
!   s is an array of length at least n.
!
! and
!
!   sigma contains the tension factor. this value indicates
!   the curviness desired. if abs(sigma) is nearly zero
!   (e.g. .001) the resulting curve is approximately a cubic
!   spline. if abs(sigma) is large (e. g. 50.) the resulting
!   curve is nearly a polygonal line. if sigma equals zero a
!   cubic spline results. a standard value for sigma is
!   approximately 1. in absolute value.
!
! on output--
!
!   xp and yp contain information about the curvature of the
!   curve at the given nodes.
!
!   s contains the polygonal arclengths of the curve.
!
!   ierr contains an error flag,
!        = 0 for normal return,
!        = 1 if n is less than 2,
!        = 2 if adjacent coordinate pairs coincide.
!
! and
!
!   n, x, y, slp1, slpn, islpsw, and sigma are unaltered.
!
! this subroutine references package modules ceez, terms,
! and snhcsh.
!
  integer n,islpsw,ierr
  real x(n),y(n),slp1,slpn,xp(n),yp(n),temp(n),s(n), &
       sigma
!
  nm1 = n-1
  np1 = n+1
  ierr = 0
  if (n <= 1) go to 11
!
! determine polygonal arclengths
!
  s(1) = 0.
  do 1 i = 2,n
    im1 = i-1
1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+ &
           (y(i)-y(im1))**2)
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/s(n)
!
! approximate end slopes
!
  if (islpsw >= 2) go to 2
  slpp1x = cos(slp1)
  slpp1y = sin(slp1)
  go to 4
2 dels1 = s(2)-s(1)
  dels2 = dels1+dels1
  if (n > 2) dels2 = s(3)-s(1)
  if (dels1 == 0. .or. dels2 == 0.) go to 12
  call ceez (dels1,dels2,sigmap,c1,c2,c3,n)
  sx = c1*x(1)+c2*x(2)
  sy = c1*y(1)+c2*y(2)
  if (n == 2) go to 3
  sx = sx+c3*x(3)
  sy = sy+c3*y(3)
3 delt = sqrt(sx*sx+sy*sy)
  slpp1x = sx/delt
  slpp1y = sy/delt
4 if (islpsw == 1 .or. islpsw == 3) go to 5
  slppnx = cos(slpn)
  slppny = sin(slpn)
  go to 7
5 delsn = s(n)-s(nm1)
  delsnm = delsn+delsn
  if (n > 2) delsnm = s(n)-s(n-2)
  if (delsn == 0. .or. delsnm == 0.) go to 12
  call ceez (-delsn,-delsnm,sigmap,c1,c2,c3,n)
  sx = c1*x(n)+c2*x(nm1)
  sy = c1*y(n)+c2*y(nm1)
  if (n == 2) go to 6
  sx = sx+c3*x(n-2)
  sy = sy+c3*y(n-2)
6 delt = sqrt(sx*sx+sy*sy)
  slppnx = sx/delt
  slppny = sy/delt
!
! set up right hand sides and tridiagonal system for xp and
! yp and perform forward elimination
!
7 dx1 = (x(2)-x(1))/s(2)
  dy1 = (y(2)-y(1))/s(2)
  call terms (diag1,sdiag1,sigmap,s(2))
  xp(1) = (dx1-slpp1x)/diag1
  yp(1) = (dy1-slpp1y)/diag1
  temp(1) = sdiag1/diag1
  if (n == 2) go to 9
  do 8 i = 2,nm1
    dels2 = s(i+1)-s(i)
    if (dels2 == 0.) go to 12
    dx2 = (x(i+1)-x(i))/dels2
    dy2 = (y(i+1)-y(i))/dels2
    call terms (diag2,sdiag2,sigmap,dels2)
    diag = diag1+diag2-sdiag1*temp(i-1)
    diagin = 1./diag
    xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
    yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
    temp(i) = sdiag2*diagin
    dx1 = dx2
    dy1 = dy2
    diag1 = diag2
8   sdiag1 = sdiag2
9 diag = diag1-sdiag1*temp(nm1)
  xp(n) = (slppnx-dx1-sdiag1*xp(nm1))/diag
  yp(n) = (slppny-dy1-sdiag1*yp(nm1))/diag
!
! perform back substitution
!
  do 10 i = 2,n
    ibak = np1-i
    xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
   10   yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
  return
!
! too few points
!
   11 ierr = 1
  return
!
! coincident adjacent points
!
   12 ierr = 2
  return
end
subroutine kurv2 (t,xs,ys,n,x,y,xp,yp,s,sigma)
!
!*******************************************************************************
!
!! KURV2 maps the interval (0.,1.) onto a curve in the plane.
!
!
!  the subroutine kurv1 should be called earlier to determine certain
! necessary parameters. the resulting curve has a parametric
! representation both of whose components are splines under
! tension and functions of the polygonal arclength
! parameter.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   t contains a real value to be mapped to a point on the
!   curve. the interval (0.,1.) is mapped onto the entire
!   curve, with 0. mapping to (x(1),y(1)) and 1. mapping
!   to (x(n),y(n)). values outside this interval result in
!   extrapolation.
!
!   n contains the number of points which were specified
!   to determine the curve.
!
!   x and y are arrays containing the x- and y-coordinates
!   of the specified points.
!
!   xp and yp are the arrays output from kurv1 containing
!   curvature information.
!
!   s is an array containing the polygonal arclengths of
!   the curve.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, xp, yp, s, and sigma should be
! input unaltered from the output of kurv1.
!
! on output--
!
!   xs and ys contain the x- and y-coordinates of the image
!   point on the curve.
!
! none of the input parameters are altered.
!
! this subroutine references package modules intrvl and
! snhcsh.
!
  integer n
  real t,xs,ys,x(n),y(n),xp(n),yp(n),s(n),sigma
!
!
! determine interval
!
  tn = s(n)*t
  im1 = intrvl(tn,s,n)
  i = im1+1
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/s(n)
!
! set up and perform interpolation
!
  del1 = tn-s(im1)
  del2 = s(i)-tn
  dels = s(i)-s(im1)
  sumx = (x(i)*del1+x(im1)*del2)/dels
  sumy = (y(i)*del1+y(im1)*del2)/dels
  if (sigmap /= 0.) go to 1
  d = del1*del2/(6.*dels)
  c1 = (del1+dels)*d
  c2 = (del2+dels)*d
  xs = sumx-xp(i)*c1-xp(im1)*c2
  ys = sumy-yp(i)*c1-yp(im1)*c2
  return
1 delp1 = sigmap*(del1+dels)/2.
  delp2 = sigmap*(del2+dels)/2.
  call snhcsh(sinhm1,dummy,sigmap*del1,-1)
  call snhcsh(sinhm2,dummy,sigmap*del2,-1)
  call snhcsh(sinhms,dummy,sigmap*dels,-1)
  call snhcsh (sinhp1,dummy,sigmap*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmap*del2/2.,-1)
  call snhcsh (dummy,coshp1,delp1,1)
  call snhcsh (dummy,coshp2,delp2,1)
  d = sigmap*sigmap*dels*(sinhms+sigmap*dels)
  c1 = (sinhm1*del2-del1*(2.*(coshp1+1.)*sinhp2+sigmap* &
       coshp1*del2))/d
  c2 = (sinhm2*del1-del2*(2.*(coshp2+1.)*sinhp1+sigmap* &
       coshp2*del1))/d
  xs = sumx+xp(i)*c1+xp(im1)*c2
  ys = sumy+yp(i)*c1+yp(im1)*c2
  return
end
subroutine kurvp1 (n,x,y,xp,yp,temp,s,sigma,ierr)
!
!*******************************************************************************
!
!! KURVP1 determines the parameters of a spline under tension
!  forming a closed curve in the plane and passing through a sequence of pairs
! (x(1),y(1)),...,(x(n),y(n)). for actual computation of
! points on the curve it is necessary to call the subroutine
! kurvp2.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   n is the number of points to be interpolated (n >= 2).
!
!   x is an array containing the n x-coordinates of the
!   points.
!
!   y is an array containing the n y-coordinates of the
!   points. (adjacent x-y pairs must be distinct, i. e.
!   either x(i) /= x(i+1) or y(i) /= y(i+1), for
!   i = 1,...,n-1.)
!
!   xp and yp are arrays of length at least n.
!
!   temp is an array of length at least 2*n which is used
!   for scratch storage.
!
!   s is an array of length at least n.
!
! and
!
!   sigma contains the tension factor. this value indicates
!   the curviness desired. if abs(sigma) is nearly zero
!   (e.g. .001) the resulting curve is approximately a cubic
!   spline. if abs(sigma) is large (e. g. 50.) the resulting
!   curve is nearly a polygonal line. if sigma equals zero a
!   cubic spline results. a standard value for sigma is
!   approximately 1. in absolute value.
!
! on output--
!
!   xp and yp contain information about the curvature of the
!   curve at the given nodes.
!
!   s contains the polygonal arclengths of the curve.
!
!   ierr contains an error flag,
!        = 0 for normal return,
!        = 1 if n is less than 2,
!        = 2 if adjacent coordinate pairs coincide.
!
! and
!
!   n, x, y, and sigma are unaltered,
!
! this subroutine references package modules terms and
! snhcsh.
!
  integer n,ierr
  real x(n),y(n),xp(n),yp(n),temp(*),s(n),sigma
!
  nm1 = n-1
  np1 = n+1
  ierr = 0
  if (n <= 1) go to 7
!
! determine polygonal arclengths
!
  s(1) = sqrt((x(n)-x(1))**2+(y(n)-y(1))**2)
  do 1 i = 2,n
    im1 = i-1
1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+ &
           (y(i)-y(im1))**2)
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n)/s(n)
!
! set up right hand sides of tridiagonal (with corner
! elements) linear system for xp and yp
!
  dels1 = s(1)
  if (dels1 == 0.) go to 8
  dx1 = (x(1)-x(n))/dels1
  dy1 = (y(1)-y(n))/dels1
  call terms(diag1,sdiag1,sigmap,dels1)
  dels2 = s(2)-s(1)
  if (dels2 == 0.) go to 8
  dx2 = (x(2)-x(1))/dels2
  dy2 = (y(2)-y(1))/dels2
  call terms(diag2,sdiag2,sigmap,dels2)
  diag = diag1+diag2
  diagin = 1./diag
  xp(1) = (dx2-dx1)*diagin
  yp(1) = (dy2-dy1)*diagin
  temp(np1) = -sdiag1*diagin
  temp(1) = sdiag2*diagin
  dx1 = dx2
  dy1 = dy2
  diag1 = diag2
  sdiag1 = sdiag2
  if (n == 2) go to 3
  do 2 i = 2,nm1
    npi = n+i
    dels2 = s(i+1)-s(i)
    if (dels2 == 0.) go to 8
    dx2 = (x(i+1)-x(i))/dels2
    dy2 = (y(i+1)-y(i))/dels2
    call terms(diag2,sdiag2,sigmap,dels2)
    diag = diag1+diag2-sdiag1*temp(i-1)
    diagin = 1./diag
    xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
    yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
    temp(npi) = -temp(npi-1)*sdiag1*diagin
    temp(i) = sdiag2*diagin
    dx1 = dx2
    dy1 = dy2
    diag1 = diag2
2   sdiag1 = sdiag2
3 dels2 = s(1)
  dx2 = (x(1)-x(n))/dels2
  dy2 = (y(1)-y(n))/dels2
  call terms(diag2,sdiag2,sigmap,dels2)
  xp(n) = dx2-dx1
  yp(n) = dy2-dy1
  temp(nm1) = temp(2*n-1)-temp(nm1)
  if (n==2) go to 5
!
! perform first step of back substitution
!
  do 4 i = 3,n
    ibak = np1-i
    npibak = n+ibak
    xp(ibak) = xp(ibak)-temp(ibak)*xp(ibak+1)
    yp(ibak) = yp(ibak)-temp(ibak)*yp(ibak+1)
4   temp(ibak) = temp(npibak)-temp(ibak)*temp(ibak+1)
5 xp(n) = (xp(n)-sdiag2*xp(1)-sdiag1*xp(nm1))/ &
          (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
  yp(n) = (yp(n)-sdiag2*yp(1)-sdiag1*yp(nm1))/ &
          (diag1+diag2+sdiag2*temp(1)+sdiag1*temp(nm1))
!
! perform second step of back substitution
!
  xpn = xp(n)
  ypn = yp(n)
  do 6 i = 1,nm1
    xp(i) = xp(i)+temp(i)*xpn
6   yp(i) = yp(i)+temp(i)*ypn
  return
!
! too few points
!
7 ierr = 1
  return
!
! coincident adjacent points
!
8 ierr = 2
  return
end
subroutine kurvp2 (t,xs,ys,n,x,y,xp,yp,s,sigma)
!
!*******************************************************************************
!
!! KURVP2 performs the interval (0.,1.) onto a closed plane curve.
!  the
! subroutine kurvp1 should be called earlier to determine
! certain necessary parameters. the resulting curve has a
! parametric representation both of whose components are
! periodic splines under tension and functions of the poly-
! gonal arclength parameter.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   t contains a value to be mapped onto the curve. the
!   interval (0.,1.) is mapped onto the entire closed curve
!   with both 0. and 1. mapping to (x(1),y(1)). the mapping
!   is periodic with period one thus any interval of the
!   form (tt,tt+1.) maps onto the entire curve.
!
!   n contains the number of points which were specified
!   to determine the curve.
!
!   x and y are arrays containing the x- and y-coordinates
!   of the specified points.
!
!   xp and yp are the arrays output from kurvp1 containing
!   curvature information.
!
!   s is an array containing the polygonal arclengths of
!   the curve.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, xp, yp, s and sigma should
! be input unaltered from the output of kurvp1.
!
! on output--
!
!   xs and ys contain the x- and y-coordinates of the image
!   point on the curve.
!
! none of the input parameters are altered.
!
! this subroutine references package modules intrvl and
! snhcsh.
!
  integer n
  real t,xs,ys,x(n),y(n),xp(n),yp(n),s(n),sigma
!
! determine interval
!
  tn = t-real(ifix(t))
  if (tn < 0.) tn = tn+1.
  tn = s(n)*tn+s(1)
  im1 = n
  if (tn < s(n)) im1 = intrvl(tn,s,n)
  i = im1+1
  if (i > n) i = 1
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n)/s(n)
!
! set up and perform interpolation
!
  si = s(i)
  if (im1 == n) si = s(n)+s(1)
  del1 = tn-s(im1)
  del2 = si-tn
  dels = si-s(im1)
  sumx = (x(i)*del1+x(im1)*del2)/dels
  sumy = (y(i)*del1+y(im1)*del2)/dels
  if (sigmap /= 0.) go to 1
  d = del1*del2/(6.*dels)
  c1 = (del1+dels)*d
  c2 = (del2+dels)*d
  xs = sumx-xp(i)*c1-xp(im1)*c2
  ys = sumy-yp(i)*c1-yp(im1)*c2
  return
1 delp1 = sigmap*(del1+dels)/2.
  delp2 = sigmap*(del2+dels)/2.
  call snhcsh(sinhm1,dummy,sigmap*del1,-1)
  call snhcsh(sinhm2,dummy,sigmap*del2,-1)
  call snhcsh(sinhms,dummy,sigmap*dels,-1)
  call snhcsh (sinhp1,dummy,sigmap*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmap*del2/2.,-1)
  call snhcsh (dummy,coshp1,delp1,1)
  call snhcsh (dummy,coshp2,delp2,1)
  d = sigmap*sigmap*dels*(sinhms+sigmap*dels)
  ci = (sinhm1*del2-del1*(2.*(coshp1+1.)*sinhp2+sigmap* &
       coshp1*del2))/d
  cim1 = (sinhm2*del1-del2*(2.*(coshp2+1.)*sinhp1+ &
         sigmap*coshp2*del1))/d
  xs = sumx+ci*xp(i)+cim1*xp(im1)
  ys = sumy+ci*yp(i)+cim1*yp(im1)
  return
end
subroutine l2slv(m, n, m1, l, a, mm, b, mb, w, tol, n1, ipivot, &
                   x, nn, res, mr, qr, mmpnn, c, ifault)
!
!*******************************************************************************
!
!! L2SLV computes least squares solutions to over/under-determined systems.
!
! the method used is
! a modified gram-schmidt orthogonal decomposition with iterative
! refinement of the solution.  the solution may be subject to linear
! equality constraints.  output includes the least squares
! coefficients, residuals, unscaled covariance matrix, and information
! on the behavior of the iterative refinement procedure.
! matrix a is the given matrix of a system of m linear equations in n
! unknowns, and matrix w is a given diagonal matrix of weights with all
! diagonal elements nonnegative.  let h = w*a.
! in the event that n1 (the computed rank of matrix h) is less than n
! (the number of unknown coefficients), a unique solution vector having
! n elements can be obtained by imposing the condition that the
! solution be of minimal euclidean norm.  such a solution is sought in
! the case of underdetermined or rank-deficient problems.
!
! ** input variables **
! m      total number of equations.
! n      number of unknown coefficients.
! m1     number of linear constraints (0 <= m1 <= m and m1 <= n).
! l      number of right-hand sides (vectors of observations).
! a      two-dimensional array of size (mm,n).  on entry, the array a
!        contains the given matrix of a system of m linear equations
!        in n unknowns, where the first m1 equations are to be
!        satisfied exactly.  a is left intact on exit.
! b      two-dimensional array of size (mb,l).  on entry, b contains
!        the l given right-hand sides (vectors of observations).  b is
!        left intact on exit.
! w      vector of size m.  on entry, w contains the diagonal elements
!        of a given diagonal matrix of weights, all nonnegative.
!        (the first m1 elements of w are set equal to 1.0 by the
!        program when m1 is greater than zero.)
! tol    parameter used in determining the rank of matrix h.
!        note --
!        (1) if tol equals zero, the tolerance used in subroutine
!            decom2 will be based on machine precision.
!        (2) if tol is greater than zero, this value of tol will be
!            used in setting an absolute tolerance for comparison with
!            diagonal elements of the triangular matrix obtained in
!            subroutine decom2.  the value of tol can be based on
!            knowledge concerning the accuracy of the data.
! mm     dimensioning parameter specifying maximum number of rows in
!        the array a.  mm must satisfy mm >= m.
! mb     dimensioning parameter specifying maximum number of rows in
!        the array b.  mb must satisfy mb >= m.
! mr     dimensioning parameter specifying maximum number of rows in
!        the array res.  mr must satisfy mr >= m.
! nn     dimensioning parameter specifying maximum number of rows in
!        the array x.  nn must satisfy nn >= n.
! mmpnn  dimensioning parameter specifying maximum number of rows in
!        the array qr.  mmpnn must satisfy mmpnn >= m+n.
!
! ** output variables and internal variables **
! n1     computed rank of matrix h, where h = w*a.
! ipivot vector of size n.  on exit, this array records the order
!        in which the columns of h were selected by the pivoting
!        scheme in the course of the orthogonal decomposition.
!        whenever n1 < n, the first n1 elements of ipivot indicate
!        which columns of h were found to be linearly independent.
! x      two-dimensional array of size (nn,l).  on exit, x contains
!        the solution vectors.
! res    two-dimensional array of size (mr,l).  on exit, res contains
!        the residual vectors.
! qr     two-dimensional array of size (mmpnn,n).  on exit, if n1 = n
!        then qr contains the unscaled covariance matrix. (qr is used
!        internally to store the results from the subroutine decom2.
!        the results from decom2 are destroyed when the covariance
!        matrix is computed.)
! c      vector having at least 6*(m+n)+2*l elements used (1) for
!        internal work space and (2) for returning information on the
!        behavior of the iterative refinement procedure.
!        (a) numit is the number of iterations carried out during the
!            iterative refinement in attempting to obtain a solution
!            for the k-th right-hand side.
!            on exit, c(k) = +numit if the solution converged, and
!                     c(k) = -numit if the solution failed to converge.
!        (b) digitx gives an estimate of the number of correct digits
!            in the initial solution of the coefficients for the k-th
!            right-hand side.  on exit, c(k+l) = digitx.
! ifault fault indicator which is zero if no errors were encountered
!        and positive if errors were detected or if evidence of severe
!        ill-conditioning was found.  if ifault is set to 1, 2, 3, 4,
!        5, 6 or 7, execution is terminated.  execution continues when
!        ifault is set equal to 8, 9 or 10 provided that a solution
!        was obtained for at least one right-hand side.  the value of
!        ifault is used to indicate the following --
!        0 = no errors encountered.
!        1 = bad input parameter (m, n or l).
!        2 = bad input parameter (m1).
!        3 = bad dimension.  either m > mm, m > mb, m > mr,
!            n > nn, or m+n > mmpnn.
!        4 = at least one weight is negative.
!        5 = either matrix h or matrix of constraints equals zero.
!        6 = constraints are linearly dependent.
!        7 = all solutions failed to converge.
!        8 = solution failed to converge for at least one right-hand
!            side.
!        9 = large number of iterations required for convergence.
!       10 = estimated number of digits in initial solution of
!            coefficients is small.
!       11 = diagonal element of covariance matrix was computed to be
!            negative owing to rounding error. no severe conditioning
!            problems were detected.
!       12 = diagonal element of covariance matrix was computed to be
!            negative owing to rounding error. the problem appears to
!            be extremely ill-conditioned.
!
! ** subroutines required **
! subroutine decom2
!        uses modified gram-schmidt algorithm with pivoting to
!        obtain an orthogonal decomposition of the input matrix.
! subroutine solve2
!        computes coefficients and residuals.  iterative refinement is
!        used to improve the accuracy of the initial solution.
! subroutine solve3
!        called only by subroutine solve2.
! subroutine covar
!        computes unscaled covariance matrix of the coefficients.
!
! ** storage requirements **
! the storage required for the dimensioned arrays in l2slv is
!   m*(2*n + 2*l + 7) + n*(n + l + 7) + 2*l
! locations.  all arrays required in subroutines called by l2slv are
! declared herein and are transmitted only through parameter lists of
! call-sequences.
!
! ** precision of arithmetic calculations **
! single precision arithmetic is used for all calculations except the
! double precision accumulation of inner products.  (the variable sum
! is declared to be double precision in subroutines decom2, solve2,
! solve3 and covar.)  it is essential for the success of the iterative
! refinement procedure that inner products be accumulated in double
! precision.
!
! ** conversion of the program to double precision **
!
! * on computers having short word length (as the ibm 360/370) it may *
! * be desirable to perform all calculations in double precision.  in *
! * this case, the iterative refinement presently included in solve2  *
! * should be omitted.                                                *
! * to convert the program to double precision, the following         *
! * approach is suggested.                                            *
! *                                                                   *
! * 1. variables presently declared to be real should be declared     *
! *    double precision.  those typed integer, double precision and   *
! *    logical should not be changed.                                 *
! * 2. the use of fail, numit and digitx should be omitted.           *
! * 3. description of variable c (at l2b 690-790) should read --      *
! *    c  vector having at least 6*(m+n) elements used only for       *
! *       internal work space.                                        *
! * 4. the value of eta (at l2b 1960) should be set so that it is the *
! *    smallest positive double precision number such that 1.0 + eta  *
! *    is greater than 1.0 in double precision arithmetic.            *
! *    for ibm computer type, eta = 16.**(-13)                        *
! *    for univac computer type, eta = 2.**(-59)                      *
! * 5. the following fortran functions should be changed --           *
! *      single precision name     double precision name              *
! *             dble(x)                x                              *
! *             real(n)               dble(float(n))                 *
! *             sqrt(x)                dsqrt(x)                       *
! *    dble(x) is used in subroutines decom2, solve2, solve3 and      *
! *       covar.                                                      *
! *    real(n) is used in subroutine decom2.                         *
! *    sqrt(x) is used in subroutine l2slv.                           *
! * 6. replace statement l2b 2500 by a statement reading              *
! *          k3 = 1                                                   *
! * 7. further details are given in subroutine solve2 in connection   *
! *    with the omission of iterative refinement.                     *
! * 8. in subroutine l2slv, statements l2b 950-1000, 1820-1830, 2020, *
! *    2350-2360, 2480-2490, 3070, 3280-3570 and 3590-3620 should be  *
! *    omitted.                                                       *
! *    statement numbers given here refer to those in the right-hand  *
! *    margin.  certain comments in subroutine l2slv do not apply to  *
! *    the double precision version.                                  *
! *                                                                   *
!
  integer ipivot(n)
  real a(mm,n), b(mb,l), c(*), eta, qr(mmpnn,n), &
   res(mr,l), tol, w(m), x(nn,l)
  real digitx
  logical fail
  logical sing
!
! set value of eta, a machine-dependent parameter.
! eta, the relative machine precision, is the smallest positive real
! number such that 1.0 + eta is greater than 1.0 in floating-point
! arithmetic.
!
  eta = epsilon ( eta )
!
! default value for tol is zero.
!
  if (tol < 0.0) tol = 0.0
  ifault = 0
  ksum = 0
!
! perform initial checking of input parameters, dimensions and
! weights for possible errors.
!
  if (m > 0 .and. n > 0 .and. l > 0) go to 10
  ifault = 1
  return
   10 if (m1 <= m .and. m1 <= n .and. m1 >= 0) go to 20
  ifault = 2
  return
   20 if (m <= mm .and. m <= mb .and. m <= mr .and. n <= nn &
              .and. m+n <= mmpnn) go to 30
  ifault = 3
  return
   30 do 40 i=1,m
    if (m1 > 0 .and. i <= m1) w(i) = 1.0
    if (w(i) >= 0.0) go to 40
    ifault = 4
    return
   40 continue
!
! set parameters which allocate vector c to contain certain final
! results and also to be used as work space.
!
! k1 is starting point for numit and fail, of length l.
! k2 is starting point for digitx, of length l.
! k3 is starting point for d, of length n.
! k4 is starting point for k-th column of b, of length m.
! k5 is starting point for k-th column of x, of length n.
! k6 is starting point for k-th column of res, of length m.
! k7 is starting point for work space of length m.
! k8 is starting point for work space of length m.
! k9 is starting point for work space of length n.
! k10 is starting point for work space of length n.
! k11 is starting point for work space of length m + n.
! k12 is starting point for work space of length m + n.
!
  k1 = 1
  k2 = k1 + l
  k3 = k2 + l
  k4 = k3 + n
  k5 = k4 + m
  k6 = k5 + n
  k7 = k6 + m
  k8 = k7 + m
  k9 = k8 + m
  k10 = k9 + n
  k11 = k10 + n
  k12 = k11 + m + n
  k = k12 + m + n - 1
!
! multiply each row of matrix a (m by n) by its appropriate weight and
! store the result in the first m rows of array qr.  set array c and
! the last n rows of array qr equal to zero.
!
  do 60 i=1,k
    c(i) = 0.0
   60 continue
  mp1 = m + 1
  mpn = m + n
  do 90 j=1,n
    do 70 i=1,m
      qr(i,j) = a(i,j)*w(i)
   70   continue
    do 80 i=mp1,mpn
      qr(i,j) = 0.0
   80   continue
   90 continue
!
! obtain an orthogonal decomposition of the matrix stored in the first
! m rows of array qr and compute its rank.
!
  call decom2(m, n, m1, eta, tol, qr, c(k3), n1, ipivot, sing, &
   mmpnn)
!
  if (.not.sing) go to 110
  if (n1 > 0) go to 100
  ifault = 5
  return
  100 ifault = 6
  return
!
! seek a solution (coefficients and residuals) for each of the l least
! squares problems whose right-hand sides are given in the array b.
!
  110 iter = -alog10(eta)
  do 200 k=1,l
! k-th right-hand side.
    k0 = k4 - 1
    do 120 i=1,m
      k0 = k0 + 1
      c(k0) = b(i,k)
  120   continue
!
    call solve2(m, n, m1, a, c(k4), w, n1, ipivot, qr, c(k3), &
     eta, fail, numit, digitx, &
     c(k5), c(k6), c(k7), c(k8), c(k9), c(k10), c(k11), c(k12), &
     mm, mmpnn)
!
    k0 = k5 - 1
    do 130 j=1,n
      k0 = k0 + 1
      x(j,k) = c(k0)
  130   continue
    if (m1==0) go to 150
    do 140 i=1,m1
      res(i,k) = 0.0
  140   continue
  150   m1p1 = m1 + 1
    if (m1p1 > m) go to 170
    k0 = k6 + m1 - 1
    do 160 i=m1p1,m
      k0 = k0 + 1
      res(i,k) = c(k0)
  160   continue
  170   continue
!
! for right-hand sides where convergence of a solution is reported,
! a check is made for evidence of severe ill-conditioning.  such
! evidence is furnished by large values of numit (number of iterations
! before convergence was obtained) and small values of digitx
! (estimate of the number of correct digits in the initial solution
! of the coefficients).  if numit exceeds -alog10(eta) then ifault
! is set to 9.  if digitx is less than 0.5 (half a decimal digit)
! then ifault is set to 10.
!
    c(k) = real(numit)
    if (fail) c(k) = -c(k)
    k0 = k2 + k - 1
    c(k0) = digitx
    if (.not.fail) go to 180
! ksum is a tally of solutions which failed to converge.
    ksum = ksum + 1
    ifault = 8
    go to 200
  180   if (numit <= iter) go to 190
    ifault = 9
  190   if (digitx >= 0.5) go to 200
    ifault = 10
  200 continue
  if (ksum < l) go to 210
  ifault = 7
  return
  210 if (n1 < n) return
  do 230 i=1,n
    mpi = m + i
    do 220 j=1,n
      qr(i,j) = qr(mpi,j)
  220   continue
    qr(i,i) = 0.0
  230 continue
!
! compute the unscaled covariance matrix of the coefficients.
!
  call covar(n, m1, n1, ipivot, qr, c(k3), c(k9), mmpnn)
  if (n==1) go to 260
  do 250 j=2,n
  jm1 = j - 1
    do 240 i=1,jm1
  240   qr(i,j) = qr(j,i)
  250 continue
!
! in certain problems, some diagonal terms of the unscaled covariance
! matrix are equal to zero or to small positive numbers.  because of
! rounding errors, computed values for these terms may be small
! negative numbers.  ifault is set to 11 if this occurs.
!
  260 do 270 j=1,n
    if (qr(j,j) < 0.0) go to 280
  270 continue
  return
  280 if (ifault/=0) go to 290
  ifault = 11
  return
  290 ifault = 12
  return
end
subroutine lainv(mo,fun,t,aerr,rerr,y,c,error,num,ierr)
!
!*******************************************************************************
!
!! LAINV calculates the inverse Laplace transform of a given function
!  which is not too oscillatory.
!
!
!  Parameters:
!
!     mo is an input integer which specifies the search procedure
!     for determination of c.  a two-pass procedure is used when
!     mo = 0 , and a one-pass procedure is used when mo is not zero.
!     when all singularities of f(z) are expected to be real, mo = 0
!     is preferable.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     t is a positive value of the independent variable for which
!     the inverse Laplace transform is to be calculated.
!
!     c is the abscissa of convergence.  it may be either given
!     or calculated by lainv.
!
!     y is the calculated value of the inverse Laplace transform.
!
!     aerr is the absolute accuracy requested.
!     rerr is the relative accuracy requested.  the subroutine
!     attempts to satisfy the less stringent of the two requirements.
!     it is assumed that aerr and rerr are >= 0.  if one wants
!     accuracy to k significant figures, then rerr should be
!     set = 10.0**(-k).
!
!     error is the estimated absolute error of y.
!
!     num is the number of evaluations of fun in lainv.
!
!     ierr may be either an input integer or an output integer.  when
!     ierr is equal to any negative integer at the beginning of lainv,
!     the abscissa of convergence is calculated and the value obtained
!     is assigned to the argument c.  otherwise, c must be input by
!     the user.  after completion of lainv, ierr has one of the
!     following values...
!
!          ierr = 0     the calculation was fully successful.
!
!          ierr = 1     the calculated value of y may not be accurate
!                       due to possible inaccuracy in the calculation
!                       of c.  this value of ierr may occur only when
!                       ierr is initially negative.
!
!          ierr = 2     the calculation of y did not converge, while
!                       the given or calculated value of c may be
!                       considered accurate.
!
!          ierr = 3     the calculation of y did not converge, and the
!                       calculated value of c may be inaccurate.  this
!                       value of ierr may occur only when ierr is
!                       initially negative.
!
!          ierr = 4     the value of t is less than or equal to 0.
!                       the special values y = 0.0 and error = 1.0
!                       are assigned.
!
!          ierr = 5     c was not found in the interval (-1.0e4,1.0e4).
!                       the special values c = 0.0, y = 0.0, and
!                       error = 1.0 are assigned.
!                       this value of ierr may occur only when
!                       ierr is initially negative.
!
!          ierr = 6     t is too large for the inverse transform to be
!                       computed. the values y = 0.0 and error = 1.0
!                       are assigned.
!
  external fun
!
  num = 0
  ierc = -1
  if(ierr >= 0) go to 10
!
!     calculation of the abscissa of convergence.
!
  if(mo == 0) go to 5
     call abcon1(fun,c,num,ierc)
     go to 10
5 call abcon(fun,c,num,ierc)
   10 if(ierc == 2) go to 100
!
!     check if t is too large
!
   15 a = c + 2.0/t
  if (a*t > exparg(0)) go to 110
!
!     calculation of the inverse Laplace transform.
!
     call lainv1(fun,t,c,rerr,aerr,y,error,num1,ier)
     num = num + num1
     if(ierc >= 0) go to 20
     if(ier == 0) go to 30
     if(ier == 1) go to 50
   20    if(ier == 2) go to 80
     if(ier == 1) go to 60
     if(ierc == 1) go to 40
   30    ierr = 0
     return
   40    ierr = 1
     return
   50    ierr = 2
     return
   60    if(ierc == 1) go to 70
     ierr = 2
     return
   70    ierr = 3
     return
   80    ierr = 4
     return
!
!     error return when c cannot be calculated
!
  100 y = 0.0
  error = 1.0
  ierr = 5
  return
!
!     t is too large for the inverse transform to be computed
!
  110 y = 0.0
  error = 1.0
  ierr = 6
  return
end
subroutine lainv1(fun,t,c,epsre,epsab,result,esterr,num, ier)
!
!*******************************************************************************
!
!! LAINV1 is used by lainv.
!
!
!   1. lainv1
!        inversion of Laplace transform using the durbin formula
!        in combination with the epsilon algorithm
!
!   2. purpose
!        the routine calculates an approximation result to the
!        inverse Laplace transform f(t) of fun, for the value
!        of the independent variable equal to t, hopefully
!        satisfying the following claim for accuracy ....
!        abs(f(t)-result) <= max(epsab,epsre*abs(f(t)))
!
!   3. calling sequence
!        call lainv1(fun,t,c,epsre,epsab,result,esterr,num,ier)
!
!      input parameters
!        fun    - real
!                 subroutine defining the Laplace transform as
!                 a complex function.  the calling sequence of
!                 fun is call fun(a,b,c,d) where
!                 a - real
!                     real part of the independent variable
!                     of the Laplace transform (input)
!                 b - real
!                     imaginary part of the independent
!                     variable of the Laplace transform (input)
!                 c - real
!                     real part of the value of the Laplace
!                     transform (output)
!                 d - real
!                     imaginary part of the value of the
!                     Laplace transform (output)
!                 the actual name for fun needs to be declared
!                 external in the driver program.
!
!        t      - real
!                 value of the independent variable for which the
!                 inverse Laplace transform has to be computed.
!                 t should be greater than zero.
!
!        c      - real
!                 abscissa of convergence of the Laplace transform
!
!        epsre  - real
!                 relative accuracy requested.  it is assumed that
!                 epsre >= 0.  if one wants accuracy to k significant
!                 figures, then rerr should be set = 10.0**(-k).
!
!        epsab  - real
!                 absolute accuracy requested.  it is assumed that
!                 epsab >= 0.  the routine tries to satisfy the
!                 least stringent of both accuracy requirements.
!
!      output parameters
!        result - real
!                 inverse Laplace transform
!
!        esterr - real
!                 estimate of the absolute error abs(f(t)-result)
!
!        num    - integer
!                 number of evaluations of fun
!
!        ier    - integer
!                 parameter giving information on the termination
!                 of the algorithm
!                 ier = 0 normal and reliable termination of the
!                         routine
!                 ier = 1 the computations are terminated because
!                         the bound on the number of evaluations
!                         of fun has been achieved.  this bound
!                         is equal to 8*max+5 where  max  is a
!                         number initialized in a data
!                         statement.  one can allow more function
!                         evaluations by increasing the value of
!                         max in the data-statement.
!                 ier = 2 the value of t is less than or equal
!                         to zero.
!
!   4. subroutines or functions needed
!                fun - user provided subroutine
!                cqext - epsilon algorithm
!
  complex rex,cres,res3la
  integer i,ier,k,kc,kk,ks,m,nex,nres,num
  dimension si(32),res3la(3),rex(52)
!
!   the array si contains values of the sine and cosine functions
!   required in the durbin formula. si(8) and si(16) are given in
!   the following data statement. the other values are computed.
!
  data si(8),si(16)/ 1.0e+00,0.0e+00/
!
!   max3 is a bound on the number of terms used in the durbin
!   formula.
!
  data max3/500/
!
  eps = epsilon ( eps )
!
!
!   calculation of the relative tolerance used.
!
  tol = 10.0*eps
  epsr1 = max ( tol,epsre)
!
!   test on validity of the input parameter t
!
  ier = 2
  result = 0.0e+00
  esterr = 1.0e+00
  num = 0
  if (t <= 0.0e+00) go to 999
!
!   pid16 is equal to pi/16
!
  pid16 = atan(1.0e+00)/4.0e+00
!
!   computation of the elements of the array si
!
  ak = 1.0e+00
  do 10 k=1,7
    si(k) = sin(ak*pid16)
    ak = ak+1.0e+00
    kk = 16-k
    si(kk) = si(k)
10    continue
  ier = 0
  nres = 0
  do 20 k=17,32
    si(k) = -si(k-16)
20    continue
!
!   initialization of the summation of the durbin formula.
!
  arg = pid16/t
  are = c+2.0e+00/t
  aim = 0.0e+00
  bb = exp(are*t)/(1.6e+01*t)
  call fun (are,aim,fre,fim)
  num = 5
  r = 5.0e-01*fre
  s = 0.0
  nex = 0
  kc = 8
  ks = 0
!
!   main loop for the summation
!
  do 40 i=1,max3
    m = 8
    if (i==1) m = 12
    do 30 k=1,m
      aim = aim+arg
      kc = kc+1
      ks = ks+1
      if (kc > 32) kc = 1
      if (ks > 32) ks = 1
      call fun(are,aim,fre,fim)
  a = fre*si(kc)
  b = -fim*si(ks)
  r = dble(r) + dble(a) + dble(b)
  e = fre*si(ks)
  f = fim*si(kc)
  s = dble(s) + dble(e) + dble(f)
30      continue
    num = num+8
    nex = nex+1
    rex(nex) = cmplx(r, s)
!
!   extrapolation using the epsilon algorithm
!
    if(nex >= 3) call cqext(nex,rex,cres,esterr,res3la,nres)
    if(nres < 4) go to 40
!
!   computation of intermediate result and estimate of the
!   absolute error
!
    result = real(cres)
    result = result * bb
    esterr = esterr * bb
    if (esterr < max ( epsab,epsr1*abs(result)).and.abs(r*bb- &
     result) < 5.0e-01*abs(result)) go to 999
40    continue
!
!   set error flag in the case that the number of terms in the
!   summation is equal to max3
!
  ier = 1
999   return
end
subroutine le (rowk,n,b,c,d,ip,ierr)
!
!*******************************************************************************
!
!! LE: solution of linear equations with reduced storage
!
  real b(n),c(n),d(*)
  integer ip(*)
  external rowk
  data zero/0.0/
!
!     set the necessary constants
!
  ierr = 0
  np1 = n + 1
  max = n*n/4 + n + 3
  k = 1
  iflag = -1
!
!     get the first column of the transposed system
!
  call rowk(n,1,c)
  bk = b(1)
!
  if (n > 1) go to 10
  if (c(1) == zero) go to 200
  c(1) = bk/c(1)
  return
!
!     find the pivot for column 1
!
   10 m = 1
  do 20 i = 2,n
  if (abs(c(m)) < abs(c(i))) m = i
   20 continue
!
  ip(1) = m
  c1 = c(m)
  c(m) = c(1)
  c(1) = c1
  if (c(1) == zero) go to 200
!
!     find the first elementary matrix and store it in d
!
  do 30 i = 2,n
   30 d(i-1) = -c(i)/c(1)
  d(n) = bk/c(1)
!
!     k loop - each k for a new column of the transposed system
!
  do 120 k = 2,n
  kp1 = k + 1
  km1 = k - 1
!
!       get column k
!
  call rowk(n,k,c)
  do 40 j = 1,km1
  m = ip(j)
  cj = c(j)
  c(j) = c(m)
   40 c(m) = cj
  bk = b(k)
!
  iflag = -iflag
  lcol = np1 - k
  lcolp1 = lcol + 1
  lastm1 = 1
  last = max - n + k
  if (k == 2) go to 50
!
  lastm1 = max - n + km1
  if (iflag < 0) last = last - n + k - 2
  if (iflag > 0) lastm1 = lastm1 - n + k - 3
!
!     j loop - effect of columns 1 to k-1 of l-inverse
!
   50 do 61 j = 1,km1
  cj = c(j)
  ij = (j-1)*lcolp1
  if (j == km1) ij = lastm1 - 1
!
!     i loop - effect of l-inverse on rows k to n+1
!
  do 60 i = k,n
  ij = ij + 1
   60 c(i) = c(i) + d(ij)*cj
   61 bk = bk - d(ij+1)*cj
!
!       k=n case
!
  m = k
  if (k < n) go to 70
  if (c(k) == zero) go to 200
  d(last) = bk/c(k)
  go to 90
!
!     find the pivot
!
   70 do 71 i = kp1,n
  if (abs(c(m)) < abs(c(i))) m = i
   71 continue
!
  ip(k) = m
  ck = c(m)
  c(m) = c(k)
  c(k) = ck
  if (c(k) == zero) go to 200
!
!     find the k-th elementary matrix
!
  ik = last
  do 80 i = kp1,n
  d(ik) = -c(i)/c(k)
   80 ik = ik + 1
  d(ik) = bk/c(k)
!
!     form the product of the elementary matrices
!
   90 do 110 j = 1,km1
  kjold = j*lcolp1 + k - np1
  mjold = kjold + m - k
  ij = (j-1)*lcol
  ijold = ij + j
  if (j /= km1) go to 100
!
  kjold = lastm1
  mjold = lastm1 + m - k
  ijold = lastm1
!
  100 ik = last - 1
  dkj = d(mjold)
  d(mjold) = d(kjold)
  do 110 i = kp1,np1
  ij = ij + 1
  ijold = ijold + 1
  ik = ik + 1
  d(ij) = d(ijold) + d(ik)*dkj
  110 continue
  120 continue
!
  last = max
  if (iflag < 0) last = max - 2
  d(n) = d(last)
!
!     insert the solution in c
!
  do 130 i = 1,n
  130 c(i) = d(i)
!
  nm1 = n - 1
  do 140 i = 1,nm1
  k = n - i
  m = ip(k)
  ck = c(k)
  c(k) = c(m)
  140 c(m) = ck
  return
!
!     the system is singular
!
  200 ierr = k
  return
end
subroutine leave(ierset,nf,mf,xv,tv,wv,error,kernel,rhfcn,ep, &
     iflag,x,t,nt,ier,eps,elinsy,tn,wn,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,xnorm)
!
!*******************************************************************************
!
!! LEAVE sets all necessary parameters for leaving iegaus.
!
!
!   if nt > 0, it also performs the necessary nystrom
!   interpolation at the nodes given in t.
!
  real kernel,kmm,kmn,knm,imknn,lufact,normk,numr1
  dimension x(*),t(*),xv(mf),tv(mf),wv(mf),tn(nf),wn(nf),wm(mf), &
     xm(mf),xmz(mf),kmm(nup,nup),kmn(nup,nhalf),knm(nhalf,nup), &
     rhs(mf),imknn(nup,nup),lufact(nup,nup),r(mf),rh(nf), &
     tm(mf),deln(nf)
  common/xxinfo/r1,r2,finlep,normk,nfinal,mfinal
  external kernel,rhfcn
!   set error parameters for return.
  normk=0.0
  nfinal=nf
  mfinal=mf
  finlep=eps
  if((eps > ep) .and. (error <= eps)) go to 10
  ier=ierset
  ep=error
  if(nt == 0) go to 20
  go to 30
10    ier=3
!   since eps is the smallest error possible, set ep=eps for the
!   return error estimate.
  ep=eps
  if(nt > 0) go to 30
!   no nystrom interpolation is desired. return the values at the
!   gaussian node points.
20    do 21 i=1,mf
  x(i)=xv(i)
21    t(i)=tv(i)
  nt=mf
  return
!   calculate norm(k).
30    savep=ep
  do 31 i=1,nf
31    imknn(i,i)=imknn(i,i)-1.0
  normk=0.0
  do 33 i=1,nf
  sum=0.0
  do 32 j=1,nf
32    sum=sum+abs(imknn(i,j))
33    normk=max ( normk,sum)
  do 34 i=1,nf
34    imknn(i,i)=imknn(i,i)+1.0
  if(nf == mf) go to 50
!   iterate to decrease the noise level in x. this should reduce possibl
!   errors in nystrom interpolation.
40    derror=((1.0-r1)/r1)*eps/normk
  if(iflag == 1) derror=derror*xnorm
  itloop=0
  do 41 i=1,mf
41    xm(i)=xv(i)
42    do 43 i=1,mf
43    xmz(i)=xm(i)
  call itert(kernel,rhfcn,nf,tn,wn,mf,tm,wm,xm,xmz,kmm,kmn,knm, &
     rhs,imknn,lufact,r,rh,deln,nup,nhalf,1)
  numr1=rnrm(xm,xmz,mf,1)
  itloop=itloop+1
  if((numr1 > derror) .and. (itloop < 5)) go to 42
  do 44 i=1,mf
44    xv(i)=xm(i)
!   estimate new error bound for nystrom interpolates.
45    temp=normk*(r1/(1.0-r1))*numr1
  if(iflag == 1) temp=temp/xnorm
  ep=max ( ep,temp)
  go to 60
!   no iteration used in computing x. just compute error estimate in
!   nystrom interpolate.
50    temp=normk*elinsy
  if(iflag == 0) temp=temp*xnorm
  if(ier /= 2) ep=max ( ep,temp)
!   compute nystrom interpolates at the nodes in t.
60    do 62 i=1,nt
  sum=0.0
  do 61 j=1,mf
61    sum=sum+wv(j)*kernel(t(i),tv(j))*xv(j)
62    x(i)=rhfcn(t(i))+sum
  if((ier == 0) .and. (ep > eps)) ier=4
  if((ier == 1) .and. (ep > error)) ier=5
  if((ier == 3) .and. (ep > eps)) ier=6
  ep=savep
  return
end
subroutine lgrngn (au, na, an)
!
!*******************************************************************************
!
!! LGRNGN: lagrangian normalization factors
!
!     au = coordinate arguments  (n-array)
!     na = number of arguments   (n)
!     an = normalization factors (n-array)
!
  dimension au(*), an(*)
  001 do 003 k=1,na
  tm=1.0
  do 002 m=1,na
  if(m==k)go to 002
  dm=au(k)-au(m)
  tm=dm*tm
  002 continue
  an(k)=tm
  003 continue
  return
end
subroutine lgrngv (mo, na, qu, au, an, ff, df, sf)
!
!*******************************************************************************
!
!! LGRNGV: lagrangian function evaluation
!
!     mo = mode of operation
!     na = number of stations
!     qu = argument of functions
!     au = station coordinates                    (n-array)
!     an = normalization factors                  (n-array)
!     ff = lagrangian functions                   (n-array)
!     df = first derivatives                      (n-array)
!     sf = second derivatives                     (n-array)
!
!     call lgrngv (0, na, qu, au, an, ff)         for functions
!     call lgrngv (1, na, qu, au, an, ff, df)     for first derivatives
!     call lgrngv (2, na, qu, au, an, ff, df, sf) for second derivatives
!
  dimension au(*), an(*), ff(*), df(*), sf(*)
  logical ln
!
  001 continue

  ln=.true.
  tm=1.0

  do k = 1, na

    if ( qu == au(k) ) then
      ln = .false.
    else
      dm = qu - au(k)
      tm = dm * tm
    end if

  end do

  do 7 k=1,na
  if(ln)go to 005
  if(qu/=au(k))go to 005
  ff(k)=tm
  go to 006
  005 dm=qu-au(k)
  ff(k)=tm/dm
  006 ff(k)=ff(k)/an(k)
  7 continue

  if(mo <= 0)go to 050
  sm=0.0

  do 013 k=1,na
  df(k)=sm
  if(ln)go to 012
  if(qu==au(k))go to 013
  012 dm=qu-au(k)
  sm=sm+1.0/dm
  013 continue

  rm=sm
  if(mo==1)go to 040
  sm=0.0
  do 023 k=1,na
  sf(k)=sm
  if(ln)go to 022
  if(qu==au(k))go to 023
  022 dm=qu-au(k)
  sm=sm+2.0*df(k)/dm
  023 continue
  sm=0.0
  tm=0.0
  l=na
  if(ln)go to 034
  do 033 k=1,na
  sf(l)=tm+sf(l)+2.0*sm*df(l)
  if(qu==au(l))go to 032
  sf(l)=2.0*(sm+df(l))
  dm=qu-au(l)
  tm=tm+2.0*sm/dm
  sm=sm+1.0/dm
  032 l=l-1
  033 continue
  go to 036
  034 do 035 k=1,na
  sf(l)=tm+sf(l)+2.0*sm*df(l)
  dm=qu-au(l)
  tm=tm+2.0*sm/dm
  sm=sm+1.0/dm
  l=l-1
  035 continue
  036 do 037 k=1,na
  sf(k)=ff(k)*sf(k)
  037 continue
  040 if (ln) go to 043
  do 042 k=1,na
  if (qu/=au(k)) go to 041
  df(k)=rm
  ff(k)=1.0
  go to 042
  041 df(k)=ff(k)
  ff(k)=0.0
  042 continue
  return
  043 sm=0.0
  l=na
  do 044 k=1,na
  df(l)=ff(l)*(sm+df(l))
  sm=sm+1.0/(qu-au(l))
  l=l-1
  044 continue
  return
  050 if(ln)go to 053
  do 052 k=1,na
  ff(k)=0.0
  if(qu/=au(k))go to 052
  ff(k)=1.0
  052 continue
  053 return
end
subroutine lgrngx (au, na, ac)
!
!*******************************************************************************
!
!! LGRNGX: lagrangian polynomial expansion
!
!     au = coordinate arguments    (n-array)
!     na = number of arguments     (n)
!     ac = polynomial coefficients (nx(n+1) array)
!
  dimension au(*), ac(*)
  001 do 003 i=1,na
  k=(i-1)*na
  l=k+i
  ac(l)=1.0
  sm=0.0
  do 002 j=1,i
  k=k+1
  l=k+na
  ac(l)=sm-au(i)*ac(k)
  sm=ac(k)
  002 continue
  003 continue
  do 005 i=1,na
  k=na+na*na
  l=i*na
  ac(l)=1.0
  do 004 j=2,na
  sm=au(i)*ac(l)
  l=l-1
  ac(l)=sm+ac(k)
  k=k-1
  004 continue
  005 continue
  do 008 i=1,na
  tm=1.0
  do 006 j=1,na
  if(j==i)go to 006
  td=au(i)-au(j)
  tm=tm*td
  006 continue
  k=(i-1)*na
  do 007 j=1,na
  k=k+1
  ac(k)=ac(k)/tm
  007 continue
  008 continue
  return
end
subroutine llsq(m,n,a,ka,b,kb,nb,wk,iwk,ierr)
!
!*******************************************************************************
!
!! LLSQ: ???
!
  dimension a(ka,n),b(kb,nb),wk(n),iwk(n)
  logical exit
!
  ierr = 0
  if (1 < n .and. n <= m) go to 10
  ierr = 1
  return
!
   10 np1 = n + 1
  call ortho(m,n,a,ka,wk,iwk,exit)
  if (exit) go to 20
  ierr = 2
  return
!
   20 do 22 j = 1,nb
  call orsol(m,n,a,ka,wk,iwk,b(1,j))
  if (m == n) go to 22
  rnorm = 0.0
  do 21 i = np1,m
   21    rnorm = rnorm + b(i,j)*b(i,j)
  b(np1,j) = sqrt(rnorm)
   22 continue
  return
end
subroutine llsqmp(m,n,a,ka,b,kb,nb,wk,iwk,ierr)
!
!*******************************************************************************
!
!! LLSQMP ???
!
  dimension a(ka,n),b(kb,nb),wk(*),iwk(n)
  logical exit
!
!     dimension wk(mn + 2m + n)
!
  ierr = 0
  if (1 < n .and. n <= m) go to 10
  ierr = 2
  return
!
   10 np1 = n + 1
  lr = m + 1
  ls = lr + m
  lq = ls + n
!
  call mcopy(m, n, a, ka, wk(lq), m)
  call ortho(m, n, wk(lq), m, wk(ls), iwk, exit)
  if (exit) go to 20
  ierr = 3
  return
!
   20 do 31 j = 1,nb
  do 21 i = 1,m
   21 wk(i) = b(i,j)
  call orsol(m, n, wk(lq), m, wk(ls), iwk, wk(1))
  call orimp(m, n, a, ka, wk(lq), m, wk(ls), iwk, b(1,j), &
                   wk(1), wk(lr), exit)
  do 22 i = 1,n
   22 b(i,j) = wk(i)
  if (.not.exit) ierr = 1
  if (m == n) go to 31
!
  rnorm = 0.0
  do 30 i = np1,m
   30 rnorm = rnorm + wk(i)*wk(i)
  b(np1,j) = sqrt(rnorm)
   31 continue
  return
end
subroutine lltslv (nr,n,a,x,b)
!
!*******************************************************************************
!
!! LLTSLV: solution of ax = b where a has the form l(l-transpose)
!           but only the lower triangular part l is stored.
!
!
!     input ...
!
!       nr       row dimension of matrix
!       n        order of the matrix
!       a(n,n)   matrix of form l(l-transpose). a is not
!                modified by the routine.
!       b(n)     right-hand side vector
!
!     output ...
!
!       x(n)     solution vector
!
!
!     note.  b and x may share the same storage area.
!
  real a(nr,n), x(n), b(n)
!
!                  forward solve, result in x
!
  x(1) = b(1)/a(1,1)
  if (n == 1) go to 30
  do 20 i = 2,n
     sum = 0.0
     im1 = i - 1
     do 10 j = 1,im1
        sum = sum + a(i,j)*x(j)
   10    continue
     x(i) = (b(i) - sum)/a(i,i)
   20 continue
!
!                   back solve, result in x
!
   30 x(n) = x(n)/a(n,n)
  if (n == 1) return
  i = n
  do 50 ii = 2,n
     ip1 = i
     i = i - 1
     sum = 0.0
     do 40 j = ip1,n
        sum = sum + a(j,i)*x(j)
   40    continue
     x(i) = (x(i) - sum)/a(i,i)
   50 continue
  return
end
subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, &
                   diag,mode,factor,nprint,info,nfev,fjac,ldfjac, &
                   ipvt,qtf,wa1,wa2,wa3,wa4)
!
!*****************************************************************************80
!
!! LMDIF minimizes sum of the squares of m nonlinear functions in n variables
!  by a modification of
!     the levenberg-marquardt algorithm. the user must provide a
!     subroutine which calculates the functions. the jacobian is
!     then calculated by a forward-difference approximation.
!
!     the subroutine statement is
!
!       subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
!                        diag,mode,factor,nprint,info,nfev,fjac,
!                        ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(m,n,x,fvec,iflag)
!         integer m,n,iflag
!         real x(n),fvec(m)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of lmdif.
!         in this case set iflag to a negative integer.
!
!       m is a positive integer input variable set to the number
!         of functions.
!
!       n is a positive integer input variable set to the number
!         of variables. n must not exceed m.
!
!       x is an array of length n. on input x must contain
!         an initial estimate of the solution vector. on output x
!         contains the final estimate of the solution vector.
!
!       fvec is an output array of length m which contains
!         the functions evaluated at the output x.
!
!       ftol is a nonnegative input variable. termination
!         occurs when both the actual and predicted relative
!         reductions in the sum of squares are at most ftol.
!         therefore, ftol measures the relative error desired
!         in the sum of squares.
!
!       xtol is a nonnegative input variable. termination
!         occurs when the relative error between two consecutive
!         iterates is at most xtol. therefore, xtol measures the
!         relative error desired in the approximate solution.
!
!       gtol is a nonnegative input variable. termination
!         occurs when the cosine of the angle between fvec and
!         any column of the jacobian is at most gtol in absolute
!         value. therefore, gtol measures the orthogonality
!         desired between the function vector and the columns
!         of the jacobian.
!
!       maxfev is a positive integer input variable. termination
!         occurs when the number of calls to fcn is at least
!         maxfev by the end of an iteration.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       diag is an array of length n. if mode = 1 (see
!         below), diag is internally set. if mode = 2, diag
!         must contain positive entries that serve as
!         multiplicative scale factors for the variables.
!
!       mode is an integer input variable. if mode = 1, the
!         variables will be scaled internally. if mode = 2,
!         the scaling is specified by the input diag. other
!         values of mode are equivalent to mode = 1.
!
!       factor is a positive input variable used in determining the
!         initial step bound. this bound is set to the product of
!         factor and the euclidean norm of diag*x if nonzero, or else
!         to factor itself. in most cases factor should lie in the
!         interval (.1,100.). 100. is a generally recommended value.
!
!       nprint is an integer input variable that enables controlled
!         printing of iterates if it is positive. in this case,
!         fcn is called with iflag = 0 at the beginning of the first
!         iteration and every nprint iterations thereafter and
!         immediately prior to return, with x and fvec available
!         for printing. if nprint is not positive, no special calls
!         of fcn with iflag = 0 are made.
!
!       info is an integer output variable. if the user has
!         terminated execution, info is set to the (negative)
!         value of iflag. see description of fcn. otherwise,
!         info is set as follows.
!
!         info = 0  improper input parameters.
!
!         info = 1  both actual and predicted relative reductions
!                   in the sum of squares are at most ftol.
!
!         info = 2  relative error between two consecutive iterates
!                   is at most xtol.
!
!         info = 3  conditions for info = 1 and info = 2 both hold.
!
!         info = 4  the cosine of the angle between fvec and any
!                   column of the jacobian is at most gtol in
!                   absolute value.
!
!         info = 5  number of calls to fcn has reached or
!                   exceeded maxfev.
!
!         info = 6  ftol is too small. no further reduction in
!                   the sum of squares is possible.
!
!         info = 7  xtol is too small. no further improvement in
!                   the approximate solution x is possible.
!
!         info = 8  gtol is too small. fvec is orthogonal to the
!                   columns of the jacobian to machine precision.
!
!       nfev is an integer output variable set to the number of
!         calls to fcn.
!
!       fjac is an output m by n array. the upper n by n submatrix
!         of fjac contains an upper triangular matrix r with
!         diagonal elements of nonincreasing magnitude such that
!
!                t     t           t
!               p *(jac *jac)*p = r *r,
!
!         where p is a permutation matrix and jac is the final
!         calculated jacobian. column j of p is column ipvt(j)
!         (see below) of the identity matrix. the lower trapezoidal
!         part of fjac contains information generated during
!         the computation of r.
!
!       ldfjac is a positive integer input variable not less than m
!         which specifies the leading dimension of the array fjac.
!
!       ipvt is an integer output array of length n. ipvt
!         defines a permutation matrix p such that jac*p = q*r,
!         where jac is the final calculated jacobian, q is
!         orthogonal (not stored), and r is upper triangular
!         with diagonal elements of nonincreasing magnitude.
!         column j of p is column ipvt(j) of the identity matrix.
!
!       qtf is an output array of length n which contains
!         the first n elements of the vector (q transpose)*fvec.
!
!       wa1, wa2, and wa3 are work arrays of length n.
!
!       wa4 is a work array of length m.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer m,n,maxfev,mode,nprint,info,nfev,ldfjac
  integer ipvt(n)
  real ftol,xtol,gtol,epsfcn,factor
  real x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n),wa1(n),wa2(n), &
       wa3(n),wa4(m)
  external fcn
!
  integer i,iflag,iter,j,l
  real actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,one,par, &
       pnorm,prered,p1,p5,p25,p75,p0001,ratio,sum,temp,temp1, &
       temp2,xnorm,zero
  real enorm
  data one,p1,p5,p25,p75,p0001,zero &
       /1.0e0,1.0e-1,5.0e-1,2.5e-1,7.5e-1,1.0e-4,0.0e0/
!
  epsmch = epsilon ( epsmch )

  info = 0
  iflag = 0
  nfev = 0
!
!     check the input parameters for errors.
!
  if (n <= 0 .or. m < n .or. ldfjac  <  m &
      .or. ftol < zero .or. xtol  <  zero .or. gtol  <  zero &
      .or. maxfev <= 0 .or. factor <= zero) go to 300
  if (mode /= 2) go to 20
  do 10 j = 1, n
     if (diag(j) <= zero) go to 300
   10    continue
   20 continue
!
!     evaluate the function at the starting point
!     and calculate its norm.
!
  iflag = 1
  call fcn(m,n,x,fvec,iflag)
  nfev = 1
  if (iflag < 0) go to 300
  fnorm = enorm(m,fvec)
!
!     initialize levenberg-marquardt parameter and iteration counter.
!
  par = zero
  iter = 1
!
!     beginning of the outer loop.
!
   30 continue
!
!        calculate the jacobian matrix.
!
     iflag = 2
     call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)
     nfev = nfev + n
     if (iflag < 0) go to 300
!
!        if requested, call fcn to enable printing of iterates.
!
     if (nprint <= 0) go to 40
     iflag = 0
     if (mod(iter-1,nprint) == 0) call fcn(m,n,x,fvec,iflag)
     if (iflag < 0) go to 300
   40    continue
!
!        compute the qr factorization of the jacobian.
!
     call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2)
!
!        on the first iteration and if mode is 1, scale according
!        to the norms of the columns of the initial jacobian.
!
     if (iter /= 1) go to 80
     if (mode == 2) go to 60
     do 50 j = 1, n
        diag(j) = wa2(j)
        if (wa2(j) == zero) diag(j) = one
   50       continue
   60    continue
!
!        on the first iteration, calculate the norm of the scaled x
!        and initialize the step bound delta.
!
     do 70 j = 1, n
        wa3(j) = diag(j)*x(j)
   70       continue
     xnorm = enorm(n,wa3)
     delta = factor*xnorm
     if (delta == zero) delta = factor
   80    continue
!
!        form (q transpose)*fvec and store the first n components in
!        qtf.
!
     do 90 i = 1, m
        wa4(i) = fvec(i)
   90       continue
     do 130 j = 1, n
        if (fjac(j,j) == zero) go to 120
        sum = zero
        do 100 i = j, m
           sum = sum + fjac(i,j)*wa4(i)
  100          continue
        temp = -sum/fjac(j,j)
        do 110 i = j, m
           wa4(i) = wa4(i) + fjac(i,j)*temp
  110          continue
  120       continue
        fjac(j,j) = wa1(j)
        qtf(j) = wa4(j)
  130       continue
!
!        compute the norm of the scaled gradient.
!
     gnorm = zero
     if (fnorm == zero) go to 170
     do 160 j = 1, n
        l = ipvt(j)
        if (wa2(l) == zero) go to 150
        sum = zero
        do 140 i = 1, j
           sum = sum + fjac(i,j)*(qtf(i)/fnorm)
  140          continue
        gnorm = max ( gnorm,abs(sum/wa2(l)))
  150       continue
  160       continue
  170    continue
!
!        test for convergence of the gradient norm.
!
     if (gnorm <= gtol) info = 4
     if (info /= 0) go to 300
!
!        rescale if necessary.
!
     if (mode == 2) go to 190
     do 180 j = 1, n
        diag(j) = max ( diag(j),wa2(j))
  180       continue
  190    continue
!
!        beginning of the inner loop.
!
  200    continue
!
!           determine the levenberg-marquardt parameter.
!
        call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, &
                   wa3,wa4)
!
!           store the direction p and x + p. calculate the norm of p.
!
        do 210 j = 1, n
           wa1(j) = -wa1(j)
           wa2(j) = x(j) + wa1(j)
           wa3(j) = diag(j)*wa1(j)
  210          continue
        pnorm = enorm(n,wa3)
!
!           on the first iteration, adjust the initial step bound.
!
        if (iter == 1) delta = amin1(delta,pnorm)
!
!           evaluate the function at x + p and calculate its norm.
!
        iflag = 1
        call fcn(m,n,wa2,wa4,iflag)
        nfev = nfev + 1
        if (iflag < 0) go to 300
        fnorm1 = enorm(m,wa4)
!
!           compute the scaled actual reduction.
!
        actred = -one
        if (p1*fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2
!
!           compute the scaled predicted reduction and
!           the scaled directional derivative.
!
        do 230 j = 1, n
           wa3(j) = zero
           l = ipvt(j)
           temp = wa1(l)
           do 220 i = 1, j
              wa3(i) = wa3(i) + fjac(i,j)*temp
  220             continue
  230          continue
        temp1 = enorm(n,wa3)/fnorm
        temp2 = (sqrt(par)*pnorm)/fnorm
        prered = temp1**2 + temp2**2/p5
        dirder = -(temp1**2 + temp2**2)
!
!           compute the ratio of the actual to the predicted
!           reduction.
!
        ratio = zero
        if (prered /= zero) ratio = actred/prered
!
!           update the step bound.
!
        if (ratio > p25) go to 240
           if (actred >= zero) temp = p5
           if (actred < zero) &
              temp = p5*dirder/(dirder + p5*actred)
           if (p1*fnorm1 >= fnorm .or. temp < p1) temp = p1
           delta = temp*amin1(delta,pnorm/p1)
           par = par/temp
           go to 260
  240       continue
           if (par /= zero .and. ratio < p75) go to 250
           delta = pnorm/p5
           par = p5*par
  250          continue
  260       continue
!
!           test for successful iteration.
!
        if (ratio < p0001) go to 290
!
!           successful iteration. update x, fvec, and their norms.
!
        do 270 j = 1, n
           x(j) = wa2(j)
           wa2(j) = diag(j)*x(j)
  270          continue
        do 280 i = 1, m
           fvec(i) = wa4(i)
  280          continue
        xnorm = enorm(n,wa2)
        fnorm = fnorm1
        iter = iter + 1
  290       continue
!
!           tests for convergence.
!
        if (abs(actred) <= ftol .and. prered <= ftol &
            .and. p5*ratio <= one) info = 1
        if (delta <= xtol*xnorm) info = 2
        if (abs(actred) <= ftol .and. prered <= ftol &
            .and. p5*ratio <= one .and. info == 2) info = 3
        if (info /= 0) go to 300
!
!           tests for termination and stringent tolerances.
!
        if (nfev >= maxfev) info = 5
        if (abs(actred) <= epsmch .and. prered <= epsmch &
            .and. p5*ratio <= one) info = 6
        if (delta <= epsmch*xnorm) info = 7
        if (gnorm <= epsmch) info = 8
        if (info /= 0) go to 300
!
!           end of the inner loop. repeat if iteration unsuccessful.
!
        if (ratio < p0001) go to 200
!
!        end of the outer loop.
!
     go to 30
  300 continue
!
!     termination, either normal or user imposed.
!
  if (iflag < 0) info = iflag
  iflag = 0
  if (nprint > 0) call fcn(m,n,x,fvec,iflag)
  return
!
!     last card of subroutine lmdif.
!
end
subroutine lmdiff(fcn,m,n,x,fvec,epsfcn,tol,info,iwa,wa,lwa)
!
!*******************************************************************************
!
!! LMDIFF minimize the sum of the squares of m functions in n variables
!  by a modification of the
!     levenberg-marquardt algorithm. this is done by using the more
!     general least-squares solver lmdif. the user must provide a
!     subroutine which calculates the functions. the jacobian is
!     then calculated by a forward-difference approximation.
!
!     the subroutine statement is
!
!       subroutine lmdiff(fcn,m,n,x,fvec,epsfcn,tol,info,iwa,wa,lwa)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(m,n,x,fvec,iflag)
!         integer m,n,iflag
!         real x(n),fvec(m)
!
!         calculate the functions at x and
!         return this vector in fvec.
!
!         return
!       end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of lmdiff.
!         in this case set iflag to a negative integer.
!
!       m is a positive integer input variable set to the number
!         of functions.
!
!       n is a positive integer input variable set to the number
!         of variables. n must not exceed m.
!
!       x is an array of length n. on input x must contain
!         an initial estimate of the solution vector. on output x
!         contains the final estimate of the solution vector.
!
!       fvec is an output array of length m which contains
!         the functions evaluated at the output x.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       tol is a nonnegative input variable. termination occurs
!         when the algorithm estimates either that the relative
!         error in the sum of squares is at most tol or that
!         the relative error between x and the solution is at
!         most tol.
!
!       info is an integer output variable. if the user has
!         terminated execution, info is set to the (negative)
!         value of iflag. see description of fcn. otherwise,
!         info is set as follows.
!
!         info = 0  improper input parameters.
!
!         info = 1  algorithm estimates that the relative error
!                   in the sum of squares is at most tol.
!
!         info = 2  algorithm estimates that the relative error
!                   between x and the solution is at most tol.
!
!         info = 3  conditions for info = 1 and info = 2 both hold.
!
!         info = 4  fvec is orthogonal to the columns of the
!                   jacobian to machine precision.
!
!         info = 5  number of calls to fcn has reached or
!                   exceeded 200*(n+1).
!
!         info = 6  tol is too small. no further reduction in
!                   the sum of squares is possible.
!
!         info = 7  tol is too small. no further improvement in
!                   the approximate solution x is possible.
!
!       iwa is an integer work array of length n.
!
!       wa is a work array of length lwa.
!
!       lwa is a positive integer input variable not less than
!         m*n+5*n+m.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!       minpack-supplied ... lmdif
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer m,n,info,lwa
  integer iwa(n)
  real epsfcn,tol
  real x(n),fvec(m),wa(lwa)
  external fcn
!     **********
!
!     **********
  integer maxfev,mode,mp5n,nfev,nprint
  real factor,ftol,gtol,xtol,zero
  data factor,zero /1.0e2,0.0e0/
  info = 0
!
!     check the input parameters for errors.
!
  if (n <= 0 .or. m < n .or. epsfcn  <  zero &
      .or. tol < zero .or. lwa  <  m*n + 5*n + m) go to 10
!
!     call lmdif.
!
  maxfev = 200*(n + 1)
  ftol = tol
  xtol = tol
  gtol = zero
  mode = 1
  nprint = 0
  mp5n = m + 5*n
  call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), &
             mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, &
             wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
  if (info == 8) info = 4
   10 continue
  return
end
subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, &
                   wa2)
!
!*******************************************************************************
!
!! LMPAR determines a parameter for a least squares problem.
!
!     given an m by n matrix a, an n by n nonsingular diagonal
!     matrix d, an m-vector b, and a positive number delta,
!     the problem is to determine a value for the parameter
!     par such that if x solves the system
!
!           a*x = b ,     sqrt(par)*d*x = 0 ,
!
!     in the least squares sense, and dxnorm is the euclidean
!     norm of d*x, then either par is zero and
!
!           (dxnorm-delta) <= 0.1*delta ,
!
!     or par is positive and
!
!           abs(dxnorm-delta) <= 0.1*delta .
!
!     this subroutine completes the solution of the problem
!     if it is provided with the necessary information from the
!     qr factorization, with column pivoting, of a. that is, if
!     a*p = q*r, where p is a permutation matrix, q has orthogonal
!     columns, and r is an upper triangular matrix with diagonal
!     elements of nonincreasing magnitude, then lmpar expects
!     the full upper triangle of r, the permutation matrix p,
!     and the first n components of (q transpose)*b. on output
!     lmpar also provides an upper triangular matrix s such that
!
!            t   t                   t
!           p *(a *a + par*d*d)*p = s *s .
!
!     s is employed within lmpar and may be of separate interest.
!
!     only a few iterations are generally needed for convergence
!     of the algorithm. if, however, the limit of 10 iterations
!     is reached, then the output par will contain the best
!     value obtained so far.
!
!     the subroutine statement is
!
!       subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
!                        wa1,wa2)
!
!     where
!
!       n is a positive integer input variable set to the order of r.
!
!       r is an n by n array. on input the full upper triangle
!         must contain the full upper triangle of the matrix r.
!         on output the full upper triangle is unaltered, and the
!         strict lower triangle contains the strict upper triangle
!         (transposed) of the upper triangular matrix s.
!
!       ldr is a positive integer input variable not less than n
!         which specifies the leading dimension of the array r.
!
!       ipvt is an integer input array of length n which defines the
!         permutation matrix p such that a*p = q*r. column j of p
!         is column ipvt(j) of the identity matrix.
!
!       diag is an input array of length n which must contain the
!         diagonal elements of the matrix d.
!
!       qtb is an input array of length n which must contain the first
!         n elements of the vector (q transpose)*b.
!
!       delta is a positive input variable which specifies an upper
!         bound on the euclidean norm of d*x.
!
!       par is a nonnegative variable. on input par contains an
!         initial estimate of the levenberg-marquardt parameter.
!         on output par contains the final estimate.
!
!       x is an output array of length n which contains the least
!         squares solution of the system a*x = b, sqrt(par)*d*x = 0,
!         for the output par.
!
!       sdiag is an output array of length n which contains the
!         diagonal elements of the upper triangular matrix s.
!
!       wa1 and wa2 are work arrays of length n.
!
!     subprograms called
!
!
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer n,ldr
  integer ipvt(n)
  real delta,par
  real r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n),wa2(n)
!
  integer i,iter,j,jm1,jp1,k,l,nsing
  real dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,sum,temp,zero
  real enorm
  data p1,p001,zero /1.0e-1,1.0e-3,0.0e0/
!
!     dwarf is the smallest positive magnitude.
!
  dwarf = tiny ( dwarf )
!
!     compute and store in x the gauss-newton direction. if the
!     jacobian is rank-deficient, obtain a least squares solution.
!
  nsing = n
  do 10 j = 1, n
     wa1(j) = qtb(j)
     if (r(j,j) == zero .and. nsing == n) nsing = j - 1
     if (nsing < n) wa1(j) = zero
   10    continue
  if (nsing < 1) go to 50
  do 40 k = 1, nsing
     j = nsing - k + 1
     wa1(j) = wa1(j)/r(j,j)
     temp = wa1(j)
     jm1 = j - 1
     if (jm1 < 1) go to 30
     do 20 i = 1, jm1
        wa1(i) = wa1(i) - r(i,j)*temp
   20       continue
   30    continue
   40    continue
   50 continue
  do 60 j = 1, n
     l = ipvt(j)
     x(l) = wa1(j)
   60    continue
!
!     initialize the iteration counter.
!     evaluate the function at the origin, and test
!     for acceptance of the gauss-newton direction.
!
  iter = 0
  do 70 j = 1, n
     wa2(j) = diag(j)*x(j)
   70    continue
  dxnorm = enorm(n,wa2)
  fp = dxnorm - delta
  if (fp <= p1*delta) go to 220
!
!     if the jacobian is not rank deficient, the newton
!     step provides a lower bound, parl, for the zero of
!     the function. otherwise set this bound to zero.
!
  parl = zero
  if (nsing < n) go to 120
  do 80 j = 1, n
     l = ipvt(j)
     wa1(j) = diag(l)*(wa2(l)/dxnorm)
   80    continue
  do 110 j = 1, n
     sum = zero
     jm1 = j - 1
     if (jm1 < 1) go to 100
     do 90 i = 1, jm1
        sum = sum + r(i,j)*wa1(i)
   90       continue
  100    continue
     wa1(j) = (wa1(j) - sum)/r(j,j)
  110    continue
  temp = enorm(n,wa1)
  parl = ((fp/delta)/temp)/temp
  120 continue
!
!     calculate an upper bound, paru, for the zero of the function.
!
  do 140 j = 1, n
     sum = zero
     do 130 i = 1, j
        sum = sum + r(i,j)*qtb(i)
  130       continue
     l = ipvt(j)
     wa1(j) = sum/diag(l)
  140    continue
  gnorm = enorm(n,wa1)
  paru = gnorm/delta
  if (paru == zero) paru = dwarf/amin1(delta,p1)
!
!     if the input par lies outside of the interval (parl,paru),
!     set par to the closer endpoint.
!
  par = max ( par,parl)
  par = amin1(par,paru)
  if (par == zero) par = gnorm/dxnorm
!
!     beginning of an iteration.
!
  150 continue
     iter = iter + 1
!
!        evaluate the function at the current value of par.
!
     if (par == zero) par = max ( dwarf,p001*paru)
     temp = sqrt(par)
     do 160 j = 1, n
        wa1(j) = temp*diag(j)
  160       continue
     call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag)
     do 170 j = 1, n
        wa2(j) = diag(j)*x(j)
  170       continue
     dxnorm = enorm(n,wa2)
     temp = fp
     fp = dxnorm - delta
!
!        if the function is small enough, accept the current value
!        of par. also test for the exceptional cases where parl
!        is zero or the number of iterations has reached 10.
!
     if (abs(fp) <= p1*delta &
         .or. parl == zero .and. fp <= temp &
              .and. temp < zero .or. iter == 10) go to 220
!
!        compute the newton correction.
!
     do 180 j = 1, n
        l = ipvt(j)
        wa1(j) = diag(l)*(wa2(l)/dxnorm)
  180       continue
     do 210 j = 1, n
        wa1(j) = wa1(j)/sdiag(j)
        temp = wa1(j)
        jp1 = j + 1
        if (n < jp1) go to 200
        do 190 i = jp1, n
           wa1(i) = wa1(i) - r(i,j)*temp
  190          continue
  200       continue
  210       continue
     temp = enorm(n,wa1)
     parc = ((fp/delta)/temp)/temp
!
!        depending on the sign of the function, update parl or paru.
!
     if (fp > zero) parl = max ( parl,par)
     if (fp < zero) paru = amin1(paru,par)
!
!        compute an improved estimate for par.
!
     par = max ( parl,par+parc)
!
!        end of an iteration.
!
     go to 150
  220 continue
!
!     termination.
!
  if (iter == 0) par = zero
  return
!
!     last card of subroutine lmpar.
!
end
subroutine lnsrch(n,x,f,g,p,xpls,fpls,fcn,mxtake,iretcd, &
                    stepmx,steptl,typsiz)
!
!*******************************************************************************
!
!! LNSRCH finds a next newton iterate by line search
!
!
!     input ...
!
!       n         dimension of problem
!       x(n)      old iterate x(k-1)
!       f         function value at old iterate, f(x)
!       g(n)      gradient at old iterate, g(x)
!       p(n)      non-zero newton step
!       fcn       name of subroutine to evaluate function
!       stepmx    maximum allowable step size
!       steptl    relative step size at which successive iterates
!                 considered close enough to terminate algorithm
!       typsiz(n) scaling vector for x
!
!     output ...
!
!       xpls(n)   new iterate x(k)
!       fpls      function value at new iterate, f(xpls)
!       iretcd    return code
!       mxtake    boolean flag indicating step of maximum length used
!
!
!     internal variables ...
!
!       sln      newton length
!       rln      relative length of newton step
!
  real x(n), g(n), p(n), xpls(n), typsiz(n)
  real lambda
  logical mxtake
  external fcn
!
  mxtake = .false.
  iretcd = 2
  tmp = 0.0
  do 10 i = 1,n
     tmp = tmp + (p(i)/typsiz(i))**2
   10 continue
  sln = sqrt(tmp)
!
  if (sln <= stepmx) go to 30
!
!     newton step longer than maximum allowed
!
     scl = stepmx/sln
     do 20 i = 1,n
        p(i) = scl*p(i)
   20    continue
     sln = stepmx
!
   30 slp = sdot(n,g,1,p,1)
  rln = 0.0
  do 40 i = 1,n
     rln = max ( rln,abs(p(i))/ max ( abs(x(i)),typsiz(i)))
   40 continue
  rmnlmb = steptl/rln
  lambda = 1.0
!
!     loop.  check if the new iterate is satisfactory.
!
  100 do 110 i = 1,n
    xpls(i) = x(i) + lambda*p(i)
  110 continue
  call fcn(n,xpls,fpls)
  if (fpls <= f + slp*1.e-4*lambda) go to 200
!
!     solution not (yet) found
!
    if (lambda < rmnlmb) go to 210
!
!     calculate new lambda
!
    if (lambda /= 1.0) go to 120
!
!     first backtrack. quadratic fit
!
        tlmbda = amin1(-slp/(2.0*(fpls - f - slp)), 0.9)
        go to 170
!
!     all subsequent backtracks. cubic fit
!
  120       t1 = (fpls - f - lambda*slp)/(lambda*lambda)
        t2 = (pfpls - f - plmbda*slp)/(plmbda*plmbda)
        t3 = 1.0/(lambda - plmbda)
        a = t3*(t1 - t2)
        b = t3*(t2*lambda - t1*plmbda)
        w = 10.0*abs(t1*t3)
        if ((abs(a) + w) /= w) go to 130
!
!     the cubic fit degenerates to a quadratic fit
!
           tlmbda = -slp/(2.0*b)
           go to 160
!
!     the cubic is nondegenerate
!
  130       disc = b*b - 3.0*a*slp
        if (disc <= b*b) go to 140
!
!     only one positive critical point, must be minimum
!
           tlmbda = (-b + sign(1.0,a)*sqrt(disc))/(3.0*a)
           go to 160
!
!     both critical points positive, first is minimum
!
  140          if (disc > 0.0) go to 150
              tlmbda = -b/(3.0*a)
              go to 160
  150          tlmbda = (-b - sign(1.0,a)*sqrt(disc))/(3.0*a)
!
  160       if (tlmbda > 0.5*lambda) tlmbda = 0.5*lambda
!
!
  170     plmbda = lambda
      pfpls = fpls
      if (tlmbda >= lambda*0.1) go to 180
        lambda = lambda*0.1
        go to 100
  180     lambda = tlmbda
      go to 100
!
!     a suitable value for xpls has been obtained
!
  200 iretcd = 0
  if (lambda == 1.0 .and. sln > 0.99*stepmx) mxtake =.true.
  return
!
!     no satisfactory xpls found sufficiently distinct from x
!
  210 iretcd = 1
  return
end
subroutine lnsys ( a, d, m, n, b, x, option, ierr )
!
!*******************************************************************************
!
!! LNSYS solves A*X = B, where A is a matrix of order N.
!
!
!  m is the number of
!   rows in the dimension statement for a in the calling program.
!
!   option=1   compute an lu decomposition of a and store it in d.
!              store the pivot indices in pivot and solve ax = b.
!   option=2   compute an lu decomposition of a and store it in d.
!              store the pivot indices in pivot and solve ax = b.
!              then compute the residual and one correction. the
!              correction is stored in r, the new value x1 in x,
!              the relative error
!                         norm(x0-x1)/norm(x1)
!              in the variable error, and the relative residual
!                         norm(residual)/norm(b)
!              in the variable relrsd. these values can be obtained
!              using the common/xxlin/ given below.
!   option=3   same as option=1, except that the lu decomposition
!              has already been stored in d and the pivot indices
!              in pivot.
!   option=4   same as option=2, except that the lu decomposition
!              has already been stored in d and the pivot indices
!              in pivot.
!
!   the lu decomposition is obtained using scaled partial pivoting.
!   for options 1 and 2, ierr is a variable that reports the status
!   of the results. ierr = 0 if the lu decomposition is obtained.
!   otherwise, ierr = -k when the k-th row of a contains only zeros
!   or ierr = k when the k-th pivot element is 0.
!
!   it is assumed that n <= 128. this assumption may be modified
!   by changing the dimension statements for the arrays pivot, r,
!   and scale. also modify the dimension statement for pivot in the
!   subroutine iegs.
!
  real a(m,n),d(m,n),b(n),x(n)
  integer option,pivot(128)
  real normx,norme,normb,normr,r(128),scale(128)
  common /xxlin/ error,relrsd,pivot
!
  nm1 = n - 1
  iswit = 1
  if (option > 2) go to 100

  do 11 i = 1,n

    scale(i) = 0.0

    do j = 1,n
      d(i,j) = a(i,j)
      scale(i) = scale(i) + abs(d(i,j))
    end do

    if ( scale(i) == 0.0) then
      ierr = -i
      return
    end if

   11 continue
!
!             obtain the lu decomposition of a
!
  ierr = 0
  do 43 k = 1,nm1
  c = abs(d(k,k))/scale(k)
  l = k
  kp1 = k + 1
    do 20 i = kp1,n
    t = abs(d(i,k))/scale(i)
    if (t <= c) go to 20
    c = t
    l = i
   20   continue
!
  if (c /= 0.0) go to 30
  ierr = k
  return
!
!     interchange rows k and l
!
   30 pivot(k) = l
  if (k == l) go to 40
    do 31 j = k,n
    t = d(k,j)
    d(k,j) = d(l,j)
   31   d(l,j) = t
  t = scale(k)
  scale(k) = scale(l)
  scale(l) = t
!
!     eliminate the k-th unknown below the diagonal
!
   40   do 42 i = kp1,n
    d(i,k) = d(i,k)/d(k,k)
    t = d(i,k)
      do 41 j = kp1,n
   41     d(i,j) = d(i,j) - t*d(k,j)
   42   continue
   43 continue
!
  if (d(n,n) /= 0.0) go to 100
  ierr = n
  return
!
!               store b in r and set x = 0
!
  100 do 110 i = 1,n
  r(i) = b(i)
  110 x(i) = 0.0
  go to 200
!
!             compute the residual r = b - ax
!
  120 do 131 i = 1,n
  sum = 0.0
    do 130 j = 1,n
  130   sum = sum + a(i,j)*x(j)
  131 r(i) = b(i) - sum
!
  normb = 0.0
  normr = 0.0
  do 140 i = 1,n
  normb = max ( normb,abs(b(i)))
  140 normr = max ( normr,abs(r(i)))
  relrsd = 0.0
  if (normb /= 0.0) relrsd = normr/normb
  iswit = 2
!
!             solve lz = r and store z in r
!
  200 do 212 k = 1,nm1
  l = pivot(k)
  if (k == l) go to 210
  t = r(k)
  r(k) = r(l)
  r(l) = t
  210 kp1 = k + 1
    do 211 i = kp1,n
  211   r(i) = r(i) - d(i,k)*r(k)
  212 continue
!
!      solve ue = r, store e in r, and set x = x + e
!
  r(n) = r(n)/d(n,n)
  x(n) = x(n) + r(n)
  do 221 nmi = 1,nm1
  i = n - nmi
  ip1 = i + 1
  sum = 0.0
    do 220 j = ip1,n
  220   sum = sum + d(i,j)*r(j)
  r(i) = (r(i) - sum)/d(i,i)
  221 x(i) = x(i) + r(i)
!
  go to (300,230,300,230),option
  230 if (iswit == 1) go to 120
!
!             calculate the correction error
!
  normx = 0.0
  norme = 0.0
  do 250 i = 1,n
  normx = max ( normx,abs(x(i)))
  250 norme = max ( norme,abs(r(i)))
  error = 0.0
  if (normx /= 0.0) error = norme/normx
  300 return
end
subroutine locpt (x0, y0, x, y, n, l, m)
!
!*******************************************************************************
!
!! LOCPT locates a point inside, on, or outside a closed polygonal path.
!
!
!     given a polygonal line connecting the vertices (x(i),y(i))
!     (i = 1,...,n) taken in this order. it is assumed that the
!     polygonal path is a loop, where (x(n),y(n)) = (x(1),y(1))
!     or there is an arc from (x(n),y(n)) to (x(1),y(1)).
!
!     (x0,y0) is an arbitrary point and l and m are variables.
!     l and m are assigned the following values ...
!
!        l = -1   if (x0,y0) is outside the polygonal path
!        l =  0   if (x0,y0) lies on the polygonal path
!        l =  1   if (x0,y0) is inside the polygonal path
!
!     m = 0 if (x0,y0) is on or outside the path. if (x0,y0)
!     is inside the path then m is the winding number of the
!     path around the point (x0,y0).
!
  real x(n), y(n)
  eps = epsilon ( eps )
  n0 = n
  if (x(1) == x(n) .and. y(1) == y(n)) n0 = n - 1
  pi = atan2(0.0, -1.0)
  pi2 = 2.0*pi
  tol = 4.0*eps*pi
  l = -1
  m = 0
!
  u = x(1) - x0
  v = y(1) - y0
  if (u == 0.0 .and. v == 0.0) go to 20
  if (n0 < 2) return
  theta1 = atan2(v, u)
!
  sum = 0.0
  theta = theta1
  do 10 i = 2,n0
     u = x(i) - x0
     v = y(i) - y0
     if (u == 0.0 .and. v == 0.0) go to 20
     thetai = atan2(v, u)
!
     angle = abs(thetai - theta)
     if (abs(angle - pi) < tol) go to 20
     if (angle > pi) angle = angle - pi2
     if (theta > thetai) angle = -angle
     sum = sum + angle
     theta = thetai
   10 continue
!
  angle = abs(theta1 - theta)
  if (abs(angle - pi) < tol) go to 20
  if (angle > pi) angle = angle - pi2
  if (theta > theta1) angle = -angle
  sum = sum + angle
!
!     sum = 2*pi*m where m is the winding number
!
  m = abs(sum)/pi2 + 0.2
  if (m == 0) return
  l = 1
  if (sum < 0.0) m = -m
  return
!
!     (x0, y0) is on the boundary of the path
!
   20 l = 0
  return
end
function logam (x)
!
!*******************************************************************************
!
!! LOGAM: computation of ln(gamma(x)) for x = n/2  where n is an integer
!
!     d = 0.5*(ln(2*pi) - 1)
!
  real logam
  real w(200)
  data d/.41893853320467/
!
  data w(1)  /.57236494292470e+00/, w(2)  /0.0/, &
       w(3) /-.12078223763525e+00/, w(4)  /0.0/, &
       w(5)  /.28468287047292e+00/, w(6)  /.69314718055995e+00/, &
       w(7)  /.12009736023471e+01/, w(8)  /.17917594692281e+01/, &
       w(9)  /.24537365708424e+01/, w(10) /.31780538303479e+01/, &
       w(11) /.39578139676187e+01/, w(12) /.47874917427820e+01/, &
       w(13) /.56625620598571e+01/, w(14) /.65792512120101e+01/, &
       w(15) /.75343642367587e+01/, w(16) /.85251613610654e+01/, &
       w(17) /.95492672573010e+01/, w(18) /.10604602902745e+02/, &
       w(19) /.11689333420797e+02/, w(20) /.12801827480081e+02/
  data w(21) /.13940625219404e+02/, w(22) /.15104412573076e+02/, &
       w(23) /.16292000476567e+02/, w(24) /.17502307845874e+02/, &
       w(25) /.18734347511936e+02/, w(26) /.19987214495662e+02/, &
       w(27) /.21260076156245e+02/, w(28) /.22552163853123e+02/, &
       w(29) /.23862765841689e+02/, w(30) /.25191221182739e+02/, &
       w(31) /.26536914491116e+02/, w(32) /.27899271383841e+02/, &
       w(33) /.29277754515041e+02/, w(34) /.30671860106081e+02/, &
       w(35) /.32081114895947e+02/, w(36) /.33505073450137e+02/, &
       w(37) /.34943315776877e+02/, w(38) /.36395445208033e+02/, &
       w(39) /.37861086508961e+02/, w(40) /.39339884187199e+02/
  data w(41) /.40831500974531e+02/, w(42) /.42335616460753e+02/, &
       w(43) /.43851925860675e+02/, w(44) /.45380138898477e+02/, &
       w(45) /.46919978795809e+02/, w(46) /.48471181351835e+02/, &
       w(47) /.50033494105019e+02/, w(48) /.51606675567764e+02/, &
       w(49) /.53190494526169e+02/, w(50) /.54784729398112e+02/, &
       w(51) /.56389167643720e+02/, w(52) /.58003605222981e+02/, &
       w(53) /.59627846095884e+02/, w(54) /.61261701761002e+02/, &
       w(55) /.62904990828877e+02/, w(56) /.64557538627006e+02/, &
       w(57) /.66219176833549e+02/, w(58) /.67889743137182e+02/, &
       w(59) /.69569080920824e+02/, w(60) /.71257038967168e+02/
  data w(61) /.72953471184169e+02/, w(62) /.74658236348830e+02/, &
       w(63) /.76371197867783e+02/, w(64) /.78092223553315e+02/, &
       w(65) /.79821185413614e+02/, w(66) /.81557959456115e+02/, &
       w(67) /.83302425502950e+02/, w(68) /.85054467017582e+02/, &
       w(69) /.86813970941781e+02/, w(70) /.88580827542198e+02/, &
       w(71) /.90354930265818e+02/, w(72) /.92136175603687e+02/, &
       w(73) /.93924462962300e+02/, w(74) /.95719694542143e+02/, &
       w(75) /.97521775222888e+02/, w(76) /.99330612454787e+02/, &
       w(77) /.10114611615586e+03/, w(78) /.10296819861451e+03/, &
       w(79) /.10479677439716e+03/, w(80) /.10663176026064e+03/
  data w(81) /.10847307506907e+03/, w(82) /.11032063971476e+03/, &
       w(83) /.11217437704318e+03/, w(84) /.11403421178146e+03/, &
       w(85) /.11590007047041e+03/, w(86) /.11777188139975e+03/, &
       w(87) /.11964957454634e+03/, w(88) /.12153308151544e+03/, &
       w(89) /.12342233548444e+03/, w(90) /.12531727114936e+03/, &
       w(91) /.12721782467361e+03/, w(92) /.12912393363913e+03/, &
       w(93) /.13103553699957e+03/, w(94) /.13295257503562e+03/, &
       w(95) /.13487498931216e+03/, w(96) /.13680272263733e+03/, &
       w(97) /.13873571902320e+03/, w(98) /.14067392364823e+03/, &
       w(99) /.14261728282115e+03/, w(100)/.14456574394634e+03/
  data w(101)/.14651925549072e+03/, w(102)/.14847776695177e+03/, &
       w(103)/.15044122882700e+03/, w(104)/.15240959258450e+03/, &
       w(105)/.15438281063467e+03/, w(106)/.15636083630308e+03/, &
       w(107)/.15834362380427e+03/, w(108)/.16033112821663e+03/, &
       w(109)/.16232330545817e+03/, w(110)/.16432011226320e+03/, &
       w(111)/.16632150615984e+03/, w(112)/.16832744544843e+03/, &
       w(113)/.17033788918059e+03/, w(114)/.17235279713916e+03/, &
       w(115)/.17437212981875e+03/, w(116)/.17639584840700e+03/, &
       w(117)/.17842391476655e+03/, w(118)/.18045629141754e+03/, &
       w(119)/.18249294152079e+03/, w(120)/.18453382886145e+03/
  data w(121)/.18657891783334e+03/, w(122)/.18862817342367e+03/, &
       w(123)/.19068156119837e+03/, w(124)/.19273904728784e+03/, &
       w(125)/.19480059837319e+03/, w(126)/.19686618167289e+03/, &
       w(127)/.19893576492993e+03/, w(128)/.20100931639928e+03/, &
       w(129)/.20308680483583e+03/, w(130)/.20516819948264e+03/, &
       w(131)/.20725347005963e+03/, w(132)/.20934258675254e+03/, &
       w(133)/.21143552020227e+03/, w(134)/.21353224149456e+03/, &
       w(135)/.21563272214993e+03/, w(136)/.21773693411395e+03/, &
       w(137)/.21984484974781e+03/, w(138)/.22195644181913e+03/, &
       w(139)/.22407168349308e+03/, w(140)/.22619054832373e+03/
  data w(141)/.22831301024565e+03/, w(142)/.23043904356578e+03/, &
       w(143)/.23256862295547e+03/, w(144)/.23470172344282e+03/, &
       w(145)/.23683832040517e+03/, w(146)/.23897838956183e+03/, &
       w(147)/.24112190696703e+03/, w(148)/.24326884900298e+03/, &
       w(149)/.24541919237325e+03/, w(150)/.24757291409619e+03/, &
       w(151)/.24972999149863e+03/, w(152)/.25189040220972e+03/, &
       w(153)/.25405412415489e+03/, w(154)/.25622113555001e+03/, &
       w(155)/.25839141489572e+03/, w(156)/.26056494097186e+03/, &
       w(157)/.26274169283208e+03/, w(158)/.26492164979855e+03/, &
       w(159)/.26710479145687e+03/, w(160)/.26929109765102e+03/
  data w(161)/.27148054847853e+03/, w(162)/.27367312428569e+03/, &
       w(163)/.27586880566295e+03/, w(164)/.27806757344037e+03/, &
       w(165)/.28026940868320e+03/, w(166)/.28247429268763e+03/, &
       w(167)/.28468220697654e+03/, w(168)/.28689313329543e+03/, &
       w(169)/.28910705360840e+03/, w(170)/.29132395009427e+03/, &
       w(171)/.29354380514276e+03/, w(172)/.29576660135076e+03/, &
       w(173)/.29799232151870e+03/, w(174)/.30022094864701e+03/, &
       w(175)/.30245246593264e+03/, w(176)/.30468685676567e+03/, &
       w(177)/.30692410472600e+03/, w(178)/.30916419358015e+03/, &
       w(179)/.31140710727802e+03/, w(180)/.31365282994988e+03/
  data w(181)/.31590134590330e+03/, w(182)/.31815263962021e+03/, &
       w(183)/.32040669575401e+03/, w(184)/.32266349912673e+03/, &
       w(185)/.32492303472629e+03/, w(186)/.32718528770378e+03/, &
       w(187)/.32945024337081e+03/, w(188)/.33171788719693e+03/, &
       w(189)/.33398820480710e+03/, w(190)/.33626118197920e+03/, &
       w(191)/.33853680464160e+03/, w(192)/.34081505887080e+03/, &
       w(193)/.34309593088909e+03/, w(194)/.34537940706227e+03/, &
       w(195)/.34766547389743e+03/, w(196)/.34995411804077e+03/, &
       w(197)/.35224532627544e+03/, w(198)/.35453908551944e+03/, &
       w(199)/.35683538282361e+03/, w(200)/.35913420536958e+03/
!
  if (x > 100.0) go to 10
     n = 2.0*x + 0.1
     logam = w(n)
     return
   10 t = (1.0/x)**2
  z = (((-0.75*t + 1.0)*t - 3.5)*t + 105.0)/(x*1260.0)
  logam = (d + z) + (x - 0.5)*(alog(x) - 1.0)
  return
end
subroutine lopcmp (m, n, t, x, kx, dx, kdx, l, ti, z, kz)
!
!*******************************************************************************
!
!! LOPCMP: evaluation of a cubic spline closed curve in n-space
!
  real t(m), x(kx,n), dx(kdx,n), ti(l), z(kz, n)
!
!     reduction of ti(k) to t0 where 0 <= t0 < 1
!
  k = 1
  j = ti(1)
  t0 = ti(1) - j
  if (t0 < 0.0) t0 = 1.0 + t0
  if (t0 >= t(m)) go to 60
  il = 1
  ir = m
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 50
  if (t0 - t(i)) 20,50,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   40 if (t0 < t(i+1)) go to 50
  i = i + 1
  go to 40
!
!     computation when t(i) <= t0 < t(i+1)
!
   50 h = t(i+1) - t(i)
  dt = t0 - t(i)
  do 51 j = 1,n
     a = dx(i,j)
     d = (x(i+1,j) - x(i,j))/h
     w = a + dx(i+1,j)
     b = (-w - a + 3.0*d)/h
     c = ((w - d - d)/h)/h
     z(k,j) = x(i,j) + dt*(a + dt*(b + dt*c))
   51 continue
  go to 100
!
!     computation when t0 >= t(m)
!
   60 i = m
  h = 1.0 - t(m)
  dt = t0 - t(m)
  do 61 j = 1,n
     a = dx(m,j)
     d = (x(1,j) - x(m,j))/h
     w = a + dx(1,j)
     b = (-w - a + 3.0*d)/h
     c = ((w - d - d)/h)/h
     z(k,j) = x(m,j) + dt*(a + dt*(b + dt*c))
   61 continue
!
!     next point
!
  100 if (k >= l) return
  told = t0
  k = k + 1
  j = ti(k)
  t0 = ti(k) - j
  if (t0 < 0.0) t0 = 1.0 + t0
  if (t0 >= t(m)) go to 60
  if (t0 - told) 110,50,40
!
  110 il = 1
  ir = min (i+1,m)
  go to 10
end
subroutine lopdf (m, n, t, x, kx, dx, kdx, ti, z, dz, ddz)
!
!*****************************************************************************80
!
!! LOPDF: evaluation and differentiation of cubic spline closed curve in n-space
!
  real t(m), x(kx,n), dx(kdx,n), z(n), dz(n), ddz(n)
!
!     reduction of ti to t0 where 0 <= t0 < 1
!
  j = ti
  t0 = ti - j
  if (t0 < 0.0) t0 = 1.0 + t0
  if (t0 >= t(m)) go to 50
  il = 1
  ir = m
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 40
  if (t0 - t(i)) 20,40,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     computation when t(i) <= t0 < t(i+1)
!
   40 h = t(i+1) - t(i)
  dt = t0 - t(i)
  do 41 j = 1,n
     a = dx(i,j)
     d = (x(i+1,j) - x(i,j))/h
     w = a + dx(i+1,j)
     b = (-w - a + 3.0*d)/h
     c = ((w - d - d)/h)/h
     z(j) = x(i,j) + dt*(a + dt*(b + dt*c))
     b = b + b
     c = 3.0*c
     dz(j) = a + dt*(b + c*dt)
     ddz(j) = b + (c + c)*dt
   41 continue
  return
!
!     computation when t0 >= t(m)
!
   50 h = 1.0 - t(m)
  dt = t0 - t(m)
  do 51 j = 1,n
     a = dx(m,j)
     d = (x(1,j) - x(m,j))/h
     w = a + dx(1,j)
     b = (-w - a + 3.0*d)/h
     c = ((w - d - d)/h)/h
     z(j) = x(m,j) + dt*(a + dt*(b + dt*c))
     b = b + b
     c = 3.0*c
     dz(j) = a + dt*(b + c*dt)
     ddz(j) = b + (c + c)*dt
   51 continue
  return
end
subroutine lpdp(a, mda, m, n1, n2, prgopt, x, wnorm, mode, ws, is)
!
!*******************************************************************************
!
!! LPDP determines vectors w and z which minimize ||w|| with g*w+h*z >= y.
!
!  w is an n1 vector, and z an n2 vector.
!
!     this is the least projected distance problem, lpdp.
!     the matrices g and h are of respective
!     dimensions m by n1 and m by n2.
!
!     called by subprogram lsi( ).
!
!     the matrix
!                (g h y)
!
!     occupies rows 1,...,m and cols 1,...,n1+n2+1 of a(*,*).
!
!     the solution (w) is returned in x(*).
!                  (z)
!
!     the value of mode indicates the status of
!     the computation after returning to the user.
!
!          mode=1  the solution was successfully obtained.
!
!          mode=2  the inequalities are inconsistent.
!
!     subroutines called
!
!     wnnls         solves a nonnegatively constrained linear least
!                   squares problem with linear equality constraints.
!                   part of this package.
!
!     sdot,scopy    subroutines from the blas package.
!     sscal,snrm2   see trans. math software (5), p. 308.
!
  dimension a(mda,*), prgopt(*), x(*), ws(*), is(*)
  data zero, one /0.e0,1.e0/, fac /0.1e0/
!
  n = n1 + n2
  mode = 1
  if (.not.(m <= 0)) go to 20
  if (.not.(n > 0)) go to 10
  x(1) = zero
  call scopy(n, x, 0, x, 1)
   10 wnorm = zero
  return
   20 np1 = n + 1
!
!     scale nonzero rows of inequality matrix to have length one.
!
  do 40 i = 1,m
     sc = snrm2(n,a(i,1),mda)
     if (sc == zero) go to 40
     sc = one/sc
     call sscal(np1, sc, a(i,1), mda)
   40 continue
!
!     scale rt.-side vector to have length one (or zero).
  ynorm = snrm2(m,a(1,np1),1)
  if (ynorm == zero) go to 50
  sc = one/ynorm
  call sscal(m, sc, a(1,np1), 1)
!
!     scale cols of matrix h.
   50 j = n1 + 1
   60 if (j > n) go to 70
  sc = snrm2(m,a(1,j),1)
  if (sc /= zero) sc = one/sc
  call sscal(m, sc, a(1,j), 1)
  x(j) = sc
  j = j + 1
  go to 60
   70 if (.not.(n1 > 0)) go to 130
!
!     copy transpose of (h g y) to work array ws(*).
  iw = 0
  do 80 i=1,m
!
!     move col of transpose of h into work array.
     call scopy(n2, a(i,n1+1), mda, ws(iw+1), 1)
     iw = iw + n2
!
!     move col of transpose of g into work array.
     call scopy(n1, a(i,1), mda, ws(iw+1), 1)
     iw = iw + n1
!
!     move component of vector y into work array.
     ws(iw+1) = a(i,np1)
     iw = iw + 1
   80 continue
  ws(iw+1) = zero
  call scopy(n, ws(iw+1), 0, ws(iw+1), 1)
  iw = iw + n
  ws(iw+1) = one
  iw = iw + 1
!
!     solve eu=f subject to (transpose of h)u=0, u >= 0.  the
!     matrix e = transpose of (g y), and the (n+1)-vector
!     f = transpose of (0,...,0,1).
  ix = iw + 1
  iw = iw + m
  call wnnls(ws, np1, n2, np1-n2, m, 0, prgopt, ws(ix), rnorm, &
   modew, is, ws(iw+1))
!
!     compute the components of the soln denoted above by w.
  sc = one - sdot(m,a(1,np1),1,ws(ix),1)
  if (.not.(one+fac*abs(sc)/=one .and. rnorm > zero)) go to 110
  sc = one/sc
  do 90 j=1,n1
     x(j) = sc*sdot(m,a(1,j),1,ws(ix),1)
   90 continue
!
!     compute the vector q=y-gw.  overwrite y with this vector.
  do 100 i=1,m
     a(i,np1) = a(i,np1) - sdot(n1,a(i,1),mda,x,1)
  100 continue
  go to 130
  110 mode = 2
  return
  130 if (.not.(n2 > 0)) go to 180
!
!     copy transpose of (h q) to work array ws(*).
  iw = 0
  do 140 i=1,m
     call scopy(n2, a(i,n1+1), mda, ws(iw+1), 1)
     iw = iw + n2
     ws(iw+1) = a(i,np1)
     iw = iw + 1
  140 continue
  ws(iw+1) = zero
  call scopy(n2, ws(iw+1), 0, ws(iw+1), 1)
  iw = iw + n2
  ws(iw+1) = one
  iw = iw + 1
  ix = iw + 1
  iw = iw + m
!
!     solve rv=s subject to v >= 0.  the matrix r =(transpose
!     of (h q)), where q=y-gw.  the (n2+1)-vector s =(transpose
!     of (0,...,0,1)).
!
  call wnnls(ws, n2+1, 0, n2+1, m, 0, prgopt, ws(ix), rnorm, modew, &
   is, ws(iw+1))
!
!     compute the components of the soln denoted above by z.
!
  sc = one - sdot(m,a(1,np1),1,ws(ix),1)
  if (.not.(one+fac*abs(sc)/=one .and. rnorm > zero)) go to 160
  sc = one/sc
  do 150 j=1,n2
     l = n1 + j
     x(l) = sc*sdot(m,a(1,l),1,ws(ix),1)*x(l)
  150 continue
  go to 180
  160 mode = 2
  return
!
!     account for scaling of rt.-side vector in solution.
  180 call sscal(n, ynorm, x, 1)
  wnorm = snrm2(n1,x,1)
  return
end
subroutine lsei(w, mdw, me, ma, mg, n, prgopt, x, rnorme, rnorml, &
   mode, ws, ip)
!
!*******************************************************************************
!
!! LSEI solves a linearly constrained least squares problem
!  with both equality and inequality constraints, and, if the
!     user requests, obtains a covariance matrix of the solution
!     parameters.
!
!     suppose there are given matrices e, a and g of respective
!     dimensions me by n, ma by n and mg by n, and vectors f, b and h of
!     respective lengths me, ma and mg.  this subroutine solves the
!     linearly constrained least squares problem
!
!                   ex = f, (e me by n) (equations to be exactly
!                                       satisfied)
!                   ax = b, (a ma by n) (equations to be
!                                       approximately satisfied,
!                                       least squares sense)
!                   gx >= h,(g mg by n) (inequality constraints)
!
!     the inequalities gx >= h mean that every component of the product
!     gx must be >= the corresponding component of h.
!
!     in case the equality constraints cannot be satisfied, a
!     generalized inverse solution residual vector length is obtained
!     for f-ex. this is the minimal length possible for f-ex.
!
!
!     any values me >= 0, ma >= 0, or mg >= 0 are permitted.  the
!     rank of the matrix e is estimated during the computation. we call
!     this value kranke. it is an output parameter in ip(1) defined
!     below. using a generalized inverse solution of ex=f, a reduced
!     least squares problem with inequality constraints is obtained.
!     the tolerances used in these tests for determining the rank
!     of e and the rank of the reduced least squares problem are
!     given in sandia tech. rept. sand78-1290. they can be
!     modified by the user if new values are provided in
!     the option list of the array prgopt(*).
!
!     the user must dimension all arrays appearing in the call list..
!     w(mdw,n+1),prgopt(*),x(n),ws(2*(me+n)+k+(mg+2)*(n+7)),ip(mg+2*n+2)
!     where k=max(ma+mg,n).  this allows for a solution of a range of
!     problems in the given working space.  the dimension of ws(*)
!     given is a necessary overestimate.  once a particular problem
!     has been run, the output parameter ip(3) gives the actual
!     dimension required for that problem.
!
!     the parameters for lsei( ) are
!
!     input..
!
!     w(*,*),mdw,   the array w(*,*) is doubly subscripted with
!     me,ma,mg,n    first dimensioning parameter equal to mdw.
!                   for this discussion let us call m = me+ma+mg.  then
!                   mdw must satisfy mdw >= m.  the condition
!                   mdw < m is an error.
!
!                   the array w(*,*) contains the matrices and vectors
!
!                                  (e  f)
!                                  (a  b)
!                                  (g  h)
!
!                   in rows and columns 1,...,m and 1,...,n+1
!                   respectively.
!
!                   the integers me, ma, and mg are the
!                   respective matrix row dimensions
!                   of e, a and g. each matrix has n columns.
!
!     prgopt(*)    this real-valued array is the option vector.
!                  if the user is satisfied with the nominal
!                  subprogram features set
!
!                  prgopt(1)=1 (or prgopt(1)=1.0)
!
!                  otherwise prgopt(*) is a linked list consisting of
!                  groups of data of the following form
!
!                  link
!                  key
!                  data set
!
!                  the parameters link and key are each one word.
!                  the data set can be comprised of several words.
!                  the number of items depends on the value of key.
!                  the value of link points to the first
!                  entry of the next group of data within
!                  prgopt(*).  the exception is when there are
!                  no more options to change.  in that
!                  case link=1 and the values key and data set
!                  are not referenced. the general layout of
!                  prgopt(*) is as follows.
!
!               ...prgopt(1)=link1 (link to first entry of next group)
!               .  prgopt(2)=key1 (key to the option change)
!               .  prgopt(3)=data value (data value for this change)
!               .       .
!               .       .
!               .       .
!               ...prgopt(link1)=link2 (link to the first entry of
!               .                       next group)
!               .  prgopt(link1+1)=key2 (key to the option change)
!               .  prgopt(link1+2)=data value
!               ...     .
!               .       .
!               .       .
!               ...prgopt(link)=1 (no more options to change)
!
!                  values of link that are nonpositive are errors.
!                  a value of link > nlink=100000 is also an error.
!                  this helps prevent using invalid but positive
!                  values of link that will probably extend
!                  beyond the program limits of prgopt(*).
!                  unrecognized values of key are ignored.  the
!                  order of the options is arbitrary and any number
!                  of options can be changed with the following
!                  restriction.  to prevent cycling in the
!                  processing of the option array a count of the
!                  number of options changed is maintained.
!                  whenever this count exceeds nopt=1000 the
!                  routine terminates.
!
!                  options..
!
!                  key=1
!                         compute in w(*,*) the n by n
!                  covariance matrix of the solution variables
!                  as an output paramter.  nominally the
!                  covariance matrix will not be computed.
!                  (this requires no user input.)
!                  the data set for this option is a single value.
!                  it must be nonzero when the covariance matrix
!                  is desired.  if it is zero, the covariance
!                  matrix is not computed.  when the covariance matrix
!                  is computed, the first dimensioning parameter
!                  of the array w(*,*) must satisfy mdw >= max (m,n).
!
!                  key=2
!                         scale the nonzero columns of the
!                         entire data matrix.
!                  (e)
!                  (a)
!                  (g)
!
!                  to have length one.  the data set for this
!                  option is a single value.  it must be
!                  nonzero if unit length column scaling
!                  is desired.
!
!                  key=3
!                         scale columns of the entire data matrix
!                  (e)
!                  (a)
!                  (g)
!
!                  with a user-provided diagonal matrix.
!                  the data set for this option consists
!                  of the n diagonal scaling factors, one for
!                  each matrix column.
!
!                  key=4
!                         change the rank determination tolerance for
!                  the equality constraint equations from
!                  the nominal value of sqrt(srelpr).  this quantity
!                  can be no smaller than srelpr, the arithmetic-
!                  storage precision.  the quantity srelpr is the
!                  largest positive number such that t=1.+srelpr
!                  satisfies t==1.  the quantity used
!                  here is internally restricted to be at
!                  least srelpr.  the data set for this option
!                  is the new tolerance.
!
!                  key=5
!                         change the rank determination tolerance for
!                  the reduced least squares equations from
!                  the nominal value of sqrt(srelpr).  this quantity
!                  can be no smaller than srelpr, the arithmetic-
!                  storage precision.  the quantity used
!                  here is internally restricted to be at
!                  least srelpr.  the data set for this option
!                  is the new tolerance.
!
!                  for example, suppose we want to change
!                  the tolerance for the reduced least squares
!                  problem, compute the covariance matrix of
!                  the solution parameters, and provide
!                  column scaling for the data matrix.  for
!                  these options the dimension of prgopt(*)
!                  must be at least n+9.  the fortran statements
!                  defining these options would be as follows.
!
!                  prgopt(1)=4 (link to entry 4 in prgopt(*))
!                  prgopt(2)=1 (covariance matrix key)
!                  prgopt(3)=1 (covariance matrix wanted)
!
!                  prgopt(4)=7 (link to entry 7 in prgopt(*))
!                  prgopt(5)=5 (least squares equas. tolerance key)
!                  prgopt(6)=... (new value of the tolerance)
!
!                  prgopt(7)=n+9 (link to entry n+9 in prgopt(*))
!                  prgopt(8)=3 (user-provided column scaling key)
!
!                  call scopy(n,d,1,prgopt(9),1)  (copy the n
!                    scaling factors from the user array d(*)
!                    to prgopt(9)-prgopt(n+8))
!
!                  prgopt(n+9)=1 (no more options to change)
!
!                  the contents of prgopt(*) are not modified
!                  by the subprogram.
!                  the key 8 and 9 options for wnnls( ) can also
!                  be included in this array.  their functions
!                  are documented in the usage instructions for
!                  subprogram wnnls( ).
!
!     output..
!
!     x(*),rnorme,  the array x(*) contains the solution parameters
!     rnorml        if the integer output flag mode = 0 or 1.
!                   the definition of mode is given directly below.
!                   when mode = 0 or 1, rnorme and rnorml
!                   respectively contain the residual vector
!                   euclidean lengths of f - ex and b - ax.  when
!                   mode=1 the equality constraint equations ex=f
!                   are contradictory, so rnorme/=0. the residual
!                   vector f-ex has minimal euclidean length. for
!                   mode >= 2, none of these parameters are
!                   defined.
!
!     mode          integer flag that indicates the subprogram
!                   status after completion.  if mode >= 2, no
!                   solution has been computed.
!
!                   mode =
!
!                   0  both equality and inequality constraints
!                      are compatible and have been satisfied.
!
!                   1  equality constraints are contradictory.
!                      a generalized inverse solution of ex=f was used
!                      to minimize the residual vector length f-ex.
!                      in this sense, the solution is still meaningful.
!
!                   2  no solution could be obtained. the constraints
!                      are contradictory.
!
!                   4  usage error occurred.  the value
!                      of mdw is < me+ma+mg, mdw is
!                      < n and a covariance matrix is
!                      requested, or the option vector
!                      prgopt(*) is not properly defined.
!
!     w(*,*)        the array w(*,*) contains the n by n symmetric
!                   covariance matrix of the solution parameters,
!                   provided this was requested on input with
!                   the option vector prgopt(*) and the output
!                   flag is returned with mode = 0 or 1.
!
!     ip(*)         the integer working array has three entries
!                   that provide rank and working array length
!                   information after completion.
!
!                      ip(1) = rank of equality constraint
!                              matrix.  define this quantity
!                              as kranke.
!
!                      ip(2) = rank of reduced least squares
!                              problem.
!
!                      ip(3) = the amount of storage in the
!                              working array ws(*) that was
!                              actually used by the subprogram.
!                              the formula given above for the length
!                              of ws(*) is a necessary overestimate.
!     user designated
!     working arrays..
!
!     ws(*),ip(*)              these are respectively type real
!                              and type integer working arrays.
!                              their required minimal lengths are
!                              given above.
!
!
!     subroutines called
!
!     lsi           part of this package.  solves a
!                   constrained least squares problem with
!                   inequality constraints.
!
!     sdot,sscal,   subroutines from the blas package.
!     saxpy,sasum,  see trans. math software (5), p. 308.
!     scopy,snrm2,
!     sswap,isamax
!
!     h12           subroutine to construct and apply a
!                   householder transformation.
!
!
!     revised oct. 1, 1989.
!
  real w(mdw,*), prgopt(*), x(n), ws(*)
  integer ip(*)
  logical cov
  data zero /0.e0/, one /1.e0/, half /0.5e0/
!
  srelpr = epsilon ( srelpr )
!
!     compute number of possible right multiplying householder
!     transformations.
!
  m = me + ma + mg
  mode = 0
  if (n <= 0 .or. me + ma <= 0) return
  if (.not.(mdw < m)) go to 80
  mode = 4
  return
   80 np1 = n + 1
  kranke = min (me,n)
  n1 = 2*kranke + 1
  n2 = n1 + n
!
!     process-option-vector
!
  go to 480
   90 if (.not.(cov .and. mdw < n)) go to 100
  mode = 4
  return
  100 l = kranke
!
!     compute norm of equality constraint matrix and rt side.
!
  enorm = zero
  do 110 j = 1,n
    enorm = max ( enorm,sasum(me,w(1,j),1))
  110 continue
  fnorm = sasum(me,w(1,np1),1)
  if (.not.(l > 0)) go to 200
  snmax = zero
  rnmax = zero
  do 180 i = 1,l
!
!     compute maximum ratio of vector lengths. partition
!     is at col. i.
    do 150 k = i,me
       sn = sdot(n-i+1,w(k,i),mdw,w(k,i),mdw)
       rn = sdot(i-1,w(k,1),mdw,w(k,1),mdw)
       if (.not.(rn==zero .and. sn > snmax)) go to 120
       snmax = sn
       imax = k
       go to 150
  120      if (.not.(k==i .or. (sn*rnmax > rn*snmax))) go to 150
       snmax = sn
       rnmax = rn
       imax = k
  150   continue
!
!     interchange rows if necessary.
    if (i/=imax) call sswap(np1, w(i,1), mdw, w(imax,1), mdw)
    if (.not.(snmax > tau**2*rnmax)) go to 160
!
!     eliminate elems i+1,...,n in row i.
    call h12(1, i, i+1, n, w(i,1), mdw, ws(i), w(i+1,1), mdw, 1, &
     m-i)
    go to 180
  160   kranke = i - 1
    go to 200
  180 continue
!
!     save diag. terms of lower trap. matrix.
!
  200 call scopy(kranke, w, mdw+1, ws(kranke+1), 1)
!
!     use householder trans from left to achieve kranke by kranke upper
!     triangular form.
!
  if (.not.(kranke > 0 .and. kranke < me)) go to 220
  do 210 kk = 1,kranke
    k = kranke + 1 - kk
!
!     apply tranformation to matrix cols. 1,...,k-1.
    call h12(1, k, kranke+1, me, w(1,k), 1, up, w, 1, mdw, k-1)
!
!     apply to rt side vector.
    call h12(2, k, kranke+1, me, w(1,k), 1, up, w(1,np1), 1, 1, 1)
  210 continue
  220 if (.not.(kranke > 0)) go to 240
!
!     solve for variables 1,...,kranke in new coordinates.
  call scopy(kranke, w(1,np1), 1, x, 1)
  do 230 i=1,kranke
    x(i) = (x(i)-sdot(i-1,w(i,1),mdw,x,1))/w(i,i)
  230 continue
!
!     compute residuals for reduced problem.
!
  240 mep1 = me + 1
  rnorml = zero
  if (.not.(me < m)) go to 270
  do 260 i = mep1,m
    w(i,np1) = w(i,np1) - sdot(kranke,w(i,1),mdw,x,1)
    sn = sdot(kranke,w(i,1),mdw,w(i,1),mdw)
    rn = sdot(n-kranke,w(i,kranke+1),mdw,w(i,kranke+1),mdw)
    if (.not.(rn <= tau**2*sn .and. kranke < n)) go to 260
    w(i,kranke+1) = zero
    call scopy(n-kranke, w(i,kranke+1), 0, w(i,kranke+1), mdw)
  260 continue
!
!     compute equal. constraint equas. residual length.
  270 rnorme = snrm2(me-kranke,w(kranke+1,np1),1)
!
!     move reduced problem data upward if kranke < me.
!
  if (.not.(kranke < me)) go to 290
  do 280 j=1,np1
    call scopy(m-me, w(me+1,j), 1, w(kranke+1,j), 1)
  280 continue
!
!     compute soln of reduced problem.
!
  290 call lsi(w(kranke+1,kranke+1), mdw, ma, mg, n-kranke, prgopt, &
   x(kranke+1), rnorml, mode, ws(n2), ip(2))
  if (mode > 1) go to 470
  if (.not.(me > 0)) go to 330
!
!     test for consistency of equality constraints.
!
  mdeqc = 0
  xnrme = sasum(kranke,w(1,np1),1)
  if (rnorme > tau*(enorm*xnrme+fnorm)) mdeqc = 1
  mode = mode + mdeqc
!
!     check if soln to equal. constraints satisfies inequal.
!     constraints when there are no degrees of freedom left.
!
  if (.not.(kranke==n .and. mg > 0)) go to 330
  xnorm = sasum(n,x,1)
  mapke1 = ma + kranke + 1
  mend = ma + kranke + mg
  do 310 i=mapke1,mend
    size = sasum(n,w(i,1),mdw)*xnorm + abs(w(i,np1))
    if (.not.(w(i,np1) > tau*size)) go to 310
    mode = 2
    go to 470
  310 continue
  330 if (.not.(kranke > 0)) go to 420
!
!     replace diag. terms of lower trap. matrix.
  call scopy(kranke, ws(kranke+1), 1, w, mdw+1)
!
!     reapply trans to put soln in original coordinates.
!
  do 340 ii = 1,kranke
    i = kranke + 1 - ii
    call h12(2, i, i+1, n, w(i,1), mdw, ws(i), x, 1, 1, 1)
  340 continue
!
!     compute cov matrix of equal. constrained problem.
!
  if (.not.(cov)) go to 450
  do 400 jj=1,kranke
    j = kranke + 1 - jj
    if (.not.(j < n)) go to 400
    rb = ws(j)*w(j,j)
    if (rb/=zero) rb = one/rb
    jp1 = j + 1
    do 350 i=jp1,n
      w(i,j) = sdot(n-j,w(i,jp1),mdw,w(j,jp1),mdw)*rb
  350   continue
    gam = sdot(n-j,w(jp1,j),1,w(j,jp1),mdw)*rb
    gam = half*gam
    call saxpy(n-j, gam, w(j,jp1), mdw, w(jp1,j), 1)
    do 370 i=jp1,n
      do 360 k=i,n
        w(i,k) = w(i,k) + w(j,i)*w(k,j) + w(i,j)*w(j,k)
        w(k,i) = w(i,k)
  360     continue
  370   continue
    uj = ws(j)
    vj = gam*uj
    w(j,j) = uj*vj + uj*vj
    do 380 i=jp1,n
      w(j,i) = uj*w(i,j) + vj*w(j,i)
  380   continue
    call scopy(n-j, w(j,jp1), mdw, w(jp1,j), 1)
  400 continue
!
!     apply the scaling to the covariance matrix.
!
  420 if (.not.(cov)) go to 450
  do 430 i = 1,n
    l = n1 + i
    call sscal(n, ws(l-1), w(i,1), mdw)
    call sscal(n, ws(l-1), w(1,i), 1)
  430 continue
!
!     rescale soln. vector.
!
  450 if (mode > 1) go to 470
  do 460 j = 1,n
    l = n1 + j
    x(j) = x(j)*ws(l-1)
  460 continue
  470 ip(1) = kranke
  ip(3) = ip(3) + 2*kranke + n
  return
  480 continue
!     to process-option-vector
!
!     the nominal tolerance used in the code
!     for the equality constraint equations.
  tau = sqrt(srelpr)
!
!     the nominal column scaling used in the code is
!     the identity scaling.
  ws(n1) = one
  call scopy(n, ws(n1), 0, ws(n1), 1)
!
!     no covariance matrix is nominally computed.
  cov = .false.
!
!     define bound for number of options to change.
  nopt = 1000
  ntimes = 0
!
!     define bound for positive values of link.
  nlink = 100000
  last = 1
  link = prgopt(1)
  if (.not.(link <= 0 .or. link > nlink)) go to 490
  mode = 4
  return
  490 if (.not.(link > 1)) go to 540
  ntimes = ntimes + 1
  if (.not.(ntimes > nopt)) go to 500
  mode = 4
  return
  500 key = prgopt(last+1)
  if (key==1) cov = prgopt(last+2)/=zero
  if (.not.(key==2 .and. prgopt(last+2)/=zero)) go to 520
  do 510 j=1,n
    t = snrm2(m,w(1,j),1)
    if (t/=zero) t = one/t
    l = n1 + j
    ws(l-1) = t
  510 continue
  520 if (key==3) call scopy(n, prgopt(last+2), 1, ws(n1), 1)
  if (key==4) tau = max ( srelpr,prgopt(last+2))
  next = prgopt(link)
  if (.not.(next <= 0 .or. next > nlink)) go to 530
  mode = 4
  return
  530 last = link
  link = next
  go to 490
  540 do 550 j=1,n
    l = n1 + j
    call sscal(m, ws(l-1), w(1,j), 1)
  550 continue
  go to 90
end
subroutine lsi(w, mdw, ma, mg, n, prgopt, x, rnorm, mode, ws, ip)
!
!*******************************************************************************
!
!! LSI is a companion subprogram to lsei( ).
!
!     the documentation for lsei( ) has more complete
!     usage instructions.
!     written by r. j. hanson, sla.
!
!     solve..
!              ax = b,  a  ma by n  (least squares equations)
!     subject to..
!
!              gx >= h, g  mg by n  (inequality constraints)
!
!     input..
!
!      w(*,*) contains  (a b) in rows 1,...,ma+mg, cols 1,...,n+1.
!                       (g h)
!
!     mdw,ma,mg,n
!              contain (resp) var. dimension of w(*,*),
!              and matrix dimensions.
!
!     prgopt(*),
!              program option vector.
!
!     output..
!
!      x(*),rnorm
!
!              solution vector(unless mode=2), length of ax-b.
!
!      mode
!              =0   inequality constraints are compatible.
!              =2   inequality constraints contradictory.
!
!      ws(*),
!              working storage of dimension k+n+(mg+2)*(n+7),
!              where k=max(ma+mg,n).
!      ip(mg+2*n+1)
!              integer working storage
!
!     subroutines called
!
!     lpdp          this subprogram minimizes a sum of squares
!                   of unknowns subject to linear inequality
!                   constraints.  part of this package.
!
!     sdot,sscal    subroutines from the blas package.
!     saxpy,sasum,  see trans. math software (5), p. 308.
!     scopy,sswap
!
!     hfti          solves an unconstrained linear least squares
!                   problem.
!
!     h12           subroutine to construct and apply a householder
!                   transformation.
!
!
  real w(mdw,*), prgopt(*), x(*), ws(*), rnrm(1), opt(7)
  integer ip(*)
  logical cov
!
  data zero /0.e0/, one /1.e0/, half /0.5e0/
!
  srelpr = epsilon ( srelpr )
  mode = 0
  rnorm = zero
  m = ma + mg
  np1 = n + 1
  krank = 0
  if (n <= 0 .or. m <= 0) go to 70
!
!     process-option-vector
!
  go to 500
!
!     compute matrix norm of least squares equas.
!
   40 anorm = zero
  do 50 j = 1,n
    anorm = max ( anorm,sasum(ma,w(1,j),1))
   50 continue
!
!     set tol for hfti( ) rank test.
  tau = tol*anorm
!
!     compute householder orthogonal decomp of matrix.
!
  if (n > 0) ws(1) = zero
  call scopy(n, ws, 0, ws, 1)
  call scopy(ma, w(1,np1), 1, ws, 1)
  k = max (m,n)
  minman = min (ma,n)
  n1 = k + 1
  n2 = n1 + n
  call hfti(w, mdw, ma, n, ws, 1, 1, tau, krank, rnrm, ws(n2), &
   ws(n1), ip)
  rnorm = rnrm(1)
  fac = one
  gam = ma - krank
  if (krank < ma) fac = rnorm**2/gam
  go to 80
!
!     reduce-to-lpdp-and-solve
!
   70 ip(1) = krank
  ip(2) = n + max (m,n) + (mg+2)*(n+7)
  return
!
!     to reduce-to-lpdp-and-solve
!
   80 map1 = ma + 1
!
!     compute ineq. rt-hand side for lpdp.
!
  if (.not.(ma < m)) go to 260
  if (.not.(minman > 0)) go to 160
  do 90 i = map1,m
    w(i,np1) = w(i,np1) - sdot(n,w(i,1),mdw,ws,1)
   90 continue
  do 100 i = 1,minman
    j = ip(i)
!
!     apply permutations to cols of ineq. constraint matrix.
    call sswap(mg, w(map1,i), 1, w(map1,j), 1)
  100 continue
!
!     apply householder transformations to constraint matrix.
!
  if (.not.(0 < krank .and. krank < n)) go to 120
  do 110 ii = 1,krank
    i = krank + 1 - ii
    l = n1 + i
    call h12(2, i, krank+1, n, w(i,1), mdw, ws(l-1), w(map1,1), &
     mdw, 1, mg)
  110 continue
!
!     compute permuted ineq. constr. matrix times r-inverse.
!
  120 do 150 i=map1,m
    if (.not.(0 < krank)) go to 150
    do 130 j=1,krank
      w(i,j) = (w(i,j)-sdot(j-1,w(1,j),1,w(i,1),mdw))/w(j,j)
  130   continue
  150 continue
!
!     solve the reduced problem with lpdp algorithm,
!     the least projected distance problem.
!
  160 call lpdp(w(map1,1), mdw, mg, krank, n-krank, opt, x, xnorm, &
   mdlpdp, ws(n2), ip(n+1))
  if (mdlpdp /= 1) go to 240
  if (.not.(krank > 0)) go to 180
!
!     compute soln in original coordinates.
!
  do 170 ii = 1,krank
    i = krank + 1 - ii
    x(i) = (x(i)-sdot(ii-1,w(i,i+1),mdw,x(i+1),1))/w(i,i)
  170 continue
!
!     apply householder trans. to soln vector.
!
  180 if (.not.(0 < krank .and. krank < n)) go to 200
  do 190 i = 1,krank
    l = n1 + i
    call h12(2, i, krank+1, n, w(i,1), mdw, ws(l-1), x, 1, 1, 1)
  190 continue
  200 if (.not.(minman > 0)) go to 270
!
!     repermute variables to their input order.
  do 210 ii=1,minman
    i = minman + 1 - ii
    j = ip(i)
    call sswap(1, x(i), 1, x(j), 1)
  210 continue
!
!     variables are now in orig. coordinates.
!     add soln of unsconstrained prob.
  do 220 i = 1,n
    x(i) = x(i) + ws(i)
  220 continue
!
!     compute the residual vector norm.
  rnorm = sqrt(rnorm**2+xnorm**2)
  go to 270
  240 mode = 2
  go to 270
  260 call scopy(n, ws, 1, x, 1)
  270 if (.not.(cov .and. krank > 0)) go to 70
!
!     compute covariance matrix based on the orthogonal decomp.
!     from hfti( ).
!
  krm1 = krank - 1
  krp1 = krank + 1
!
!     copy diag. terms to working array.
  call scopy(krank, w, mdw+1, ws(n2), 1)
!
!     reciprocate diag. terms.
  do 280 j = 1,krank
    w(j,j) = one/w(j,j)
  280 continue
  if (.not.(krank > 1)) go to 310
!
!     invert the upper triangular qr factor on itself.
  do 300 i=1,krm1
    ip1 = i + 1
    do 290 j=ip1,krank
      w(i,j) = -sdot(j-i,w(i,i),mdw,w(i,j),1)*w(j,j)
  290   continue
  300 continue
!
!     compute the inverted factor times its transpose.
  310 do 330 i=1,krank
    do 320 j=i,krank
      w(i,j) = sdot(krank+1-j,w(i,j),mdw,w(j,j),mdw)
  320   continue
  330 continue
  if (.not.(krank < n)) go to 450
!
!     zero out lower trapezoidal part.
!     copy upper tri. to lower tri. part.
  do 340 j=1,krank
    call scopy(j, w(1,j), 1, w(j,1), mdw)
  340 continue
  do 350 i=krp1,n
    w(i,1) = zero
    call scopy(i, w(i,1), 0, w(i,1), mdw)
  350 continue
!
!     apply right side transformations to lower tri.
  n3 = n2 + krp1
  do 430 i=1,krank
    l = n1 + i
    k = n2 + i
    rb = ws(l-1)*ws(k-1)
    if (.not.(rb < zero)) go to 420
!
!     if rb >= zero, transformation can be regarded as zero.
    rb = one/rb
!
!     store unscaled rank-one householder update in work array.
    ws(n3) = zero
    call scopy(n, ws(n3), 0, ws(n3), 1)
    l = n1 + i
    k = n3 + i
    ws(k-1) = ws(l-1)
    do 360 j=krp1,n
      k = n3 + j
      ws(k-1) = w(i,j)
  360   continue
    do 370 j=1,n
      l = n3 + i
      k = n3 + j
      ws(j) = sdot(j-i,w(j,i),mdw,ws(l-1),1) + sdot(n-j+1,w(j,j),1, &
       ws(k-1),1)
      ws(j) = ws(j)*rb
  370   continue
    l = n3 + i
    gam = sdot(n-i+1,ws(l-1),1,ws(i),1)*rb
    gam = gam*half
    call saxpy(n-i+1, gam, ws(l-1), 1, ws(i), 1)
    do 410 j=i,n
      if (.not.(i > 1)) go to 390
      im1 = i - 1
      k = n3 + j
      do 380 l=1,im1
        w(j,l) = w(j,l) + ws(k-1)*ws(l)
  380     continue
  390     k = n3 + j
      do 400 l=i,j
        il = n3 + l
        w(j,l) = w(j,l) + ws(j)*ws(il-1) + ws(l)*ws(k-1)
  400     continue
  410   continue
  420   continue
  430 continue
!
!     copy lower tri. to upper tri. to symmetrize the covariance matrix.
!
  do 440 i = 1,n
    call scopy(i, w(i,1), mdw, w(1,i), 1)
  440 continue
!
!     repermute rows and cols.
!
  450 do 470 ii = 1,minman
    i = minman + 1 - ii
    k = ip(i)
    if (.not.(i/=k)) go to 470
    call sswap(1, w(i,i), 1, w(k,k), 1)
    call sswap(i-1, w(1,i), 1, w(1,k), 1)
    call sswap(k-i-1, w(i,i+1), mdw, w(i+1,k), 1)
    call sswap(n-k, w(i,k+1), mdw, w(k,k+1), mdw)
  470 continue
!
!     put in normalized residual sum of squares scale factor
!     and symmetrize the resulting covariance marix.
!
  do 480 j = 1,n
    call sscal(j, fac, w(1,j), 1)
    call scopy(j, w(1,j), 1, w(j,1), mdw)
  480 continue
  go to 70
!
!     to process-option-vector
!
!     the nominal tolerance used in the code,
  500 tol = sqrt(srelpr)
  cov = .false.
  last = 1
  link = prgopt(1)
  key8 = 0
  key9 = 0
  510    if (.not.(link > 1)) go to 540
     key = prgopt(last+1)
     if (key == 1) cov = prgopt(last+2)/=zero
     if (key == 5) tol = max ( srelpr,prgopt(last+2))
     if (key /= 8) go to 520
        key8 = 1
        eps = prgopt(last+2)
        go to 530
  520    if (key /= 9) go to 530
        key9 = 1
        blowup = prgopt(last+2)
  530    next = prgopt(link)
     last = link
     link = next
     go to 510
!
!     prepare the option vector for wnnls
!
  540 j = 1
  if (key8 == 0) go to 550
     opt(1) = 4.0
     opt(2) = 8.0
     opt(3) = eps
     j = 4
  550 if (key9 == 0) go to 560
     opt(j) = j + 3
     opt(j+1) = 9.0
     opt(j+2) = blowup
     j = j + 3
  560 opt(j) = 1.0
  go to 40
end
subroutine lsod1 (f,neq,t,y,tout,rtol,atol,idid,ypout, &
                  yh,yh1,ewt,savf,acor,wm,iwm,jac,intout, &
                  tstop,tolfac,delsgn,rpar,ipar)
!
!*******************************************************************************
!
!! LSOD1 is called by stfode to solve ordinary differential equations.
!
!
!   stfode  merely allocates storage for lsod1 to relieve the user of
!   the inconvenience of a long call list.  consequently lsod1 is used
!   as described in the comments for  stfode.
!
!
  logical intout
!
  integer max3
  dimension y(neq),ypout(neq),yh(neq,*),yh1(*),ewt(neq),savf(neq), &
            acor(neq),wm(*),iwm(*),rtol(*),atol(*),rpar(*),ipar(*)
!
  common /debdf1/ told, rowns(210), &
     el0, h, hmin, hmxi, hu, x, u, &
     iquit, init, lyh, lewt, lacor, lsavf, lwm, ksteps, &
     ibegin, itol, iinteg, itstop, ijac, iband, iowns(6), &
     ier, jstart, kflag, ldum, meth, miter, maxord, n, nq, nst, &
     nfe, nje, nqu
!
  external f , jac
!
!
!
!  the expense of solving the problem is monitored by counting the
!  number of  steps attempted. when this exceeds  maxnum, the counter
!  is reset to zero and the user is informed about possible excessive
!  work.
!
  data maxnum/500/
!
!
!
  if (ibegin /= 0) go to 10
!
! on the first call , perform initialization --
!
  u = epsilon ( u )
!                       -- set associated machine dependent parameter
  wm(1)=sqrt(u)
!                       -- set termination flag
  iquit=0
!                       -- set initialization indicator
  init=0
!                       -- set counter for attempted steps
  ksteps=0
!                       -- set indicator for intermediate-output
  intout= .false.
!                       -- set start indicator for stod code
  jstart= 0
!                       -- set bdf method indicator
  meth = 2
!                       -- set maximum order for bdf method
  maxord = 5
!                       -- set iteration matrix indicator
!
  if (ijac == 0  .and.  iband == 0) miter = 2
  if (ijac == 1  .and.  iband == 0) miter = 1
  if (ijac == 0  .and.  iband == 1) miter = 5
  if (ijac == 1  .and.  iband == 1) miter = 4
!
!                       -- set other necessary items in common block
  n = neq
  nst = 0
  nje = 0
  hmxi = 0.
  nq = 1
  h = 1.
!                       -- reset ibegin for subsequent calls
  ibegin = 1
!
!
!
!      check validity of input paramaters on each entry
!
   10 if (neq >= 1) go to 20
  idid = -33
  go to 110
!
   20 max3 = 1
  if (itol /= 0) max3 = neq
  do 60 k = 1,max3
    if (rtol(k) >= 0.) go to 30
       idid = -34
       go to 110
   30   if (atol(k) >= 0.) go to 60
       idid = -35
       go to 110
   60   continue
!
  if (itstop /= 1) go to 80
  if ((tout - t)*(tstop - t) >= 0.0 &
    .and. abs(tout-t) <= abs(tstop-t)) go to 80
  idid = -36
  go to 110
!
   80 if (init == 0) go to 150
!                       check some continuation possibilities
  if (t /= tout) go to 90
  idid = -37
  go to 110
!
   90 if (t == told) go to 100
  idid = -38
  go to 110
!
  100 if (init == 1) go to 150
  if (delsgn*(tout-t) >= 0.) go to 150
  idid = -39
!
!                       invalid input detected
  110 iquit = -33
  ibegin = -1
  return
!
!
!
!     rtol = atol = 0. is allowed as valid input and interpreted as
!     asking for the most accurate solution possible. in this case,
!     the relative error tolerance rtol is reset to the smallest value
!     100*u which is likely to be reasonable for this method and machine
!
  150 do 170 k = 1,max3
    if (rtol(k) + atol(k) > 0.) go to 170
    rtol(k) = 100.*u
    idid = -2
  170   continue
  if (idid == -2) return
!
!     branch on status of initialization indicator
!            init=0 means initial derivatives and nominal step size
!                   and direction not yet set
!            init=1 means nominal step size and direction not yet set
!            init=2 means no futher initialization required
!
  if (init == 0) go to 200
  if (init == 1) go to 220
  go to 240
!
!
!
!     more initialization --
!                         -- evaluate initial derivatives
!
  200 init = 1
  call f(t,y,yh(1,2),rpar,ipar)
  nfe = 1
  if (t /= tout) go to 220
  idid = 2
  do 210 l = 1,neq
  210    ypout(l) = yh(l,2)
  told = t
  return
!
!                         -- compute initial step size
!                         -- save sign of integration direction
!                         -- set independent and dependent variables
!                                              x and yh(*) for stod
!
  220 ltol = 1
  do 225 l = 1,neq
    if (itol == 1) ltol = l
    tol = rtol(ltol)*abs(y(l)) + atol(ltol)
    if (tol == 0.) go to 380
  225   ewt(l) = tol
!
  big = sqrt ( huge ( big ) )
  call hstart (f,neq,t,tout,y,yh(1,2),ewt,1,u,big, &
               yh(1,3),yh(1,4),yh(1,5),yh(1,6),rpar,ipar,h)
!
  delsgn = sign(1.0,tout-t)
  x = t
  do 230 l = 1,neq
    yh(l,1) = y(l)
  230   yh(l,2) = h*yh(l,2)
  init = 2
!
!
!
!   on each call set information which determines the allowed interval
!   of integration before returning with an answer at tout
!
  240 del = tout - t
  absdel = abs(del)
!
!
!
!   if already past output point, interpolate and return
!
  250 if (abs(x-t) < absdel) go to 270
  call intyd(tout,0,yh,neq,y,intflg)
  call intyd(tout,1,yh,neq,ypout,intflg)
  idid = 3
  if (x /= tout) go to 260
  idid = 2
  intout = .false.
  260 t = tout
  told = t
  return
!
!   if cannot go past tstop and sufficiently close,
!   extrapolate and return
!
  270 if (itstop /= 1) go to 290
  if (abs(tstop-x) >= 100.*u*abs(x)) go to 290
  dt = tout - x
  do 280 l = 1,neq
  280   y(l) = yh(l,1) + (dt/h)*yh(l,2)
  call f(tout,y,ypout,rpar,ipar)
  nfe = nfe + 1
  idid = 3
  t = tout
  told = t
  return
!
  290 if (iinteg == 0  .or.  .not.intout) go to 300
!
!   intermediate-output mode
!
  idid = 1
  go to 500
!
!
!
!     monitor number of steps attempted
!
  300 if (ksteps <= maxnum) go to 330
!
!                       a significant amount of work has been expended
  idid = -1
  ksteps = 0
  go to 500
!
!
!
!   limit step size and set weight vector
!
  330 hmin = 100.*u*abs(x)
  ha = max ( abs(h),hmin)
  if (itstop /= 1) go to 340
  ha = amin1(ha,abs(tstop-x))
  340 h = sign(ha,h)
  ltol = 1
  do 350 l = 1,neq
    if (itol == 1) ltol = l
    ewt(l) = rtol(ltol)*abs(yh(l,1)) + atol(ltol)
    if (ewt(l) <= 0.0) go to 380
  350   continue
  tolfac = u*vnwrms(neq,yh,ewt)
  if (tolfac <= 1.) go to 400
!
!                       tolerances too small
  idid = -2
  tolfac = 2.*tolfac
  do 360 l = 1,max3
    rtol(l) = tolfac*rtol(l)
  360   atol(l) = tolfac*atol(l)
  go to 500
!
!                       relative error criterion inappropriate
  380 idid = -3
  ibegin = -l
  go to 500
!
!
!
!     take a step
!
  400 call stod(neq,y,yh,neq,yh1,ewt,savf,acor,wm,iwm,f,jac,rpar,ipar)
!
  jstart = -2
  intout = .true.
  if (kflag == 0) go to 250
!
!
!
  if (kflag == -1) go to 450
!
!                       repeated corrector convergence failures
  idid = -6
  iquit = -6
  ibegin = -1
  go to 500
!
!                       repeated error test failures
  450 idid = -7
  iquit = -7
  ibegin = -1
!
!
!
!                       store values before returning to stfode
  500 do 555 l = 1,neq
    y(l) = yh(l,1)
  555   ypout(l) = yh(l,2)/h
  t = x
  told = t
  intout = .false.
  return
end
subroutine ltrp (m,x,y,n,xi,yi,ni,t,ierr)
!
!*******************************************************************************
!
!! LTRP performs Lagrange interpolation.
!
  dimension x(n),y(n),xi(ni),yi(ni),t(m)
!
!     check input
!
  if (m < 2) go to 130
  if (m > n) go to 131
  if (ni < 1) go to 132
  ierr = 0
!
!     initialization
!
  mm1 = m-1
  k  = 1
  xx = xi(1)
  ilold = 0
!
!     find the subinterval which contains xx. i = 1 if xx < x(2)
!     and i = n if xx >= x(n). otherwise x(i) <= xx < x(i+1).
!
  if (xx-x(1)) 10,11,20
   10 i = 1
  il = 1
  ir = m
  go to 80
   11 i = 1
  yi(k) = y(1)
  go to 110
!
   20 if (x(n)-xx) 21,22,23
   21 i = n
  il = n-m+1
  ir = n
  go to 80
   22 i = n
  yi(k) = y(n)
  go to 110
   23 il = 1
  ir = n
!
!     bisection search
!
   30 i = (il+ir)/2
  if (i==il) go to 50
  if (xx-x(i)) 31,32,33
   31 ir = i
  go to 30
   32 yi(k) = y(i)
  go to 110
   33 il = i
  go to 30
!
!     linear forward search
!
   40 if (xx-x(i+1)) 50,41,42
   41 i = i+1
  yi(k) = y(i)
  go to 110
   42 i = i+1
  go to 40
!
!     point xx lies in the open subinterval (x(i),x(i+1)).
!     find the m closest points x(il),...,x(ir) to xx.
!
   50 if (i > m) go to 51
  il = 1
  num = i
  go to 60
   51 il = i-m+1
  num = m
!
   60 ipm = i+m
  if (ipm <= n) go to 61
  ir = n
  num = num+n-i
  go to 70
   61 ir = ipm
  num = num+m
!
   70 num = num-m
  if (num==0) go to 80
  dl = xx-x(il)
  dr = x(ir)-xx
  do 72 l=1,num
  if (dl <= dr) go to 71
  il = il+1
  dl = xx-x(il)
  go to 72
   71 ir = ir-1
  dr = x(ir)-xx
   72 continue
!
!     compute the coefficients t(1),...,t(m) of the backward
!     newton form of the interpolating polynomial.
!
   80 if (il==ilold) go to 100
  ilold = il
  ilm1 = il-1
  do 81 j=1,m
  l = ilm1+j
   81 t(j) = y(l)
!
  do 91 istep=1,mm1
  jmax = m-istep
  do 90 j=1,jmax
  ii = ilm1+j
  l = ii+istep
   90 t(j) = (t(j)-t(j+1))/(x(ii)-x(l))
   91 continue
!
!     evaluation of the interpolating polynomial
!
  100 yi(k) = t(1)
  do 101 j=2,m
  l = ilm1+j
  101 yi(k) = t(j)+yi(k)*(xx-x(l))
!
!     next point
!
  110 if (k >= ni) return
  k = k+1
  xx = xi(k)
  if (xx-x(1)) 10,11,111
  111 if (x(n)-xx) 21,22,120
!
  120 if (xx-xi(k-1)) 121,122,40
  121 il = 1
  ir = min (i+1,n)
  go to 30
  122 yi(k) = yi(k-1)
  go to 110
!
!     error return
!
  130 ierr = 1
  return
  131 ierr = 2
  return
  132 ierr = 3
  return
end
subroutine luimp(a, ka, n, q, kq, ipvt, b, x, r, ind)
!
!*******************************************************************************
!
!! LUIMP improves the solution of a linear system by iterative refinement.
!
!
!       given an approximate solution x of a linear system ax = b
!       obtained using sgeco or sgefa. luimp attempts to compute
!       an improved solution correct to machine precision.
!
!     parameters
!
!       a    an array of dimension (ka,n) containing the matrix
!            a of order n.
!       q    an array of dimension (kq,n) containing the lu
!            decomposition of a produced by sgeco or sgefa.
!       ipvt an array of dimension n containing the permutation
!            information given by sgeco or sgefa.
!       b    the right hand side of the equation ax = b.
!       x    on input x is the approximate solution of ax = b to
!            be improved. on output x is the solution obtained.
!       r    an array for internal use by the routine.
!       ind  variable that reports the status of the results.
!            ind = 0 if improvement of x is successful with a
!            gain in accuracy of at least 50 per cent each
!            iteration. otherwise ind = 1.
!
!     method
!       luimp executes the iteration cycle
!            (1)  ar = b - ax
!            (2)  x = x + r
!       with an initial given x. the residual vector b - ax is
!       computed to high accuracy using double precision. sgesl
!       is then used to solve (1).
!
!
  dimension a(ka,n), q(kq,n), ipvt(n), b(n), x(n), r(n)
  double precision dsum
!
  eps = epsilon ( eps )
  ind = 0
  xnrm = 0.0
  do 10 i = 1,n
   10 xnrm = xnrm + x(i)*x(i)
  if (xnrm == 0.0) return
  eps2 = eps*eps
  ratio = 1.0
!
!                  compute the residual vector
!
   20 do 22 i = 1,n
  dsum = b(i)
    do 21 j = 1,n
   21   dsum = dsum - dble(a(i,j))*dble(x(j))
   22 r(i) = dsum
!
!                  find the correction vector
!
  call sgesl(q, kq, n, ipvt, r, 0)
  rnrm = 0.0
  do 30 i = 1,n
   30 rnrm = rnrm + r(i)*r(i)
  if (rnrm <= eps2*xnrm) return
!
!                form a new approximate solution
!
  do 40 i = 1,n
   40 x(i) = x(i) + r(i)
  xnrm = 0.0
  do 41 i = 1,n
   41 xnrm = xnrm + x(i)*x(i)
!
  if (xnrm == 0.0) return
  rat = ratio
  ratio = rnrm/xnrm
  if (ratio <= 0.25*rat) go to 20

  if (ratio > amin1(rat,4.0*eps2)) ind = 1
  return
end
subroutine mach (mo, n, ibeta, imax, idmax, imach, rmach, dmach)
!
!*******************************************************************************
!
!! MACH computes single and double precision machine constants.
!
!
!          computation of the environmental constants for the
!        single and double precision floating point arithmetics
!
!                           -----------
!
!     it is assumed that the single and double precision floating
!     point arithmetics have the same base, say ibeta, and that
!     the nonzero numbers are represented in the form
!
!        sign (ibeta**k) * (x(1)/ibeta + ... + x(m)/ibeta ** m)
!
!     where each x(i) is an integer such that
!
!        0 <= x(i) < ibeta
!
!     and  x(1) >= 1 . the exponent k is an integer such that
!
!        minexp <= k <= maxexp.
!
!     the values m, minexp, and maxexp are needed for both the
!     single and double precision arithmetics in order to define
!     the function ipmpar. this subroutine attempts to help the
!     user in obtaining this information.
!
!
!                         input and output
!
!
!     input ...
!
!       mo    - mode of operation of the routine.
!
!               mo = 0  output unit n is not used. the single
!                       and double precision arithmetics are
!                       examined.
!               mo = 1  it is assumed that unit n is used.
!                       mach searches for the maximum exponent
!                       maxexp for the single precision arith-
!                       metic. the double precision arithmetic
!                       is not examined.
!               mo = 2  it is assumed that unit n is used.
!                       mach searches for the maximum exponent
!                       maxexp for the double precision arith-
!                       metic. the single precision arithmetic
!                       is not examined.
!
!       n     - if n is positive then n is the number of an
!               output unit, where any information written on
!               the unit will be available to the user if mach
!               terminates because of overflow. if n <= 0
!               then no such output unit is to be used. (if no
!               such output unit is used then set mo = 0.)
!
!       ibeta - the base of the floating point arithmetics. (it
!               is assumed that the single and double precision
!               arithmetics have the same base.) if this value
!               is not known then
!
!                           call radix (ibeta)
!
!               will (hopefully) provide the correct value. as
!               far as is known, the subroutine radix operates
!               properly on all computers. nevertheless, the
!               value obtained for ibeta should be checked.
!
!       imax  - if imax is positive then imax is assumed to be
!               an approximation of the maximum exponent maxexp
!               for the single precision numbers. otherwise, if
!               imax <= 0, then the routine defines its own
!               initial approximation for maxexp.
!
!       idmax - if idmax is positive then idmax is assumed to be
!               an approximation of the maximum exponent maxexp
!               for the double precision numbers. otherwise, if
!               idmax <= 0, then the routine defines its own
!               initial approximation for maxexp.
!
!
!     output (when mo = 0) ...
!
!       imach - integer array of dimension 10 appearing in the
!               definition of the function ipmpar.
!               ipmpar(i) = imach(i)  i = 4,...,10
!
!       rmach - real array of dimension 3 giving the following
!               constants for the single precision arithmetic.
!               rmach(1) = b**(1-m), the machine precision
!               rmach(2) = the smallest positive number
!               rmach(3) = the largest positive number
!
!       dmach - double precision array of dimension 3 giving the
!               following constants for the double precision
!               arithmetic.
!               dmach(1) = b**(1-m), the machine precision
!               dmach(2) = the smallest positive number
!               dmach(3) = the largest positive number
!
!
!                              usage
!
!
!     the following procedure is recommended for obtaining the
!     data needed for defining ipmpar.
!
!
!     step (1). in this step we search for the maximum exponent
!     maxexp for the single precision arithmetic. the double
!     precision arithmetic is not considered. it is assumed that
!     an output unit n is being used. given n and ibeta. set
!     imax = 0 and compute ...
!
!        call mach (1, n, ibeta, imax, idmax, imach, rmach, dmach)
!
!     when this code is run, information is given on unit n for
!     resetting imax. if the maximum exponent has been found
!     (in this case, the last integer written on unit n will not
!     be followed by any statement except possibly an overflow
!     statement), then set imax to the last integer written on
!     unit n and go to step (2). otherwise, if the maximum
!     exponent has not been found, then reset imax according to
!     the instructions given on unit n and rerun the code. the
!     code may be rerun with different values of imax until the
!     the maximum exponent has been found or a satisfactory
!     approximation for the maximum exponent has been obtained.
!     then set imax to the maximum exponent (or the approximation)
!     and go to step (2).
!
!
!     step (2). in this step we search for the maximum exponent
!     maxexp for the double precision arithmetic. the single
!     precision arithmetic is not considered. it is assumed that
!     an output unit n is being used. given n and ibeta. set
!     idmax = 0 and compute ...
!
!        call mach (2, n, ibeta, imax, idmax, imach, rmach, dmach)
!
!     the procedure used in this step for finding the maximum
!     exponent or obtaining a suitable approximation for the
!     maximum exponent is the same as in step (1), the only
!     difference being that now one works with idmax instead
!     of imax. when the maximum exponent is found or a suitable
!     approximation is obtained, then reset idmax to the maximum
!     exponent (or the approximation) and go to step (3).
!
!
!     step (3). given the values obtained for ibeta, imax, and
!     idmax. then compute ...
!
!        call mach (0, 0, ibeta, imax, idmax, imach, rmach, dmach)
!
!     when this code terminates, all the data needed for defining
!     ipmpar(4),...,ipmpar(10) is given in the array imach. the
!     data given in the arrays rmach and dmach are provided so that
!     the user can check the information in imach.
!
!             rmach(1)  depends on imach(4) and imach(5)
!             rmach(2)  depends on imach(4) and imach(6)
!             rmach(3)  depends on imach(4) and imach(7)
!             dmach(1)  depends on imach(4) and imach(8)
!             dmach(2)  depends on imach(4) and imach(9)
!             dmach(3)  depends on imach(4) and imach(10)
!
!     the values in rmach and dmach should be checked to see if
!     they make sense. (for example, rmach(2) and dmach(2) should
!     never be 0.)
!
!
!                       general information
!
!
!     the values in imach(6) and imach(9) are the minimum exponents
!     for the numbers in the single and double precision arithmetics
!     which have full accuracy. on some computers, accuracy is lost
!     in the storage of some small numbers. this occurs in the double
!     precision arithmetics of the cdc 6000-7000 series computes. on
!     these machines, the double precision numbers less that 2**(-927)
!     normally have only single precision accuracy. consequently,
!     imach(9) will have the computed value -926 instead of -974
!     (which one would normally expect). in this case, -926 is the
!     value that is considered to be correct.
!
!     this package of subroutines includes mach, radix, mach1, store2,
!     mach2, dstor2. the package is experimental. it is provided as
!     an aid in defining the function ipmpar. the subroutines in the
!     package are not used by any of the functions or subroutines in
!     the nswc library.
!
!     the purpose of the subroutines store2 and dstor2 is to force
!     data to be stored in memory. these routines are needed when
!     data are stored in oversized registers.
!
!     the algorithm for the subroutine radix was developed by m.a.
!     malcolm (stanford university). see references (1) and (2).
!
!
!
!     written by
!        Alfred Morris,
!        naval surface warfare center
!        dahlgren virginia
!
!
!
!     revised ... april 1989
!
!
!
!     references ...
!
!     (1) malcolm, m.a., algorithms to reveal properties of floating
!         point arithmetic, comm. acm (15), 1972, pp. 949-951.
!
!     (2) gentlemen, w.m. and marovich, s.b., more on algorithms that
!         reveal properties of floating point arithmetic units,
!         comm. acm (17), 1974, pp. 276-277.
!
!     (3) cody, w.j. and waite, w., software manual for the elementary
!         functions, prentice-hall, 1980, pp.258-264.
!
!     (4) cody, w.j., machar. a subroutine to dynamically determine
!         machine parameters, 1988. (to be published)
!
!
  real rmach(3)
  double precision dmach(3)
  integer imach(10)
  double precision deps, dint, dmin, dmax
!
  imach(1) = 0
  imach(2) = 0
  imach(3) = 0
!
  n1 = n
  n2 = n
  if (mo >= 2) go to 10
!
!     obtain the single precision information
!
  if (mo <= 0) n1 = 0
  minexp = 0
  maxexp = imax
  call mach1 (n1, ibeta, m, minexp, maxexp, eps, xint, xmin, xmax)
  if (mo == 1) stop
  call mach1 (n1, ibeta, m, minexp, maxexp, eps, xint, xmin, xmax)
  rmach(1) = eps
  rmach(2) = xmin
  rmach(3) = xmax
  imach(4) = ibeta
  imach(5) = m
  imach(6) = minexp
  imach(7) = maxexp
  n2 = 0
!
!     obtain the double precision information
!
   10 minexp = 0
  maxexp = idmax
  call mach2 (n2, ibeta, m, minexp, maxexp, deps, dint, dmin, dmax)
  if (mo >= 2) stop
  call mach2 (n2, ibeta, m, minexp, maxexp, deps, dint, dmin, dmax)
  dmach(1) = deps
  dmach(2) = dmin
  dmach(3) = dmax
  imach(8) = m
  imach(9) = minexp
  imach(10)= maxexp
  return
end
subroutine mach1 (n, ibeta, m, minexp, maxexp, eps, xint, &
                    xmin, xmax)
!
!*******************************************************************************
!
!! MACH1 evaluates single precision machine constants.
!
!
!                 computation of the environmental constants
!             for the single precision floating point arithmetic
!
!                            -----------
!
!     input ...
!
!       n       - if n is positive then n is the number of an
!                 output unit. in this case it is assumed that
!                 any information that is written on the unit
!                 will be available to the user if the routine
!                 terminates because of overflow. unit n is
!                 used only for computing the exact maximum
!                 base ibeta exponent for the floating point
!                 numbers (this exponent is stored in maxexp).
!                 if the exact maximum exponent is not needed
!                 (or has already been obtained) then set n
!                 to 0 or a negative value.
!
!       ibeta   - the base of the floating point arithmetic.
!
!       minexp  - if minexp is negative then minexp is assumed
!                 to be the minimum (base ibeta) exponent for
!                 the floating point numbers. otherwise, if
!                 minexp >= 0, then the minimum exponent is
!                 computed.
!
!       maxexp  - if maxexp is positive then maxexp is assumed to
!                 be an approximation of the maximum (base ibeta)
!                 exponent for the floating point numbers. other-
!                 wise, if maxexp <= 0, then an approximation
!                 for the maximum exponent is obtained.
!
!     output ...
!
!       m       - the number of base ibeta digits in the floating
!                 point representation.
!
!       minexp  - the largest in magnitude negative integer such
!                 that real(ibeta)**(minexp - 1) is a positive
!                 number. (if minexp is negative on input then
!                 minexp may be altered.)
!
!       maxexp  - if maxexp is positive on input and n <= 0
!                 then maxexp is not modified.
!
!                 if maxexp <= 0 on input and n <= 0 then
!                 on output maxexp = an approximation of the
!                 maximum (base ibeta) exponent for the floating
!                 point numbers.
!
!                 if n is positive then the routine searches for
!                 the exact maximum exponent for the floating
!                 point numbers. if maxexp is positive on input
!                 then the search begins with maxexp. if
!                 maxexp <= 0 on input then the routine begins
!                 the search with its own initial approximation
!                 for maxexp. the following loop is performed.
!                     (1) check the current value of maxexp
!                         for overflow. if overflow occurs
!                         then the routine will (hopefully)
!                         abort. otherwise, if overflow does
!                         not occur then go to (2).
!                     (2) write on unit n the current value
!                         of maxexp and go to (3).
!                     (3) increase the value of maxexp by 1
!                         and return to (1).
!                 if the overflow test in (1) fails then the
!                 routine aborts after 500 passes through the
!                 loop. if the overflow test works properly
!                 then the last integer written on unit n is
!                 the desired maximum exponent for the float-
!                 ing point numbers. reset maxexp to this
!                 integer, set n = 0, and rerun the routine.
!
!       eps     - the relative precision of the floating arithmetic.
!                 eps = real(ibeta)**(1 - m)
!
!       xint    - the largest positive integer that can
!                 be exactly represented as a floating
!                 point number. xint = b**m - 1  where
!                 b = real(ibeta).
!
!       xmin    - the smallest nonzero power of the base.
!                 xmin = real(ibeta)**(minexp - 1)
!
!       xmax    - the largest foating point number that can
!                 be obtained having the exponent maxexp.
!                 xmax = (1 - b**(-m)) * b**maxexp  where
!                 b = real(ibeta). if maxexp is the maximum
!                 exponent for the floating point numbers
!                 then xmax is the largest floating point
!                 number that exists. the value obtained
!                 for xmax may be affected slightly by
!                 roundoff error.
!
  real eps, xint, xmin, xmax
  real b, b2, binv, bm1, d1, d2, one, p, q, t, x, z, zero
!
  common /spdata/ d1, d2
!
  zero = real(0)
  one = real(1)
  b = real(ibeta)
  b2 = b*b
  bm1 = real(ibeta - 1)
  binv = one/b
!
!     compute m and eps
!
  m = 1
  t = b
   10    m = m + 1
     z = t
     t = b*t
     call store2 (t + one, t)
     x = d1*binv - z
     if (x == binv) go to 10
!
  eps = one/z
  xint = (z - one)*b + bm1
  xmax = xint/t
!
!     compute minexp and xmin
!
  p = one + eps
  q = one + eps*b2
  if (minexp >= 0) go to 30
!
!     minexp has been given. check the value of minexp
!     and modify it (if necessary).
!
  minexp = minexp - 1
  do 15 k = 1,m
     minexp = minexp + 1
     xmin = b**(minexp + 2)
     xmin = ((xmin * binv) * binv) * binv
     xmin = xmin * one
     if (xmin + xmin /= zero) go to 20
   15 continue
!
!     obtain k, km, and j.
!
   20 k = 1 - minexp
  km = 1
   21    km = km + km
     if (km < k) go to 21
  if (km == k) km = k + k

  j = 0
  x = (xmin*binv)*one
  call store2 (x, q*x)
  if (x + x == zero .or. abs(x) >= xmin) go to 60
  if (t*d2 /= t*x) go to 60
  go to 51
!
!     minexp must be found. this loop obtains the largest
!     k = 2**i such that b**(-k) does not underflow.
!
   30 k = 1
  z = binv
   31    x = z
     z = (x*x)*one
     call store2 (z, p*z)
     if (z + z == zero .or. abs(z) >= x) go to 32
     if (t*d2 == t*z) go to 32
     k = k + k
     go to 31
   32 km = k + k
  j = 0
!
!     loop to determine minexp and xmin.
!
   40    xmin = x
     x = (x*binv)*one
     call store2 (x, p*x)
     if (x + x == zero .or. abs(x) >= xmin) go to 60
     if (t*d2 == t*x) go to 50
     k = k + 1
     go to 40
!
!     if there is loss of accuracy not due to underflow
!     then set j = number of digits possibly lost due to
!     this loss of accuracy.
!
   50 call store2 (x, q*x)
  if (t*d2 /= t*x) go to 60
   51    z = x
     j = j + 1
     x = (x*binv)*one
     call store2 (x, x)
     if (x + x /= zero .and. abs(x) < z) go to 51

   60 minexp = 1 - k
!
!     define an initial approximation for maxexp and xmax
!     when maxexp <= 0 on input
!
  if (maxexp > 0) go to 71
  if (ibeta == 2 .or. ibeta == 8 .or. &
      ibeta == 16) go to 70

     maxexp = k - 3
     if (n > 0) write (n,200) maxexp
     t = one/(b2*b2*xmin)
     xmax = (xmax*t)*b
     go to 80

   70 k = k + j
  if (k + k > km + 2) km = km + km
  maxexp = km - k - 3
   71 if (n > 0) write (n,200) maxexp
  t = b**(maxexp - 1)
  xmax = (xmax*t)*b
!
!     check the approximation for maxexp
!
   80 call store2 (t, t*p)
  if (d1 == d2) go to 100
  if (n <= 0) return
!
!     loop to find the exact largest value for maxexp
!
  write (n,210) maxexp
  do 90 l = 1,500
     t = t*b
     xmax = xmax*b
     maxexp = maxexp + 1
     call store2 (t, t*p)
     if (d1 == d2) go to 100
     write (n,220) maxexp
   90 continue
  write (n,240)
  stop
!
!     reporting overflow on unit n
!
  100 if (n > 0) write (n,230)
  stop
!
!     format statements
!
  200 format (50h the initial approximation for imax (or maxexp) is// &
          i25// &
          47h if no further information appears on this file/ &
          50h then set imax (or maxexp) to a smaller value than/ &
          39h this approximation and rerun the code.//)
  210 format (51h the loop to find the largest possible exponent has/ &
          48h begun. set imax (or maxexp) to the last integer/ &
          14h that follows.//i25)
  220 format (i25)
  230 format(/'   ****** overflow occurs ******')
  240 format(/46h ****** 500 passes were made through the loop./ &
          45h        the maximum exponent cannot be found./ &
          43h        if one wishes, set imax (or maxexp)/ &
          45h        to a larger value and rerun the code./)

end
subroutine mach2 (n, ibeta, m, minexp, maxexp, eps, xint, &
                    xmin, xmax)
!
!*******************************************************************************
!
!! MACH2 computes double precision environment constants.
!
!
!                 computation of the environmental constants
!             for the double precision floating point arithmetic
!
!                            -----------
!
!     input ...
!
!       n       - if n is positive then n is the number of an
!                 output unit. in this case it is assumed that
!                 any information that is written on the unit
!                 will be available to the user if the routine
!                 terminates because of overflow. unit n is
!                 used only for computing the exact maximum
!                 base ibeta exponent for the floating point
!                 numbers (this exponent is stored in maxexp).
!                 if the exact maximum exponent is not needed
!                 (or has already been obtained) then set n
!                 to 0 or a negative value.
!
!       ibeta   - the base of the floating point arithmetic.
!
!       minexp  - if minexp is negative then minexp is assumed
!                 to be the minimum (base ibeta) exponent for
!                 the floating point numbers. otherwise, if
!                 minexp >= 0, then the minimum exponent is
!                 computed.
!
!       maxexp  - if maxexp is positive then maxexp is assumed to
!                 be an approximation of the maximum (base ibeta)
!                 exponent for the floating point numbers. other-
!                 wise, if maxexp <= 0, then an approximation
!                 for the maximum exponent is obtained.
!
!     output ...
!
!       m       - the number of base ibeta digits in the floating
!                 point representation.
!
!       minexp  - let b = dble(real(ibeta)). then minexp is the
!                 largest in magnitude negative integer such that
!                 b**(minexp - 1) is a positive number. (if minexp
!                 is negative on input then minexp may be altered.)
!
!       maxexp  - if maxexp is positive on input and n <= 0
!                 then maxexp is not modified.
!
!                 if maxexp <= 0 on input and n <= 0 then
!                 on output maxexp = an approximation of the
!                 maximum (base ibeta) exponent for the floating
!                 point numbers.
!
!                 if n is positive then the routine searches for
!                 the exact maximum exponent for the floating
!                 point numbers. if maxexp is positive on input
!                 then the search begins with maxexp. if
!                 maxexp <= 0 on input then the routine begins
!                 the search with its own initial approximation
!                 for maxexp. the following loop is performed.
!                     (1) check the current value of maxexp
!                         for overflow. if overflow occurs
!                         then the routine will (hopefully)
!                         abort. otherwise, if overflow does
!                         not occur then go to (2).
!                     (2) write on unit n the current value
!                         of maxexp and go to (3).
!                     (3) increase the value of maxexp by 1
!                         and return to (1).
!                 if the overflow test in (1) fails then the
!                 routine aborts after 500 passes through the
!                 loop. if the overflow test works properly
!                 then the last integer written on unit n is
!                 the desired maximum exponent for the float-
!                 ing point numbers. reset maxexp to this
!                 integer, set n = 0, and rerun the routine.
!
!       eps     - the relative precision of the floating arithmetic.
!                 eps = b**(1 - m) where b = dble(real(ibeta)).
!
!       xint    - the largest positive integer that can
!                 be exactly represented as a floating
!                 point number. xint = b**m - 1  where
!                 b = dble(real(ibeta)).
!
!       xmin    - the smallest nonzero power of the base.
!                 xmin = b**(minexp-1) where b=dble(real(ibeta)).
!
!       xmax    - the largest foating point number that can
!                 be obtained having the exponent maxexp.
!                 xmax = (1 - b**(-m)) * b**maxexp  where
!                 b = dble(real(ibeta)). if maxexp is the
!                 maximum exponent for the floating point
!                 numbers then xmax is the largest floating
!                 point number that exists. the value
!                 obtained for xmax may be affected slightly
!                 by roundoff error.
!
  double precision eps, xint, xmin, xmax
  double precision b,b2, binv, bm1, d1, d2, one, p, q, t, x, z, zero
!
  common /dpdata/ d1, d2
!
  zero = dble(real(0))
  one = dble(real(1))
  b = dble(real(ibeta))
  b2 = b*b
  bm1 = dble(real(ibeta - 1))
  binv = one/b
!
!     compute m and eps
!
  m = 1
  t = b
   10    m = m + 1
     z = t
     t = b*t
     call dstor2 (t + one, t)
     x = d1*binv - z
     if (x == binv) go to 10

  eps = one/z
  xint = (z - one)*b + bm1
  xmax = xint/t
!
!     compute minexp and xmin
!
  p = one + eps
  q = one + eps*b2
  if (minexp >= 0) go to 30
!
!     minexp has been given. check the value of minexp
!     and modify it (if necessary).
!
  minexp = minexp - 1
  do 15 k = 1,m
     minexp = minexp + 1
     xmin = b**(minexp + 2)
     xmin = ((xmin * binv) * binv) * binv
     xmin = xmin * one
     if (xmin + xmin /= zero) go to 20
   15 continue
!
!     obtain k, km, and j.
!
   20 k = 1 - minexp
  km = 1
   21    km = km + km
     if (km < k) go to 21
  if (km == k) km = k + k

  j = 0
  x = (xmin*binv)*one
  call dstor2 (x, q*x)
  if (x + x == zero .or. dabs(x) >= xmin) go to 60
  if (t*d2 /= t*x) go to 60
  go to 51
!
!     minexp must be found. this loop obtains the largest
!     k = 2**i such that b**(-k) does not underflow.
!
   30 k = 1
  z = binv
   31    x = z
     z = (x*x)*one
     call dstor2 (z, p*z)
     if (z + z == zero .or. dabs(z) >= x) go to 32
     if (t*d2 == t*z) go to 32
     k = k + k
     go to 31
   32 km = k + k
  j = 0
!
!     loop to determine minexp and xmin
!
   40    xmin = x
     x = (x*binv)*one
     call dstor2 (x, p*x)
     if (x + x == zero .or. dabs(x) >= xmin) go to 60
     if (t*d2 == t*x) go to 50
     k = k + 1
     go to 40
!
!     if there is loss of accuracy not due to underflow
!     then set j = number of digits possibly lost due to
!     this loss of accuracy.
!
   50 call dstor2 (x, q*x)
  if (t*d2 /= t*x) go to 60
   51    z = x
     j = j + 1
     x = (x*binv)*one
     call dstor2 (x, x)
     if (x + x /= zero .and. dabs(x) < z) go to 51
!
   60 minexp = 1 - k
!
!     define an initial approximation for maxexp and xmin
!     when maxexp <= 0 on input
!
  if (maxexp > 0) go to 71
  if (ibeta == 2 .or. ibeta == 8 .or. &
      ibeta == 16) go to 70

     maxexp = k - 3
     if (n > 0) write (n,200) maxexp
     t = one/(b2*b2*xmin)
     xmax = (xmax*t)*b
     go to 80

   70 k = k + j
  if (k + k > km + 2) km = km + km
  maxexp = km - k - 3
   71 if (n > 0) write (n,200) maxexp
  t = b**(maxexp - 1)
  xmax = (xmax*t)*b
!
!     check the approximation for maxexp
!
   80 call dstor2 (t, t*p)
  if (d1 == d2) go to 100
  if (n <= 0) return
!
!     loop to find the exact largest value for maxexp
!
  write (n,210) maxexp
  do 90 l = 1,500
     t = t*b
     xmax = xmax*b
     maxexp = maxexp + 1
     call dstor2 (t, t*p)
     if (d1 == d2) go to 100
     write (n,220) maxexp
   90 continue
  write (n,240)
  stop
!
!     reporting overflow on unit n
!
  100 if (n > 0) write (n,230)
  stop

!     format statements
!
  200 format (51h the initial approximation for idmax (or maxexp) is// &
          i25// &
          47h if no further information appears on this file/ &
          51h then set idmax (or maxexp) to a smaller value than/ &
          39h this approximation and rerun the code.//)
  210 format (51h the loop to find the largest possible exponent has/ &
          49h begun. set idmax (or maxexp) to the last integer/ &
          14h that follows.//i25)
  220 format (i25)
  230 format (32h0  ****** overflow occurs ******)
  240 format(/46h ****** 500 passes were made through the loop./ &
          45h        the maximum exponent cannot be found./ &
          44h        if one wishes, set idmax (or maxexp)/ &
          45h        to a larger value and rerun the code./)
end
subroutine madd ( m, n, a, ka, b, kb, c, kc )
!
!*******************************************************************************
!
!! MADD computes the sum of two real matrices.
!
!
!  Modified:
!
!    19 May 2001
!
!  Parameters:
!
  real a(ka,n)
  real b(kb,n)
  real c(kc,n)
!
  c(1:m,1:n) = a(1:m,1:n) + b(1:m,1:n)

  return
end
subroutine mc13d(n, icn, licn, ip, lenr, ior, ib, num, iw)
!
!*******************************************************************************
!
!! MC13D: ???
!
!
!  Parameters:
!
! input variables  .... n,icn,licn,ip,lenr.
! output variables  ior,ib,num.
!
! n   order of the matrix.
! icn array containing the column indices of the non-zeros.  those
!     belonging to a single row must be contiguous but the ordering
!     of column indices within each row is unimportant and wasted
!     space between rows is permitted.
! licn  length of array icn.
! ip  ip(i), i=1,2,...n, is the position in array icn of the first
!     column index of a non-zero in row i.
! lenr  lenr(i) is the number of non-zeros in row i, i=1,2,...n.
! ior  ior(i) gives the position in the original ordering of the row
!     or column which is in position i in the permuted form, i=1,2,..n.
! ib  ib(i) is the row number in the permuted matrix of the beginning
!     of block i, i=1,2,...num.
! num number of blocks found.
! iw  work array .. see later comments.
!
  integer ip(n)
  integer icn(licn), lenr(n), ior(n), ib(n), iw(n,*)
  call mc13e(n, icn, licn, ip, lenr, ior, ib, num, iw(1,1), &
    iw(1,2), iw(1,3))
  return
end
subroutine mc13e(n, icn, licn, ip, lenr, arp, ib, num, lowl, &
    numb, prev)
!
!*******************************************************************************
!
!! MC31E ???
!
!
! arp(i) is one less than the number of unsearched edges leaving
!     node i.  at the end of the algorithm it is set to a
!     permutation which puts the matrix in block lower
!     triangular form.
! ib(i) is the position in the ordering of the start of the ith
!     block.  ib(n+1-i) holds the node number of the ith node
!     on the stack.
! lowl(i) is the smallest stack position of any node to which a path
!     from node i has been found.  it is set to n+1 when node i
!     is removed from the stack.
! numb(i) is the position of node i in the stack if it is on
!     it, is the permuted order of node i for those nodes
!     whose final position has been found and is otherwise zero.
! prev(i) is the node at the end of the path when node i was
!     placed on the stack.
!
  integer stp, dummy
  integer ip(n)
  integer icn(licn), lenr(n), arp(n), ib(n), lowl(n), numb(n), &
    prev(n)
!
!
!   icnt is the number of nodes whose positions in final ordering have
!     been found.
  icnt = 0
! num is the number of blocks that have been found.
  num = 0
  nnm1 = n + n - 1
!
! initialization of arrays.
  do 10 j=1,n
    numb(j) = 0
    arp(j) = lenr(j) - 1
   10 continue
!
!
  do 90 isn=1,n
! look for a starting node
    if (numb(isn)/=0) go to 90
    iv = isn
! ist is the number of nodes on the stack ... it is the stack pointer.
    ist = 1
! put node iv at beginning of stack.
    lowl(iv) = 1
    numb(iv) = 1
    ib(n) = iv
!
! the body of this loop puts a new node on the stack or backtracks.
    do 80 dummy=1,nnm1
      i1 = arp(iv)
! have all edges leaving node iv been searched.
      if (i1 < 0) go to 30
      i2 = ip(iv) + lenr(iv) - 1
      i1 = i2 - i1
!
! look at edges leaving node iv until one enters a new node or
!     all edges are exhausted.
      do 20 ii=i1,i2
        iw = icn(ii)
! has node iw been on stack already.
        if (numb(iw)==0) go to 70
! update value of lowl(iv) if necessary.
        if (lowl(iw) < lowl(iv)) lowl(iv) = lowl(iw)
   20     continue
!
! there are no more edges leaving node iv.
      arp(iv) = -1
! is node iv the root of a block.
   30     if (lowl(iv) < numb(iv)) go to 60
!
! order nodes in a block.
      num = num + 1
      ist1 = n + 1 - ist
      lcnt = icnt + 1
! peel block off the top of the stack starting at the top and
!     working down to the root of the block.
      do 40 stp=ist1,n
        iw = ib(stp)
        lowl(iw) = n + 1
        icnt = icnt + 1
        numb(iw) = icnt
        if (iw==iv) go to 50
   40     continue
   50     ist = n - stp
      ib(num) = lcnt
! are there any nodes left on the stack.
      if (ist/=0) go to 60
! have all the nodes been ordered.
      if (icnt < n) go to 90
      go to 100
!
! backtrack to previous node on path.
   60     iw = iv
      iv = prev(iv)
! update value of lowl(iv) if necessary.
      if (lowl(iw) < lowl(iv)) lowl(iv) = lowl(iw)
      go to 80
!
! put new node on the stack.
   70     arp(iv) = i2 - ii - 1
      prev(iw) = iv
      iv = iw
      ist = ist + 1
      lowl(iv) = ist
      numb(iv) = ist
      k = n + 1 - ist
      ib(k) = iv
   80   continue
!
   90 continue
!
!
! put permutation in the required form.
  100 do 110 i=1,n
    ii = numb(i)
    arp(ii) = i
  110 continue
  return
end
subroutine mc21a (n,icn,licn,ip,lenr,iperm,numnz,iw)
!
!*******************************************************************************
!
!! MC21A ???
!
!
! description of parameters.
! input variables   n,icn,licn,ip,lenr
! output variables  iperm,numnz
!
! n   order of matrix.
! icn array containing the column indices of the non-zeros.  those
!     belonging to a single row must be contiguous but the ordering
!     of column indices within each row is unimportant and wasted
!     space between rows is permitted.
! licn  length of array icn.
! ip  ip(i), i=1,2,...n, is the position in array icn of the first
!     column index of a non-zero in row i.
! lenr  lenr(i) is the number of non-zeros in row i, i=1,2,..n.
! iperm contains permutation to make diagonal have the smallest
!     number of zeros on it.  elements (iperm(i),i) i=1, ... n are
!     non-zero at the end of the algorithm unless matrix
!     is structurally singular.  in this case, (iperm(i),i) will
!     be zero for n-numnz entries.
! numnz number of non-zeros on diagonal of permuted matrix.
! iw  work array  ..  see later comments.
!
  integer ip(n)
  integer icn(licn), lenr(n), iperm(n), iw(n,4)
!
  call mc21b (n,icn,licn,ip,lenr,iperm,numnz,iw(1,1),iw(1,2), &
              iw(1,3),iw(1,4))
  return
end
subroutine mc21b (n,icn,licn,ip,lenr,iperm,numnz,pr,arp,cv,out)
!
!*******************************************************************************
!
!! MC21B ???
!
!
!     division of work array is now described.
!
! pr(i) is the previous row to i in the depth first search.
! arp(i) is one less than the number of non-zeros in row i
!     which have not been scanned when looking for a cheap assignment.
! cv(i) is the most recent row extension at which column i
!     was visited.
! out(i) is one less than the number of non-zeros in row i
!     which have not been scanned during one pass through the
!     main loop.
!
  integer ip(n), icn(licn), lenr(n), iperm(n), pr(n), cv(n), &
          arp(n), out(n)
!
!     initialization of arrays
!
  do 10 i = 1,n
     arp(i) = lenr(i) - 1
     cv(i) = 0
     iperm(i) = 0
   10 continue
  numnz = 0
!
!     main loop.
!     each pass round this loop either results in a new assignment
!     or gives a row with no assignment.
!
  do 130 jord = 1,n
  j = jord
  pr(j) = -1
  do 100 k = 1,jord
!
!     look for a cheap assignment
!
  in1 = arp(j)
  if (in1 < 0) go to 60
  in2 = ip(j) + lenr(j) - 1
  in1 = in2 - in1
  do 50 ii = in1,in2
     i = icn(ii)
     if (iperm(i) == 0) go to 110
   50 continue
!
!     no cheap assignment in row
!
  arp(j) = -1
!
!     begin looking for assignment chain starting with row j
!
   60 out(j) = lenr(j) - 1
!
!     inner loop.  extends chain by one or backtracks.
!
  do 90 kk = 1,jord
     in1 = out(j)
     if (in1 < 0) go to 80
     in2 = ip(j) + lenr(j) - 1
     in1 = in2 - in1
!
!        forward scan
!
     do 70 ii = in1,in2
        i = icn(ii)
        if (cv(i) == jord) go to 70
!
!           column i has not yet been accessed during this pass
!
        j1 = j
        j = iperm(i)
        cv(i) = jord
        pr(j) = j1
        out(j1) = in2 - ii - 1
        go to 100
   70    continue
!
!        backtracking step
!
   80    j = pr(j)
     if (j == -1) go to 130
   90 continue
!
  100 continue
!
!     new assignment is made
!
  110 iperm(i) = j
  arp(j) = in2 - ii - 1
  numnz = numnz + 1
  do 120 k = 1,jord
     j = pr(j)
     if (j == -1) go to 130
     ii = ip(j) + lenr(j) - out(j) - 2
     i = icn(ii)
     iperm(i) = j
  120 continue
!
  130 continue
!
!     if matrix is structurally singular, we now complete the
!     permutation iperm.
!
  if (numnz == n) go to 500
  do 140 i = 1,n
     arp(i) = 0
  140 continue
  k = 0
  do 160 i = 1,n
     if (iperm(i) /= 0) go to 150
        k = k + 1
        out(k) = i
        go to 160
  150    j = iperm(i)
     arp(j) = i
  160 continue
  k = 0
  do 170 i = 1,n
     if (arp(i) /= 0) go to 170
     k = k + 1
     ioutk = out(k)
     iperm(ioutk) = i
  170 continue
  500 return
end
subroutine mcopy(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! MCOPY copies a real matrix.
!
  real a(ka,n),b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = a(i,j)
   20 continue
  return
end
subroutine mcvbs(a,ka,m,n,ml,mu,b,ib,jb,num,ierr)
!
!*******************************************************************************
!
!! MCVBS: conversion of real matrices from banded to sparse form
!
  real a(ka,*), b(*)
  integer ib(*), jb(*)
!
  kdim = ml + mu + 1
  l = 1
  nu = ml + 1
!
!     store the nonzero data of the first ml rows
!
  if (ml == 0) go to 20
  do 11 i = 1,ml
  ib(i) = l
  nu = nu - 1
  kmin = 1 + nu
  kmax = min (kdim,n+nu)
     do 10 k = kmin,kmax
     if (a(i,k) == 0.0) go to 10
     if (l > num) go to 40
        b(l) = a(i,k)
        jb(l) = k - nu
        l = l + 1
   10    continue
   11 continue
!
!     store the remaining nonzero data
!
   20 imin = ml + 1
  imax = min (m,ml+n)
  do 22 i = imin,imax
  ib(i) = l
  nu = nu - 1
  kmax = min (kdim,n+nu)
     do 21 k = 1,kmax
     if (a(i,k) == 0.0) go to 21
     if (l > num) go to 40
        b(l) = a(i,k)
        jb(l) = k - nu
        l = l + 1
   21    continue
   22 continue
!
!     set up the remaining m-imax rows
!
  ierr = 0
  ibeg = imax + 1
  mp1 = m + 1
  do 30 i = ibeg,mp1
   30 ib(i) = l
  return
!
!     error return
!
   40 ierr = i
  return
end
subroutine mcvdr(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! MCVDR copies a double precision matrix into a real matrix.
!
  double precision a(ka,n)
  real b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = a(i,j)
   20 continue
  return
end
subroutine mcvfs(a,ka,n,b)
!
!*******************************************************************************
!
!! MCVFS ???
!
  real a(ka,n),b(*)
!
  l = 0
  do 20 j = 1,n
     do 10 i = 1,j
     l = l + 1
   10    b(l) = a(i,j)
   20 continue
  return
end
subroutine mcvrc(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! MCVRC copies a real matrix into the real part of a complex matrix.
!
  real a(ka,n)
  complex b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = cmplx(a(i,j),0.0)
   20 continue
  return
end
subroutine mcvrd(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! MCVRD copies a real matrix into a double precision matrix.
!
  real a(ka,n)
  double precision b(kb,n)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(i,j) = a(i,j)
   20 continue
  return
end
subroutine mcvsb(a,ia,ja,m,n,b,kb,nb,ml,mu,ierr)
!
!*******************************************************************************
!
!! MCVSB: conversion of real matrices from sparse to banded form
!
  real a(*), b(kb,nb)
  integer ia(*), ja(*)
!
!     computation of ml and mu
!
  ml = 0
  mu = 0
  do 11 i = 1,m
  lmin = ia(i)
  lmax = ia(i+1) - 1
  if (lmin > lmax) go to 11
     do 10 l = lmin,lmax
     if (a(l) == 0.0) go to 10
        k = ja(l) - i
        mu = max (mu, k)
        ml = max (ml,-k)
   10    continue
   11 continue
!
!     set b = 0 if b provides sufficient storage
!
  kmax = ml + mu + 1
  if (kmax > nb) go to 40
!
  ierr = 0
  do 21 k = 1,kmax
     do 20 i = 1,m
   20    b(i,k) = 0.0
   21 continue
!
!     store the matrix in b
!
  nu = ml + 1
  do 31 i = 1,m
  nu = nu - 1
  lmin = ia(i)
  lmax = ia(i+1) - 1
  if (lmin > lmax) go to 31
     do 30 l = lmin,lmax
     if (a(l) == 0.0) go to 30
        k = ja(l) + nu
        b(i,k) = a(l)
   30    continue
   31 continue
  return
!
!     error return
!
   40 ierr = kmax
  return
end
subroutine mcvsf(a,ka,n,b)
!
!*******************************************************************************
!
!! MCVSF ???
!
  real a(ka,n),b(*)
!
  a(1,1) = b(1)
  if (n < 2) return
  l = (n*(n + 1))/2
!
  j = n
  do 11 jj = 2,n
  i = j
     do 10 ii = 1,j
     a(i,j) = b(l)
     i = i - 1
   10    l = l - 1
   11 j = j - 1
!
  do 21 i = 2,n
  im1 = i - 1
     do 20 j = 1,im1
   20    a(i,j) = a(j,i)
   21 continue
  return
end
subroutine meval(dimen,evldeg,nepols,nepts,evlcds,nerows,evlvls, &
                   error,fitiwk,fitdwk,fiwkln,fdwkln,temp)
!
!*******************************************************************************
!
!! MEVAL evaluates the least-squares multinomial fit produced by mfit.
!
!
!   either the full multinomial as produced may be evaluated, or only an initial
!     segment thereof.  as in the case with  mfit , it is possible
!     (1) to specify multinomials of a full given degree, or
!     (2) to specify  the  number  of  orthogonal  basis  elements  to
!         achieve a partial-degree fit.
!
!     in case (1), the  desired  degree  is  given  as  the  value  of
!     evldeg   (which  must  be  nonnegative and not greater than the
!     value used for  fitdeg  in  mfit ), and the parameter  nepols
!     will  be  set  by  meval  to specify the number of basis elements
!     required. if  evldeg  <  fitdeg   is  given,  then  only  the
!     initial  portion of the fitting multinomial (of degree  evldeg )
!     will be evaluated.
!
!     in case (2),  evldeg  is to be set negative, in which  case  the
!     value  of   nepols  (which must be positive and not greater than
!     the value used for   nfpols   in   mfit )  will  be  taken  as
!     defining  the  initial  portion of the fitting multinomial to be
!     evaluated.
!
!     if  nepols  =  nfpols  (with  evldeg  <  0),  or   evldeg   =
!     fitdeg  (with   evldeg   >  0),  then  the  full  multinomial
!     generated by  mfit  will be evaluated.
!
!     the  evaluation  will  take  place  for  each  of   the   points
!     (collection  of  variable  values)  given as a row of the matrix
!      evlcds .  the  values  produced  from  the  full,  or  partial,
!     multinomial will be placed in the array  evlvls .
!
!     variables
!
!
!      dimen  -- (integer) -- (passed)
!         the number of variables.
!      evldeg  -- (integer) -- (passed)
!         if  evldeg  < 0, then this parameter will be ignored.
!         if  evldeg  >= 0, then the value of  evldeg  must  satisfy
!         evldeg  <= (the  degree  of the approximating multinomial
!         generated in  mfit ).  in this case  evldeg  will  specify
!         the degree of the initial portion of the fitting multinomial
!         to be evaluated.
!      nepols  -- (integer) -- (passed/returned)
!         if  evldeg  >= 0, then this parameter will be ignored.
!         if evldeg < 0, then the partial multinomial involving the
!         first   nepols  orthogonal basis functions will be evaluated
!         at the points given by  evlcds .  the resulting values  will
!         be stored in  evlvls .
!         the value of nepols must be >= 1 and <= (the size of the
!         basis  generated  in   mfit ),  which  was returned as the
!         value of  nfpols .
!         nepols  will be changed if evldeg > 0 to give the size of
!         basis required for the multinomial of degree  evldeg .
!      nepts  -- (integer) -- (passed)
!         the number of evaluation points.
!      evlcds  -- (real 2-subscript array) -- (passed)
!         evlcds (p,k) is the value of the k-th variable at the  p-th
!         evaluation point.
!      nerows  -- (integer) -- (passed)
!         the row dimension declared for evlcds in the calling program.
!      evlvls  -- (integer) -- (returned)
!         evlvls (p) is the value of the evaluated multinomial at the
!         p-th evaluation point.
!      error  -- (integer) -- (returned)
!          0 .........  if no errors
!         -1 .........  if  nepols  >  nfpols  or  nepols  < 1
!         -2 .........  if  nepts  < 1 or  dimen   <  1
!      fitiwk  -- (integer, 1-subscript array) -- (passed)
!         the integer work array of length  fiwkln  that was  used  in
!          mfit .
!      fitdwk  -- (real 2-subscript array) -- (passed)
!         the real work array of length  fdwkln  that was
!         used in  mfit .
!      fiwkln  -- (integer) -- (passed)
!         the length of  fitiwk .
!      fdwkln  -- (integer) -- (passed)
!         the length of  fitdwk .
!      temp    -- (real 1-subscript array)
!         a work array of length  dimen  (or longer).
!
!     the subroutine  meval1  is called to do the actual evaluation.
!
!     modified by a.h. morris (nswc)
!
!
!     set up index pointers to the beginning of each row of
!     the mtable -- this sets the beginning point for each
!     full multinomial degree.
!
  integer fiwkln,fdwkln,nepols,nepts,dimen,error,maxstt,alfstt,cstt
  integer gbasiz,alfl,dimp1,evldeg,top,bot,curdeg,psistt
  integer fitiwk(fiwkln)
  real    fitdwk(fdwkln),evlcds(nerows,dimen)
  real    evlvls(nepts),temp(dimen)
!
!
  if (nepts < 1 .or. dimen  <  1) go to 110
  if (evldeg) 40,10,20
!
   10 nepols = 1
  go to 50
!
   20 top = 1
  bot = 1
  do 30 curdeg = 1,evldeg
     top = top * (dimen + curdeg)
   30    bot = bot * curdeg
  nepols = top / bot
!
   40 gbasiz = fitiwk(1)
  if (nepols > gbasiz .or. nepols < 1) go to 100
!
   50 error = 0
  dimp1 = dimen + 1
  alfl = fitiwk(4)
  maxstt = 1
  alfstt = dimp1 + maxstt
  cstt = alfstt + alfl
  psistt = cstt + fitiwk(2)
!
!
!     the actual evaluation is done inside  meval1.
!
!
  call meval1 (evlcds,nerows,fitdwk(cstt),nepts,dimen,nepols, &
               fitdwk(alfstt),fitiwk,fitdwk(psistt), &
               evlvls,alfl,fitdwk(maxstt),temp,dimp1)
  return
!
!
!     error return
!
!
  100 error = -1
  return
  110 error = -2
  return
end
subroutine meval1 (coord,ncrows,c,nepts,dimen,npolys,alpha, &
                     indexs,psi,f,alfl,maxabs,x,dimp1)
!
!*******************************************************************************
!
!! MEVAL1 performs the main work of evaluating the fitting multinomial
!  (or the initial portion of it  which
!     is requested by the setting of  nepols ,  evldeg  in the
!     call to subroutine  meval .
!
!     this subroutine is called by  meval .  it is  not  called
!     directly by the user.
!
!     the body of this subroutine follows the explanation
!     given in
!          least squares fitting using
!          orthogonal multinomials
!     by
!          bartels and jezioranski
!     in
!          acm transactions on mathematical software
!
!
!     modified by a.h. morris (nswc)
!
  integer dimen,nepts,npolys,alfl,dimp1
  integer jm1,jprime,m,p,k,i,j,index
  integer indexs(4,npolys)
  real    alpha(alfl),coord(ncrows,dimen),psi(npolys)
  real    c(npolys),f(nepts),maxabs(dimp1),x(dimen)
  real    runtot,rntot1
!
  if (npolys == 1) go to 50
!
  psi(1) = 1.0
  do 40 p = 1,nepts
!
!     scale the coordinates of the p-th point
!
     do 10 k = 1,dimen
          x(k) = coord(p,k)
          if (maxabs(k) /= 0.0) x(k) = x(k) / maxabs(k)
 10      continue
!
!     use the  basis function coefficients  c  and recurrence
!     coefficients  alpha  to evaluate the fitted multinomial
!     at the p-th point.
!
     rntot1 = c(1)
     do 30 j = 2,npolys
          k = indexs(2,j)
          jprime = indexs(1,j)
          runtot = x(k) * psi(jprime)
          i = indexs(3,j)
          jm1 = j - 1
          do 20 m = i,jm1
             index = indexs(4,j) + m - i
 20              runtot = runtot - psi(m) * alpha(index)
          psi(j) = runtot
 30           rntot1 = rntot1 + c(j) * psi(j)
 40       f(p) = rntot1 * maxabs(dimp1)
  return
!
!     compute the degree 0 polynomial
!
 50   runtot = c(1) * maxabs(dimp1)

  f(1:nepts) = runtot

  return
end
subroutine mexp ( a, lda, n, z, ierr )
!
!*******************************************************************************
!
!! MEXP computes the matrix exponential.
!
!
!  Author:
!
!    Alfred Morris,
!    Naval Surface Weapons Center,
!    Dahlgren, Virginia.
!
!  Parameters:
!
!    Input/output, real A(LDA,N), the N by N matrix.  On output, A has
!    been overwritten.
!
!    Input, integer LDA, the leading dimension of A, which must be at least N.
!
!    Input, integer N, the order of the matrix.
!
!    Output, real Z(LDA,N), the N by N matrix exponential.
!
!    Output, integer IERR, an error flag.
!    0, the matrix exponential was successfully computed.
!    1, the norm of A is too large.
!    2, the Pade denominator matrix is singular.
!
  integer lda
  integer n
!
  real a(lda,n)
  real anorm
  real anorm1
  real c(8)
  real factor
  integer i
  integer ierr
  integer igh
  integer j
  integer k
  integer l
  integer ll
  integer low
  integer m
  real p
  real q
  real s
  real wk(n,n+8)
  real z(lda,n)
!
!     coefficients for (8,8) pade table entry
!
  data c(1)/.500000000000000e+00/, c(2)/.116666666666667e+00/, &
       c(3)/.166666666666667e-01/, c(4)/.160256410256410e-02/, &
       c(5)/.106837606837607e-03/, c(6)/.485625485625486e-05/, &
       c(7)/.138750138750139e-06/, c(8)/.192708526041859e-08/
!
  ierr = 0

  if ( n < 1 ) then
    return
  end if

  if ( n == 1 ) then
    z(1,1) = exp ( a(1,1) )
    return
  end if
!
!  Balance the matrix.
!
  call balanc ( lda, n, a, low, igh, wk(1,n+8) )
!
!  Select the smaller of the 1-norm and infinity-norm.
!
  anorm = 0.0E+00
  do i = 1, n
    anorm = max ( anorm, sum ( abs ( a(i,1:n) ) ) )
  end do

  anorm1 = 0.0E+00
  do j = 1, n
    anorm1 = max ( anorm, sum ( abs ( a(1:n,j) ) ) )
  end do

  anorm = min ( anorm, anorm1 )

  s = anorm + 0.1E+00

  if ( s == anorm ) then
    ierr = 1
    return
  end if
!
!  Select the normalization factor
!
  m = 0

  if ( anorm > 1.0E+00 ) then

    factor = 2.0E+00
    m = 1

    do while ( anorm > factor )
      m = m + 1
      factor = 2.0E+00 * factor
    end do

    a(1:n,1:n) = a(1:n,1:n) / factor

  end if

  do j = 1, n
!
!  Compute the j-th column of first eight powers of a
!
     wk(1:n,n+1) = matmul ( a(1:n,1:n), a(1:n,j) )

     do k = n+1, n+6
       do i = 1, n
         s = 0.0E+00
         do l = 1,n
           s = s + a(i,l) * wk(l,k)
         end do
       wk(i,k+1) = s
       end do
     end do
!
!  Compute the j-th column of the numerator and denominator
!  of the pade approximation
!
     do i = 1, n

       p = 0.0E+00
       q = 0.0E+00
       k = 8
       l = n + 7
       do ll = 1, 7
         s = c(k) * wk(i,l)
         p = s + p
         q = s - q
         k = k - 1
         l = l - 1
       end do

       s = c(1) * a(i,j)
       z(i,j) = p + s
       wk(i,j) = q - s

       if ( i == j ) then
         z(i,j) = z(i,j) + 1.0E+00
         wk(i,j) = wk(i,j) + 1.0E+00
       end if

     end do

  end do
!
!  Calculate exp(a) by solving  wk * exp(a) = z
!
  call slv ( n, n, wk, n, z, lda, ierr )

  if ( ierr /= 0 ) then
    ierr = 2
    return
  end if
!
!  Take out the effect of the normalization operation on exp(a)
!
  do k = 1,m

    z(1:n,1:n) = matmul ( z(1:n,1:n), z(1:n,1:n) )

  end do
!
!  Take out the effect of the balancing operation on exp(a)
!
  call balinv ( lda, n, z, low, igh, wk(1,n+8) )

  return
end
subroutine mfft (c,n,ndim,isn,ierr)
!
!*******************************************************************************
!
!! MFFT: ???
!
!
!     let ntot denote the product of n(1),...,n(ndim). the complex
!     array c of dimension ntot is interpreted by the routine as
!     a real array of dimension 2*ntot. if this association is not
!     permitted by the fortran being used, then the user may use
!     the subroutine mfft1.
!
  real c(*)
  integer n(ndim)
  !
  if (iabs(isn) /= 1) go to 40
  if (ndim <= 0) go to 50
  ntot = 1
  do i = 1,ndim
     ntot = n(i)*ntot
  end do
  if (ntot < 1) go to 30

  isign = isn + isn
  nspan = 1
  do 20 i = 1,ndim
     nspan = n(i)*nspan
     call sfft (c(1),c(2),ntot,n(i),nspan,isign,ierr)
     if (ierr /= 0) return
   20 continue
  return
!
   30 ierr = 1
  return
   40 ierr = 4
  return
   50 ierr = 5
  return
end
subroutine mfft1 (a,b,n,ndim,isn,ierr)
!
!*******************************************************************************
!
!! MFFT1 ???
!
  real a(*), b(*)
  integer n(ndim)
!
  if (iabs(isn) /= 1) go to 40
  if (ndim <= 0) go to 50
  ntot = 1
  do 10 i = 1,ndim
     ntot = n(i)*ntot
   10 continue
  if (ntot < 1) go to 30
!
  nspan = 1
  do 20 i = 1,ndim
     nspan = n(i)*nspan
     call sfft (a,b,ntot,n(i),nspan,isn,ierr)
     if (ierr /= 0) return
   20 continue
  return
!
   30 ierr = 1
  return
   40 ierr = 4
  return
   50 ierr = 5
  return
end
subroutine mfit(dimen,fitdeg,nfpols,nfpts, &
                  fitcds,ncrows,fitvls,wts, &
                  resids,error,fitiwk,fitdwk, &
                  fiwkln,fdwkln,ireqd,dreqd)
!
!*******************************************************************************
!
!! MFIT constructs a least-squares orthogonal multinomial fit to data.
!
!
!     the data for the fit is given in the arrays fitcds, fitvls, and
!     wts. fitcds is a matrix, each row of which contains an observa-
!     tion point. fitvls is a singly-indexed array, each element of
!     which contains a function value corresponding to an observation
!     point. wts is a singly-indexed array, each element of which is
!     a nonnegative weight for the corresponding observation.
!
!     the fit which is produced is a multinomial expressed in the form
!
!      c  psi  (x ,...,x     ) +...+ c       psi       (x ,...,x     )
!       1    1   1      dimen         nfpols    nfpols   1      dimen
!
!     where the value of  nfpols  will be as given (if  fitdeg < 0)
!     or  as  computed  by  mfit  to give a full-degree fit (in case
!     fitdeg  is specified >= 0).  the elements
!
!         psi  (x ,...,x     )
!            k   1      dimen
!
!     form a basis for the multinomials which is orthogonal with
!     respect to the weights and observation points.
!
!     the extent of the fit can be specified in one of two ways.
!         if the parameter fitdeg is set >= 0, then a complete basis
!         for the multinomials of degree =  fitdeg  will be used.  (an
!         error will be  flagged  if  this  will  require  more  basis
!         multinomials  than  the  number  of  data  points which were
!         given.)
!         if the parameter  fitdeg  is <  0, then  nfpols  will  be
!         taken as the count of the number of basis multinomials to be
!         used for a partial-degree fit.  (an error will be flagged if
!         nfpols  < 0.)
!
!     variables
!     ---------
!
!      dimen  -- (integer) -- (passed)
!         the number of variables.
!      fitdeg  - (integer) -- (passed/returned)
!         ignored if < 0.
!         if fitdeg >= 0 then  fitdeg  is  checked  against  nfpts .
!         the value of  fitdeg  will be reduced if there is a basis of
!         multinomials, all of  degree  <= fitdeg ,  of  cardinality
!         nfpts .  see  error  below.
!      nfpols  - (integer) -- (passed/returned)
!         ignored if  fitdeg  >= 0.
!         if  fitdeg < 0 then the value of nfpols will be taken  as
!         the size of the basis of multinomials to be used in the fit.
!         nfpols  must satisfy  nfpols  < nfpts  and nfpols >= 1
!         see  error  below.
!      nfpts  --- (integer) -- (passed)
!         the number of data points to be used in the fit.
!         nfpts  must be >= 1.  see  error  below.
!      fitcds  -- (real 2-subscript array) -- (passed)
!         fitcds (p,k) is the value of the k-th variable at the  p-th
!         data point.
!      ncrows  -- (integer) -- (passed)
!         the row dimension  declared  for   fitcds   in  the  calling
!         program.
!      fitvls  -- (real 1-subscript array) -- (passed)
!         fitvls (p) is the observed function value of the p-th  data
!         point.
!      wts  ----- (real 1-subscript array) -- (passed)
!         wts (p) is the weight attached to the p-th data point.
!      resids  -- (real 1-subscript array) -- (returned)
!         resids (p) is the difference between the fitted function at
!         point p and  fitvls (p).
!      error  -- (integer) -- (returned)
!       0 the desired least square multinomial fit was obtained.
!      -1 only the first nfpols basis polynomials were obtained.
!         fitdeg is the degree of the fit.
!       1 if  fitdeg  >= 0 but there is an interpolating multinomial
!         of smaller degree or if fitdeg < 0 and nfpols > nfpts.
!       2 if  fitdeg  < 0 and  nfpols  <= 0.
!       3 if  nfpts  < 1 and/or  dimen   <  1.
!       4 if  iwklen  and/or  dwklen  is too small.  (set  iwklen   to
!         the value returned in  ireqd , and set  dwklen  to the value
!         returned in  dreqd  to resolve this problem.)
!      fitiwk  -- (integer, 1-subscript array) -- (returned)
!         an integer work array of length  fiwkln .  upon return  from
!         mfit, fitiwk contains dimension and array length information.
!      fitdwk  -- (real 1-subscript array) -- (returned)
!         a real array of length  fdwkln  containing the coefficients
!         needed for computing the multinomial fit at a point.
!      fiwkln  -- (integer) -- (passed)
!         the length of the array  fitiwk .
!      fdwkln  -- (integer) -- (passed)
!         the length of the array  fitdwk .
!      ireqd  -- (integer) -- (returned)
!         the length which the array  fitiwk  really needs to be.
!      dreqd  -- (integer) -- (returned)
!         the length which the array  fitdwk  really needs to be.
!
!
!     note. the 20 loop depends on the scaling scheme being used. the
!     residual scaling must be consistent with that defined by scalpm
!     and scaldn.
!
!     mfit  calls  allot  and  gnrtp.
!
  integer nfpols,fitdeg,nfpts,dimen,fiwkln,fdwkln
  integer error,ireqd,dreqd,indstt,p,dimp1,ncrows
  integer newstt,maxstt,alfstt,psistt,cstt,ssqstt,psiwid,alfl
  integer fitiwk(fiwkln)
  real    fitdwk(fdwkln),fitcds(ncrows,dimen)
  real    fitvls(nfpts),resids(nfpts)
  real    wts(nfpts)
  real    scale
!
  dimp1 = dimen + 1

  call allot(fitdeg,nfpols,nfpts,dimen,fitiwk,fiwkln,ireqd,dreqd, &
             error)
  if ( error >= 2 ) return
!
  if ( fdwkln >= dreqd ) go to 10
     error = 4
     return
   10 continue
!
  psiwid = fitiwk(3)
  alfl = fitiwk(4)
  indstt = 1
  newstt = 4 * nfpols + indstt
  maxstt = 1
  alfstt = maxstt + dimp1
  cstt = alfstt + alfl
  ssqstt = cstt + nfpols
  psistt = ssqstt + nfpols
!
     call gnrtp(fitdeg,fitdwk(alfstt), &
                fitdwk(psistt),fitiwk(indstt), &
                fitiwk(newstt),fitdwk(ssqstt),fitcds, &
                ncrows,nfpols,dimen,nfpts,fitvls,resids, &
                fitdwk(cstt),psiwid,wts,alfl,dimp1, &
                fitdwk(maxstt),error)
!
!     store the number of basis polynomials actually computed
!     by the modified routine incdg called by gnrtp.
!
  fitiwk(1) = nfpols
!
!     unscale the residuals for the benefit of the user.
!
  scale = fitdwk(dimen + 1)
  do 20 p = 1,nfpts
    resids(p) = resids(p) * scale
   20 continue
  return
end
subroutine minsol (usol,idmn,zn,zm,pertb)
!
!*******************************************************************************
!
!! MINSOL orthogonalizes the array usol with respect to the constant array in
!  a weighted least squares norm
!
  dimension       usol(idmn,*)           ,zn(*)      ,zm(*)
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
!     entry at minsol occurrs when the final solution is
!     to be minimized with respect to the weighted
!     least squares norm
!
  istr = 1
  ifnl = k
  jstr = 1
  jfnl = l
!
!     compute weighted inner products
!
  ute = 0.0
  ete = 0.0
  do  20 i=is,ms
     ii = i-is+1
     do  10 j=js,ns
        jj = j-js+1
        ete = ete+zm(ii)*zn(jj)
        ute = ute+usol(i,j)*zm(ii)*zn(jj)
   10    continue
   20 continue
!
!     set perturbation parameter
!
  pertrb = ute/ete
!
!     subtract off constant pertrb
!
  do  40 i=istr,ifnl
     do  30 j=jstr,jfnl
        usol(i,j) = usol(i,j)-pertrb
   30    continue
   40 continue
  return
end
subroutine mkp (n,m,p,w,k,bck,xstar,vstar,wk,iwk,num)
!
!*******************************************************************************
!
!! MKP solves a 0-1 multiple knapsack problem of n items and  m  knapsacks.
!
!
!  n is at least 2, and m at least 1.
!
! i.e. also suitable for a 0-1 single knapsack problem).
! the problem to be solved is
!
! maximize  vstar = p(1)*(x(1,1) + ... + x(m,1)) + ...
!                   ... + p(n)*(x(1,n) + ... + x(m,n))
! subject to
! w(1)*x(i,1) + ... + w(n)*x(i,n) <= k(i)   for  i=1,...,m
! x(1,j) + ... + x(m,j) <= 1   for  j=1,...,n
! x(i,j) = 0 or 1   for  i=1,...,m ,  j=1,...,n ,
!
! where all p(j), w(j), and k(i) are positive integers.
! before mkp is called, array k must be sorted so that
! k(1) <= k(2) <= ... <= k(m) .
!
! meaning of the input parameters ...
!
! n    = number of items.
! m    = number of knapsacks.
! p(j) = profit of item  j  (j=1,...,n) .
! w(j) = weight of item  j  (j=1,...,n) .
! k(i) = capacity of knapsack  i  (i=1,...,m) .
! bck  = -1  if exact solution is required.
!      = maximum number of backtrackings to be performed, if
!        heuristic solution is required.
! wk   = real work space of dimension n.
! iwk  = work space of dimension >= 5*m + 14*n + 4*m*n + 3
! num  = dimension of iwk
!
! meaning of the output parameters ...
!
! xstar(j) = 0  if item  j  is not in the optimal solution
!               (i.e. if  x(i,j) = 0  for all  i ).
!          = knapsack where item  j  is inserted, otherwise
!            (i.e. if  x(xstar(j),j) = 1 ).
! vstar    = value of the optimal solution if  vstar > 0.
!          = error condition (infeasibility or triviality)
!            in the input data if  vstar < 0 .
!            = -1  if  n < 2  or  m  <  1 .
!            = -2  if some  p(j) ,  w(j)  or  k(i) are not
!                  positive.
!            = -3  if a knapsack cannot contain any item.
!            = -4  if an item cannot fit into any knapsack.
!            = -5  if knapsack  m  contains all the items.
!            = -7  if array  k is not correctly sorted.
!            = -8  if num < 5*m + 14*n + 4*m*n + 3.
!
!            (in all the above cases array  xstar is not
!            defined).
!
! all the parameters except wk are of integer type. when mkp
! terminates, all the input parameters are unchanged except
! bck, which gives the number of backtrackings performed.
!
  integer p(n),w(n),k(m),xstar(n),bck,vstar,iwk(num)
  real wk(n)
  integer bb, bl, x, xl
  integer b, ubb
  integer f, pbl, q, v
  integer bs, ps, ws, xs
!
!                    check the input data
!
  if (m < 1 .or. n  <  2) go to 100
  mn = m*n
  if (num < 5*m + 14*n + 4*mn + 3) go to 160
!
  if (p(1) <= 0 .or. w(1) <= 0) go to 110
  ap = p(1)
  aw = w(1)
  wk(1) = -ap/aw
  maxw = w(1)
  minw = w(1)
  isumw = w(1)
  do 10 j = 2,n
     if (p(j) <= 0 .or. w(j) <= 0) go to 110
     ap = p(j)
     aw = w(j)
     wk(j) = -ap/aw
     if (w(j) > maxw) maxw = w(j)
     if (w(j) < minw) minw = w(j)
     isumw = isumw + w(j)
   10 continue
!
  if (k(1) <= 0) go to 110
  if (m == 1) go to 30
  do 20 i = 2,m
     if (k(i) <= 0) go to 110
     if (k(i) < k(i-1)) go to 150
   20 continue
!
   30 if (minw > k(1)) go to 120
  if (maxw > k(m)) go to 130
  if (isumw <= k(m)) go to 140
  vstar = 0
!
!             reorder the arrays p and w so that
!                p(j)/w(j) >= p(j+1)/w(j+1)
!
  n5 = 5*n
  do 40 j = 1,n
     jj = n5 + j
     iwk(jj) = j
   40 continue
  call risort (wk, iwk(n5 + 1), n)
!
  do 50 j = 1,n
     iwk(j) = p(j)
     jn = j + n
     iwk(jn) = w(j)
   50 continue
!
  do 60 j = 1,n
     jj = n5 + j
     l = iwk(jj)
     p(j) = iwk(l)
     npl = n + l
     w(j) = iwk(npl)
   60 continue
!
!                partition the work space iwk
!
  lx =  jj + 1
  lxi = lx + n
  bs = lxi + n
  xs =  bs + n
  ubb = xs + n
!
  np1 = n + 1
  b = ubb + n
  ps = b  + np1
  ws = ps + np1
!
  f = ws + np1
  pbl = f + m
  q = pbl + m
  v = q + m
!
  bb = v + m
  x = bb + mn
  xl = x + mn
!
  bl = xl + mn
!
!                     solve the problem
!
  call mkp1 (n, m, p, w, k, bck, xstar, vstar, np1, n5, &
             iwk(bb), iwk(bl), iwk(x), iwk(xl), &
             iwk(b), iwk(ubb), iwk(lx), iwk(lxi), &
             iwk(f), iwk(pbl), iwk(q), iwk(v), &
             iwk(bs), iwk(ps), iwk(ws), iwk(xs), iwk(1))
!
!           restore the initial ordering to p and w,
!                and reorder xstar accordingly
!
  do 70 j = 1,n
     iwk(j) = p(j)
     jn = j + n
     iwk(jn) = w(j)
     jnn = jn + n
     iwk(jnn) = xstar(j)
   70 continue
!
  do 80 j = 1,n
     jj = n5 + j
     l = iwk(jj)
     p(l) = iwk(j)
     jn = j + n
     w(l) = iwk(jn)
     jnn = jn + n
     xstar(l) = iwk(jnn)
   80 continue
  return
!
!                        error return
!
  100 vstar = -1
  return
  110 vstar = -2
  return
  120 vstar = -3
  return
  130 vstar = -4
  return
  140 vstar = -5
  return
  150 vstar = -7
  return
  160 vstar = -8
  return
end
subroutine mkp1 (n, m, p, w, k, bck, xstar, vstar, np1, n5, &
                   bb, bl, x, xl, b, ubb, lx, lxi, &
                   f, pbl, q, v, bs, ps, ws, xs, iwk)
!
!*******************************************************************************
!
!! MKP1 carries out the solution of a knapsack problem.
!
!
! meaning of the main internal variables and arrays ...
!
! i       = knapsack currently considered.
! lb      = lower bound on the optimal solution.
! ub      = upper bound on the optimal solution.
! vb      = value of the current solution.
! x(i,j)  = 1  if item  j  is inserted in knapsack  i  in
!              the current solution.
!         = 0  otherwise.
! f(i)    = pointer to the last item inserted in knapsack  i
!           ( = -1  if knapsack  i  is empty).
! bb(i,j) = pointer to the item inserted in knapsack  i
!           just before item  j ( = -1  if  j  is the first
!           item inserted in knapsack  i ).
! q(i)    = current available capacity of knapsack  i .
! b(j)    = 1  if item  j  is not inserted in any knapsack.
!         = 0  if item  j  is inserted in a knapsack.
! pbl(i)  = number of the items which can be inserted in
!           knapsack  i .
! bl(i,s) = pointer to the  s-th  item which can be inserted
!           in knapsack  i .
! xl(i,j) = 1  if item  j  was inserted in knapsack  i  in
!              the last execution of subroutine pi1.
!         = 0  otherwise.
! iwk       work space for the subroutine sknp.
!
  integer p(n), w(n), k(m), xstar(n), bck, vstar
  integer bb(m,n), bl(m,np1), x(m,n), xl(m,n)
  integer b(np1), ubb(n), lx(n), lxi(n)
  integer f(m), pbl(m), q(m), v(m)
  integer bs(n), ps(np1), ws(np1), xs(n), iwk(n5)
  integer s, u, ub, vb
!
  if (m == 1) go to 250
!
! step 1 (initialization)
!
  jbck = bck
  bck = 0
  kub = 0
  n1 = n + 1
  b(n1) = 1
  m1 = m - 1
  do 40 j=1,n
    b(j) = 1
    do 30 i=1,m
      x(i,j) = 0
      bb(i,j) = 0
   30   continue
   40 continue
  do 50 i=1,m1
    q(i) = k(i)
    f(i) = -1
   50 continue
  q(m) = k(m)
  vstar = 0
  vb = 0
  i = 1
  call sigma1 (n,m,p,w,k,1,b,kub,ub,np1,n5,lx,lr, &
               bs,ps,ws,xs,iwk)
  do 60 j=1,n
    lxi(j) = lx(j)
   60 continue
  lri = lr
  lubi = ub
  iflag = 0
!
! step 2 (heuristic)
!
   70 kub = vstar - vb
  call pi1 (n,m,p,w,q,i,b,bb,kub,bl,lb,pbl,v,xl, &
            np1,n5,bs,ps,ws,xs,iwk)
  if ( lb + vb <= vstar ) go to 140
  vstar = lb + vb
  do 90 j=1,n
    xstar(j) = 0
    do 80 s=1,i
      if ( x(s,j) == 0 ) go to 80
      xstar(j) = s
      go to 90
   80   continue
   90 continue
  ip = pbl(i)
  if ( ip == 0 ) go to 110
  do 100 j=1,ip
    jj = bl(i,j)
    if ( xl(i,j) == 1 ) xstar(jj) = i
  100 continue
  110 i1 = i + 1
  do 130 ii=i1,m
    ip = pbl(ii)
    if ( ip == 0 ) go to 130
    do 120 j=1,ip
      jj = bl(ii,j)
      if ( xl(ii,j) == 1 ) xstar(jj) = ii
  120   continue
  130 continue
  if ( ub == lb ) go to 200
!
! step 3 (updating)
!
  140 if ( v(i) == 0 ) go to 180
  iuv = ub + vb
  u = pbl(i)
  ibv = 0
  do 170 s=1,u
    if ( xl(i,s) == 0 ) go to 170
    j = bl(i,s)
    x(i,j) = 1
    q(i) = q(i) - w(j)
    vb = vb + p(j)
    b(j) = 0
    bb(i,j) = f(i)
    ubb(j) = iuv
    if ( iflag == 1 ) go to 150
    lub = iuv
    lj = j
    li = i
  150   f(i) = j
    ibv = ibv + p(j)
    if ( ibv == v(i) ) go to 180
    call parc (i,i,ub,iflag,vb,lub,lj,li,f,bb,q,b,n,m,np1, &
               lx,lxi,lr,lri,lubi)
    if ( iflag == 1 ) go to 160
    kub = vstar - vb
    call sigma1 (n,m,p,w,q,i,b,kub,ub,np1,n5,lx,lr, &
                 bs,ps,ws,xs,iwk)
    lj = n1
  160   iuv = ub + vb
    if ( iuv <= vstar ) go to 200
  170 continue
  180 if ( i == m - 1 ) go to 200
  ip1 = i + 1
  call parc (ip1,i,ub,iflag,vb,lub,lj,li,f,bb,q,b,n,m,np1, &
             lx,lxi,lr,lri,lubi)
  if ( iflag == 1 ) go to 190
  kub = vstar - vb
  call sigma1 (n,m,p,w,q,ip1,b,kub,ub,np1,n5,lx,lr, &
               bs,ps,ws,xs,iwk)
  lj = n1
  190 if ( ub + vb <= vstar ) go to 200
  i = i + 1
  go to 140
!
! step 4 (backtracking)
!
  200 if ( i > 0 ) go to 210
  bck = bck - 1
  return
  210 if ( bck == jbck ) return
  bck = bck + 1
  if ( f(i) /= (-1) ) go to 230
  do 220 j=1,n
    bb(i,j) = 0
  220 continue
  i = i - 1
  go to 200
  230 j = f(i)
  x(i,j) = 0
  b(j) = 1
  vb = vb - p(j)
  q(i) = q(i) + w(j)
  do 240 s=1,n
    if ( bb(i,s) == j ) bb(i,s) = 0
  240 continue
  f(i) = bb(i,j)
  if ( ubb(j) <= vstar ) go to 200
  ub = ubb(j) - vb
  iflag = 1
  go to 70
!
! particular case (0-1 single knapsack problem)
!
  250 k1 = k(1)
  do 260 j=1,n
    ps(j) = p(j)
    ws(j) = w(j)
  260 continue
  call sknp (n,k1,0,vstar,n,np1,n5,ps,ws,xs,iwk)
  do 270 j=1,n
    xstar(j) = xs(j)
  270 continue
  bck = 0
  return
end
subroutine mplnmv (mo, au, nc, ac, fv)
!
!*******************************************************************************
!
!! MPLNMV: multiplex polynomial evaluation
!
!     mo = mode of operation
!     au = argument u
!     nc = number of coefficients
!     ac = array of coefficients
!     fv = function v
!
!     mo = -1 for integral
!     mo =  0 for function
!     mo = +1 for first derivative
!     mo = +2 for second derivative
!
  real ac(*)
  real fv
  integer mo
!
1 fv=0.0
  l=nc
  if(mo < 0)go to 2
  if(mo==0)go to 4
  if(mo==1)go to 6
  if(mo >= 2)go to 8
2 ql=nc
  do k=1,nc
    fv=ac(l)/ql+au*fv
    l=l-1
    ql=ql-1.0
  end do
  fv=au*fv
  return
4 do k=1,nc
    fv=ac(l)+au*fv
    l=l-1
  end do

  return
6 if(nc <= 1)return
  ql=nc
  do k=2,nc
    ql=ql-1.0
    fv=ql*ac(l)+au*fv
    l=l-1
  end do

  return
8 if(nc <= 2)return
  ql=nc

  do k = 3, nc
    ql=ql-1.0
    fv=ql*(ql-1.0)*ac(l)+au*fv
    l=l-1
  end do

  return
end
subroutine mprod (m, n, l, a, ka, b, kb, c, kc, row)
!
!*******************************************************************************
!
!! MPROD computes the product of real matrices.
!
  real a(ka,n)
  real b(kb,l)
  real c(kc,l)
  logical rloc
  real row(*)
  double precision w
!
  save = c(1,1)
  c(1,1) = 1.0
  if (rloc(c,a)) go to 20
  if (rloc(c,b)) go to 30
!
  do 12 j = 1,l
     do 11 i = 1,m
     w = 0.d0
        do 10 k = 1,n
   10       w = w + dble(a(i,k))*dble(b(k,j))
   11    c(i,j) = w
   12 continue
  return
!
!     here c begins in the same location as a. the dimension of row
!     must be greater than or equal to l. it is assumed that kc=ka.
!
   20 a(1,1) = save
  do 24 i = 1,m
     do 22 j = 1,l
     w = 0.d0
        do 21 k = 1,n
   21       w = w + dble(a(i,k))*dble(b(k,j))
   22    row(j) = w
     do 23 j = 1,l
   23    a(i,j) = row(j)
   24 continue
  return
!
!     here c begins in the same location as b. the dimension of row
!     must be greater than or equal to m. it is assumed that kc=kb.
!
   30 b(1,1) = save
  do 34 j = 1,l
     do 32 i = 1,m
     w = 0.d0
        do 31 k = 1,n
   31       w = w + dble(a(i,k))*dble(b(k,j))
   32    row(i) = w
     do 33 i = 1,m
   33    b(i,j) = row(i)
   34 continue
  return
end
subroutine mslv(mo,n,m,a,ka,b,kb,det,rcond,ierr,ipvt,wk)
!
!*******************************************************************************
!
!! MSLV factors and solves a system of linear equations.
!
  real a(ka,n)
  real b(*)
  real det(2),rcond,t,wk(n)
  integer ipvt(n),onej
!
!
!          matrix factorization and computation of rcond
!
  ierr = 0
  call sgeco(a,ka,n,ipvt,rcond,wk)
  t = 1.0 + rcond
  if (t == 1.0) go to 30
!
!                  solution of the equation ax=b
!
  if (m < 1) go to 20
  onej = 1
  do j=1,m
    call sgesl(a,ka,n,ipvt,b(onej),0)
    onej = onej + kb
  end do
!
!             calculation of det and the inverse of a
!
   20 job = 10
  if (mo == 0) job = 11
  call sgedi(a,ka,n,ipvt,det,wk,job)
  return
!
!                  the problem cannot be solved
!
   30 ierr = 1
  return
end
subroutine msubt (m, n, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! MSUBT: subtraction of real matrices
!
  real a(ka,n)
  real b(kb,n)
  real c(kc,n)
!
  c(1:m,1:n) = a(1:m,1:n) - b(1:m,1:n)

  return
end
subroutine mtable(degree,dimen,npolys,indexs,newkj,alflp1)
!
!*******************************************************************************
!
!! MTABLE tabulates JP and KJ for each J.
!
!     variables
!
!
!      alflp1  -- (integer) -- (passed)
!         the length required for array  alpha , plus one
!      degree  -- (integer) -- (passed)
!         the degree of the polynomial to be fitted
!      dimen  -- (integer) -- (passed)
!         number of independent variables
!      indexs  -- (integer, 2-subscript array) -- (returned)
!          indexs (1, j )   is    jp ,    indexs (2, j )   is     kj ,
!          indexs (3, j )  is the first nonzero recurrence coefficient
!         in  alpha  and  indexs (4, j ) is its location in  alpha .
!      newkj  -- (integer, 2-subscript array) -- (returned)
!          newkj ( k , d ) is the first monomial of degree  d   having
!          kj = k .
!      npolys  -- (integer) -- (passed)
!         number  of  monomials  of  degree  <=  order  in   dimen
!         independent variables.
!
!     this subprogram can be coded (excluding the part for calculating
!      indexs (3, j )  and   indexs (4, j )) mentally more efficiently
!     but computationally less efficiently as
!
!         j = 2
!         do 5 kj = 1,dimen
!           newkj(kj,1) = kj + 1
!           indexs(1,j) = 1
!           indexs(2,j) = kj
!           j = j + 1
!      5  continue
!         do 10 curdeg = 2,degree
!           do 10 kj = 1,dimen
!             jprime = newkj(kj,curdeg - 1)
!             newkj(kj,curdeg) = j
!             nwithk = comb(dimen + curdeg - kj - 1,curdeg - 1)
!             do 10 i = 1,nwithk
!               indexs(1,j) = jprime
!               indexs(2,j) = kj
!               jprime = jprime + 1
!               j = j + 1
!     10  continue
!
!     where comb(n,kj) is n-factorial / ((n-kj)-factorial * kj-factorial
!     here we make use of the recurrence relations
!
!       comb(dimen+curdeg-2,curdeg-1)
!
!            (dimen+curdeg-2)*comb(dimen+curdeg-3,curdeg-2)
!          = ----------------------------------------------
!                              (curdeg-1)
!
!     and
!
!       comb(dimen+curdeg-kj-1,curdeg-1)
!
!            (dimen-kj+1)*comb(dimen+curdeg-kj,curdeg-1)
!          = -------------------------------------------
!                         (dimen+curdeg-kj)
!
!
!     date last modified
!
!     october 16, 1984
!
!
  integer j,kj,curdeg,jprime,nwithk,i,curm1,ralen,dimm1,dimm2
  integer npolys,dimen,degree,alflp1,dimp1
  integer indexs(4,npolys),newkj(dimen,degree)
!
  alflp1 = 1
!
!
!     set  indexs (4,1) to 1 so that  alfl - indexs (4,1)+1 is the
!     number of columns required for  psi  for  npolys =1  ( alfl
!     is defined in the mainline to be  alflp1 -1 if alflp1 > 1
!     and  alflp1  otherwise.
!
!
  indexs(4,1) = 1
!
  if ( npolys == 1 ) return
  j = 2
  do 10 kj = 1,dimen
     newkj(kj,1) = kj + 1
     indexs(1,j) = 1
     indexs(2,j) = kj
     indexs(3,j) = 1
     indexs(4,j) = alflp1
     alflp1 = alflp1 + j - 1
     if ( j == npolys ) return
10       j = j + 1
  if ( degree == 1 ) return
  ralen = 1
  dimm1 = dimen - 1
  dimm2 = dimen - 2
  dimp1 = dimen + 1
  do 70 curdeg = 2,degree
     curm1 = curdeg - 1
     ralen = (ralen * (dimm2 + curdeg)) / curm1
     nwithk = ralen
     kj = 1
20       jprime = newkj(kj,curm1)
     newkj(kj,curdeg) = j
     if ( kj == dimen ) go to 60
        do 50 i = 1,nwithk
           indexs(1,j) = jprime
           indexs(2,j) = kj
!
!
!     calculate  indexs (3, j ),  indexs (4, j )
!
!
           if ( kj < indexs(2,jprime) ) go to 30
              indexs(3,j) = indexs(1,jprime)
              go to 40
 30            indexs(3,j) = newkj(1,curdeg - 1)
 40            indexs(4,j) = alflp1
           alflp1 = alflp1 + j - indexs(3,j)
           if ( j == npolys ) return
!
           jprime = jprime + 1
 50            j = j + 1
        kj = kj + 1
        nwithk = (nwithk * (dimp1 - kj)) / (dimen + curdeg - kj)
        go to 20
 60      indexs(1,j) = jprime
     indexs(2,j) = dimen
     indexs(3,j) = indexs(1,jprime)
     indexs(4,j) = alflp1
     alflp1 = alflp1 + j - indexs(3,j)
     if ( j == npolys ) return
 70      j = j + 1
  return
end
subroutine mtms (m, n, l, a, ka, b, kb, c, kc)
!
!*******************************************************************************
!
!! MTMS: product of real matrices
!
  real a(ka,n), b(kb,l), c(kc,l)
  double precision w
!
  do 30 j = 1,l
     do 20 i = 1,m
        w = 0.d0
        do 10 k = 1,n
           w = w + dble(a(i,k))*dble(b(k,j))
   10       continue
        c(i,j) = w
   20    continue
   30 continue
  return
end
subroutine mtprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! MTPRD: product of a vector and a sparse matrix
!
  real a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 10 j = 1,n
     y(j) = 0.0
   10 continue
!
  do 21 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 21
     do 20 l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
   20    continue
   21 continue
  return
end
subroutine mtprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! MTPRD1: set y = x*a + y where a is a sparse matrix and x,y are vectors
!
  real a(*), x(m), y(n), t
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     t = x(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do l = lmin,lmax
        j = ja(l)
        y(j) = y(j) + t*a(l)
     end do
   11 continue
  return
end
subroutine mvprd (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! MVPRD: product of a sparse matrix and a vector
!
  real a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = 0.0
     lmin = ia(i)
     lmax = ia(i+1) - 1
     if (lmin > lmax) go to 11
     do l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
     end do
   11 y(i) = sum
  return
end
subroutine mvprd1 (m, n, a, ia, ja, x, y)
!
!*******************************************************************************
!
!! MVPRD1 set y = a*x + y where a is a sparse matrix and x,y are vectors
!
  real a(*), x(n), y(m), sum
  integer ia(*), ja(*)
!
  do 11 i = 1,m
     sum = y(i)
     lmin = ia(i)
     lmax = ia(i+1) - 1

     do l = lmin,lmax
        j = ja(l)
        sum = sum + a(l)*x(j)
     end do
   11 y(i) = sum
  return
end
subroutine newest (type, uu, vv, nn, p, k)
!
!*******************************************************************************
!
!! NEWEST computes new estimates of the quadratic coefficients
!     using the scalars computed in calcsc.
!
  integer type
  double precision uu, vv, p(nn), k(nn)
  double precision a4, a5, b1, b2, c1, c2, c3, c4, temp
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
!     use formulas appropriate to setting of type.
!
  n = nn - 1
  if (type == 3) go to 30
  if (type == 2) go to 10
     a4 = a + u*b + h*f
     a5 = c + (u + v*f)*d
     go to 20
   10 a4 = (a + g)*f + h
  a5 = (f + u)*c + v*d
!
!     evaluate new quadratic coefficients.
!
   20 b1 = -k(n)/p(nn)
  b2 = -(k(n - 1) + b1*p(n))/p(nn)
  c1 = v*b2*a1
  c2 = b1*a7
  c3 = b1*b1*a3
  c4 = c1 - c2 - c3
  temp = a5 + b1*a4 - c4
  if (temp == 0.d0) go to 30
  uu = u - (u*(c3 + c2) + v*(b1*a1 + b2*a7))/temp
  vv = v*(1.d0 + c4/temp)
  return
!
!     if type=3 the quadratic is zeroed
!
   30 uu = 0.d0
  vv = 0.d0
  return
end
subroutine newton ( nl, nr, ni )
!
!*******************************************************************************
!
!! NEWTON computes the divided differences array as follows
!         nl coalesced points on left   - deriv values in fleft
!         nr coalesced points on right  -   -      -    - fright
!         ni distinct  points inbetween - fnctn    -    - fintrp
!
!     the points are ordered xl = xleft (nstack)
!                            xr = xright(nstack)
!                            xintrp array
!
!         layout of the ddtemp divided difference array
!
!     nl=6    llllll****ii
!     nr=4    lllll****ii     l = first triangle
!     ni=2    llll****ii
!             lll****ii       r = second triangle
!             ll****ii
!             l****ii         * = fill between triangles
!             rrrrii
!             rrrii           i = completion for interpolation points
!             rrii
!             rii       idif = horizontal coord. = difference order
!             ii        ipt  = vertical coord. associated with points
!             i
!
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision difff, diffx
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
!                 main calculation of divided differences
!         define a few short constants
  nl1 = nl - 1
  nl2 = nl + 1
  nr1 = nr - 1
  nr2 = nr + 1
  nrl = nr + nl
!
!         put x-values in a single array with nddx = nl+nr+ni points
  do 10 nddx=1,nl
    xdd(nddx) = xleft(nstack)
   10 continue
  nddx = nl
  do 20 k=1,nr
    nddx = nddx + 1
    xdd(nddx) = xright(nstack)
   20 continue
!            check if there are any interpolation points to add to xdd
  if (ni==0) go to 40
  do 30 k=1,ni
    nddx = nddx + 1
    xdd(nddx) = xintrp(k)
   30 continue
!
!           fill border of first triangle - size nl.
   40 continue
!         top border
  do 50 idif=1,nl
    ddtemp(idif,1) = fleft(idif)/factor(idif)
   50 continue
  if (nl1==0) go to 70
!                   bottom border
  do 60 idif=1,nl1
    ipt = nl2 - idif
    ddtemp(idif,ipt) = ddtemp(idif,1)
   60 continue
!
!          fill border of second triangle - size nr
   70 continue
!         top border
  do 80 idif=1,nr
    ddtemp(idif,nl2) = fright(idif)/factor(idif)
   80 continue
  if (nrl==nl2) go to 100
!                   bottom border
  do 90 idif=1,nr1
    ipt = nrl + 1 - idif
    ddtemp(idif,ipt) = ddtemp(idif,nl2)
   90 continue
!
!           fill parallogram between the two triangles just filled
!          fill entries parallel to bottom of first triangle
  100 continue
!
!         loop stepping along top side of second triangle
  do 120 j=2,nr2
    idif = j
!             loop stepping parallel to bottom side of first triangle
    do 110 k=2,nl2
      ipt = nl + 2 - k
      difff = ddtemp(idif-1,ipt+1) - ddtemp(idif-1,ipt)
      ipt2 = ipt - 1 + idif
      diffx = xdd(ipt2) - xdd(ipt)
      ddtemp(idif,ipt) = difff/diffx
      idif = idif + 1
  110   continue
  120 continue
!
!         fill in bottom diagonals for interpolation points, if any
  if (ni==0) go to 150
!         loop through the interpolatation points
  do 140 j=1,ni
    idif = 2
    nrlj = nrl + j
    ddtemp(1,nrlj) = fintrp(j)
!         loop through the differences (idif index)
    nrlj1 = nrlj - 1
    do 130 k=1,nrlj1
      ipt = nrlj - k
      difff = ddtemp(idif-1,ipt+1) - ddtemp(idif-1,ipt)
      diffx = xdd(nrlj) - xdd(ipt)
      ddtemp(idif,ipt) = difff/diffx
      idif = idif + 1
  130   continue
  140 continue
  150 continue
  return
end
subroutine nexth(bool,n,tr,ti,hr,hi,qpr,qpi,qhr,qhi)
!
!*******************************************************************************
!
!! NEXTH calculates the next shifted H polynomial.
!
!     bool - logical variable. if .true. h(s) is essentially zero.
!
  logical bool
  double precision tr,ti,hr(n),hi(n),qpr(n),qpi(n),qhr(n),qhi(n)
  double precision t1,t2
!
  if (bool) go to 20
     do 10 j = 2,n
        t1 = qhr(j - 1)
        t2 = qhi(j - 1)
        hr(j) = tr*t1 - ti*t2 + qpr(j)
        hi(j) = tr*t2 + ti*t1 + qpi(j)
   10    continue
     hr(1) = qpr(1)
     hi(1) = qpi(1)
     return
!
!     if h(s) is zero then replace h with qh.
!
   20 do 30 j = 2,n
     hr(j) = qhr(j - 1)
     hi(j) = qhi(j - 1)
   30 continue
  hr(1) = 0.d0
  hi(1) = 0.d0
  return
end
subroutine nextk(type, n, qp, k, qk)
!
!*******************************************************************************
!
!! NEXTK computes the next k polynomials using the scalars computed in calcsc.
!
  integer type
  double precision qp(n), k(n), qk(n)
  double precision temp
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
  if (type == 3) go to 40
  temp = a
  if (type == 1) temp = b
  if (dabs(a1) > dabs(temp)*eta*10.) go to 20
!
!     if a1 is nearly zero then use a special form of the
!     recurrence
!
  k(1) = 0.d0
  k(2) = -a7*qp(1)
  do 10 i = 3,n
     k(i) = a3*qk(i-2) - a7*qp(i-1)
   10 continue
  return
!
!     use scaled form of the recurrence
!
   20 a7 = a7/a1
  a3 = a3/a1
  k(1) = qp(1)
  k(2) = qp(2) - a7*qp(1)
  do 30 i = 3,n
     k(i) = a3*qk(i-2) - a7*qp(i-1) + qp(i)
   30 continue
  return
!
!     use unscaled form of the recurrence if type is 3
!
   40 k(1) = 0.d0
  k(2) = 0.d0
  do i = 3,n
     k(i) = qk(i - 2)
  end do

  return
end
subroutine normlz(n,x,beta)
!
!*******************************************************************************
!
!! NORMLZ computes the euclidean norm of x.
!
!
!  it returns the value in beta. if x is nonzero, then x is rescaled so
!     that norm(x) = 1.
!
!     functions and subroutines
!
!     blas       snrm2,sscal
!
  integer n
  real x(n),beta
!
  real       one,snrm2,zero
!
  data zero/0.0/, one/1.0/
!
!
  beta = snrm2(n,x,1)
  if (beta > zero) call sscal(n,(one/beta),x,1)
  return
end
subroutine noshft(l1,nn,tr,ti,eta,pr,pi,hr,hi)
!
!*******************************************************************************
!
!! NOSHFT computes the derivative polynomial as the initial h polynomial
!  and computes l1 no-shift h polynomials.
!
  double precision tr,ti,eta,pr(nn),pi(nn),hr(nn),hi(nn)
  double precision dn,t1,t2,xni,dcpabs
!
  n = nn - 1
  nm1 = n - 1
  dn = n
  do 10 i = 1,n
     xni = nn - i
     hr(i) = xni*pr(i)/dn
     hi(i) = xni*pi(i)/dn
   10 continue
!
  do 50 jj = 1,l1
     if (dcpabs(hr(n),hi(n)) <= 10.d0*eta*dcpabs(pr(n),pi(n))) &
        go to 30
     call cdivid(-pr(nn),-pi(nn),hr(n),hi(n),tr,ti)
     do 20 i = 1,nm1
        j = nn - i
        t1 = hr(j - 1)
        t2 = hi(j - 1)
        hr(j) = tr*t1 - ti*t2 + pr(j)
        hi(j) = tr*t2 + ti*t1 + pi(j)
   20    continue
     hr(1) = pr(1)
     hi(1) = pi(1)
     go to 50
!
!     if the constant term is essentially zero, shift h coefficients.
!
   30    do 40 i = 1,nm1
        j = nn - i
        hr(j) = hr(j - 1)
        hi(j) = hi(j - 1)
   40    continue
     hr(1) = 0.d0
     hi(1) = 0.d0
   50 continue
  return
end
subroutine npivot (n, m, a, ka, b, kb, d, ierr)
!
!*******************************************************************************
!
!! NPIVOT: matrix inversion/equation solving without pivot search
!
  real a(ka,n), b(*)
!
  ierr = 0
  maxb = kb*m
  do 80 k = 1,n
!
!     examine the pivot element
!
  pivot = a(k,k)
  d = d*pivot
  if (pivot /= 0.0) go to 10
     ierr = 1
     return
!
!     divide the pivot row by the pivot element
!
   10 a(k,k) = 1.0
  do 20 l = 1,n
     a(k,l) = a(k,l)/pivot
   20 continue
  if (m <= 0) go to 40
!
  do 30 kl = k,maxb,kb
     b(kl) = b(kl)/pivot
   30 continue
!
!     reduce the non-pivot rows
!
   40 do 70 j = 1,n
     if (j == k) go to 70
     t = a(j,k)
     a(j,k) = 0.0
     do 50 l = 1,n
        a(j,l) = a(j,l) - a(k,l)*t
   50    continue
     if (m <= 0) go to 70
!
     kl = k
     do 60 jl = j,maxb,kb
        b(jl) = b(jl) - b(kl)*t
        kl = kl + kb
   60    continue
   70 continue

   80 continue
  return
end
subroutine nrng (ix, a, n, ierr)
!
!*******************************************************************************
!
!! NRNG is a Gaussian random number generator.
!
  real a(n), temp(1)
  data pi2 /6.2831853071796/
!
  call urng (ix,a,n,ierr)
  if (ierr /= 0) return
  if (n == 1) go to 20
!
  m = n/2
  m = m + m
  do 10 i = 1,m,2
     r = sqrt(-2.0*alog(a(i)))
     phi = pi2*a(i+1)
     a(i) = r*cos(phi)
   10    a(i+1) = r*sin(phi)
  if (m == n) return
!
   20 call urng (ix,temp,1,ierr)
  r = sqrt(-2.0*alog(a(n)))
  a(n) = r*cos(pi2*temp(1))
  return
end
subroutine nspiv1 (n,ia,ja,a,b,max,r,c,ic,x,y,p,iu,ju,u,ierr)
!
!*******************************************************************************
!
!! NSPIV1 uses sparse gaussian elimination with
!  column interchanges to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!
!  see spslv for descriptions of all input and output arguments
!  other than those described below
!
!  ic  integer array of n entries which is the inverse of c
!      (i.e., ic(c(i)) = i). ic is both an input and output
!      argument.
!
!  input arguments (used internally only)---
!
!  y   real array of n entries used to compute the updated
!      right hand side
!
!  p   integer array of n+1 entries used for a linked list.
!      p(n+1) is the list header, and the entry following
!      p(k) is in p(p(k)).  thus, p(n+1) is the first data
!      item, p(p(n+1)) is the second, etc.  a pointer of
!      n+1 marks the end of the list
!
!  iu  integer array of n+1 entries used for row pointers to u
!      (see matrix storage description below)
!
!  ju  integer array of max entries used for column numbers of
!      the nonzeros in the strict upper triangle of u.  (see
!      matrix storage description below)
!
!  u   real array of max entries used for the actual nonzeros in
!      the strict upper triangle of u.  (see matrix storage
!      description below)
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzeros in
!  a.  iu, ju, and u are used in a similar way to store the strict upper
!  triangle of u, except that ju actually contains c(j) instead of j
!
!
  real a(*), b(n), u(max), x(n), y(n)
  real dk, lki, xpv, xpvmax, yk
  integer c(n), ia(*), ic(n), iu(*), ja(*), ju(max), p(*), r(n)
  integer ck, pk, ppk, pv, v, vi, vj, vk
!
!  initialize work storage and pointers to ju
!
  do 10 j = 1,n
    x(j) = 0.0
 10   continue
  iu(1) = 1
  juptr = 0
!
!  perform symbolic and numeric factorization row by row
!  vk (vi,vj) is the graph vertex for row k (i,j) of u
!
  do 170 k = 1,n
!
!  initialize linked list and free storage for this row
!  the r(k)-th row of a becomes the k-th row of u.
!
    p(n+1) = n+1
    vk = r(k)
!
!  set up adjacency list for vk, ordered in
!  current column order of u.  the loop index
!  goes downward to exploit any columns
!  from a in correct relative order
!
    jmin = ia(vk)
    jmax = ia(vk+1) - 1
    if (jmin > jmax)  go to 1002
    j = jmax
 20       jaj = ja(j)
      vj = ic(jaj)
!
!  store a(k,j) in work vector
!
      x(vj) = a(j)
!  this code inserts vj into adjacency list of vk
      ppk = n+1
 30       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  30,1003,40
 40       p(vj) = ppk
      p(pk) = vj
      j = j - 1
      if (j >= jmin) go to 20
!
!  the following code computes the k-th row of u
!
    vi = n+1
    yk = b(vk)
 50     vi = p(vi)
    if (vi >= k) go to 110
!
!  vi lt vk -- process the l(k,i) element and merge the
!  adjacency of vi with the ordered adjacency of vk
!
    lki = - x(vi)
    x(vi) = 0.0
!
!  adjust right hand side to reflect elimination
!
    yk = yk + lki * y(vi)
    ppk = vi
    jmin = iu(vi)
    jmax = iu(vi+1) - 1
    if (jmin > jmax)  go to 50
    do 100 j = jmin,jmax
      juj = ju(j)
      vj = ic(juj)
!
!  if vj is already in the adjacency of vk,
!  skip the insertion
!
      if (x(vj) /= 0.0)  go to 90
!
!  insert vj in adjacency list of vk.
!  reset ppk to vi if we have passed the correct
!  insertion spot.  (this happens when the adjacency of
!  vi is not in current column order due to pivoting.)
!
      if (vj - ppk) 60,90,70
 60       ppk = vi
 70       pk = ppk
      ppk = p(pk)
      if (ppk - vj)  70,90,80
 80       p(vj) = ppk
      p(pk) = vj
      ppk = vj
!
!  compute l(k,j) = l(k,j) - l(k,i)*u(i,j) for l(k,i) nonzero
!  compute u*(k,j) = u*(k,j) - l(k,i)*u(i,j) for u(k,j) nonzero
!  (u*(k,j) = u(k,j)*d(k,k))
!
 90       x(vj) = x(vj) + lki * u(j)
 100    continue
    go to 50
!
!  pivot--interchange largest entry of k-th row of u with
!  the diagonal entry.
!
!  find largest entry, counting off-diagonal nonzeros
!
 110    if (vi > n) go to 1004
    xpvmax = abs(x(vi))
    maxc = vi
    nzcnt = 0
    pv = vi
 120      v = pv
      pv = p(pv)
      if (pv > n) go to 130
      nzcnt = nzcnt + 1
      xpv = abs(x(pv))
      if (xpv <= xpvmax) go to 120
      xpvmax = xpv
      maxc = pv
      maxcl = v
      go to 120
 130    if (xpvmax == 0.0) go to 1004
!
!  if vi = k, then there is an entry for diagonal
!  which must be deleted.  otherwise, delete the
!  entry which will become the diagonal entry
!
    if (vi == k) go to 140
    if (vi == maxc) go to 140
    p(maxcl) = p(maxc)
    go to 150
 140    vi = p(vi)
!
!  compute d(k) = 1/l(k,k) and perform interchange.
!
 150    dk = 1.0 / x(maxc)
    x(maxc) = x(k)
    i = c(k)
    c(k) = c(maxc)
    c(maxc) = i
    ck = c(k)
    ic(ck) = k
    ic(i) = maxc
    x(k) = 0.0
!
!  update right hand side.
!
    y(k) = yk * dk
!
!  compute value for iu(k+1) and check for storage overflow
!
    iu(k+1) = iu(k) + nzcnt
    if (iu(k+1) > max+1) go to 1005
!
!  move column indices from linked list to ju.
!  columns are stored in current order with original
!  column number (c(j)) stored for current column j
!
    if (vi > n)  go to 170
    j = vi
 160      juptr = juptr + 1
      ju(juptr) = c(j)
      u(juptr) = x(j) * dk
      x(j) = 0.0
      j = p(j)
      if (j <= n) go to 160
 170    continue
!
!  backsolve u x = y, and reorder x to correspond with a
!
  k = n
  do 200 i = 1,n
    yk = y(k)
    jmin = iu(k)
    jmax = iu(k+1) - 1
    if (jmin > jmax)  go to 190
    do 180 j = jmin,jmax
      juj = ju(j)
      juj = ic(juj)
      yk = yk - u(j) * y(juj)
 180    continue
 190    y(k) = yk
    ck = c(k)
    x(ck) = yk
    k = k - 1
 200  continue
!
!  return with ierr = number of off-diagonal nonzeros in u
!
  ierr = iu(n+1) - iu(1)
  return
!
!  error returns
!
!  row k of a is null
!
 1002 ierr = -k
  return
!
!  row k of a has a duplicate entry
!
 1003 ierr = -(n+k)
  return
!
!  zero pivot in row k
!
 1004 ierr = -(2*n+k)
  return
!
!  storage for u exceeded on row k
!
 1005 ierr = -(3*n+k)
  return
end
subroutine nsterp(tm,wm,xm,m,tn,wn,xn,n,kernel,rhfcn,rhs,kmn, &
     nhalf,nup)
!
!*******************************************************************************
!
!! NSTERP uses the values of xn(1:n) to calculate the nystrom interpolates
!  xm(i), i=1,...,m.
!
  real kernel,kmn
  dimension tm(m),wm(m),xm(m),tn(n),wn(n),xn(n),rhs(m), &
     kmn(nup,nhalf)
  external kernel,rhfcn
!
  if(m > nup) go to 4
!   since m <= nupper, save k(tm(i),tn(j))=kmn(i,j) and
!   rhs(i)=rhfcn(tm(i)) for later use in itert.
  do 1 i=1,m
  do 1 j=1,n
1     kmn(i,j)=wn(j)*kernel(tm(i),tn(j))
  do 2 i=1,m
  rhs(i)=rhfcn(tm(i))
2     xm(i)=rhs(i)
!   calculate nystrom interpolating formula.
  do 3 i=1,m
  do 3 j=1,n
3     xm(i)=xm(i)+kmn(i,j)*xn(j)
  return
!   m > nupper, so save just rhs(i) for later use in itert.
!   calculate nystrom interpolating formula.
4     do 5 i=1,m
  rhs(i)=rhfcn(tm(i))
  xm(i)=rhs(i)
  do 5 j=1,n
5     xm(i)=xm(i)+wn(j)*kernel(tm(i),tn(j))*xn(j)
  return
end
subroutine nsurf2 (dxmin,dxmax,md,dymin,dymax,nd,dz, &
                     idz,m,n,x,y,z,iz,zp,work,sigma)
!
!*******************************************************************************
!
!! NSURF2 maps values onto a surface at every point of a grid
!  equally spaced in both x and y coordinates. the
! surface interpolation is performed using a bi-spline
! under tension. the subroutine surf1 or nsurf1 should be
! called earlier to determine certain necessary parameters.
!
!                      from the spline under tension package
!                                 coded by alan kaylor cline
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   dxmin and dxmax contain the lower and upper limits,
!   respectively, of the x-coordinates of the second grid.
!
!   md contains the number of grid lines in the x direction
!   of the second grid (md >= 1).
!
!   dymin and dymax contain the lower and upper limits,
!   respectively, of the y-coordinates of the second grid.
!
!   nd contains the number of grid lines in the y direction
!   of the second grid (nd >= 1).
!
!   idz contains the row dimension of the array dz as
!   declared in the calling program.
!
!   m and n contain the number of grid lines in the x- and
!   y-directions, respectively, of the rectangular grid
!   which specified the surface.
!
!   x and y are arrays containing the x- and y-grid values,
!   respectively, each in increasing order.
!
!   z is a matrix containing the m * n functional values
!   corresponding to the grid values (i. e. z(i,j) is the
!   surface value at the point (x(i),y(j)) for i = 1,...,m
!   and j = 1,...,n).
!
!   iz contains the row dimension of the array z as declared
!   in the calling program.
!
!   zp is an array of 3*m*n locations stored with the
!   various surface derivative information determined by
!   surf1.
!
!   work is an array of 4*md locations to be used internally
!   for workspace.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters m, n, x, y, z, iz, zp, and sigma should be
! input unaltered from the output of surf1 or nsurf1.
!
! on output--
!
!   dz contains the md by nd array of surface values
!   interpolated at the points of the second grid.
!
! none of the input parameters are altered.
!
! this function references package module snhcsh.
!
  integer md,nd,idz,m,n,iz
  real dxmin,dxmax,dymin,dymax,dz(idz,nd),x(m),y(n), &
       z(iz,n),zp(m,n,*),work(4,md),sigma
!
! denormalize tension factor in x and y direction
!
  sigmax = abs(sigma)*real(m-1)/(x(m)-x(1))
  sigmay = abs(sigma)*real(n-1)/(y(n)-y(1))
!
! find intervals of second x grid with respect to original x
! grid
!
  deltdx = 0.
  if (md >= 2) deltdx = (dxmax-dxmin)/real(md-1)
  lasti = 1
  do 3 ii = 1,md
    xii = dxmin+real(ii-1)*deltdx
    i = lasti
1   i = i+1
    if (xii > x(i) .and. i < m) go to 1
    im1 = i-1
    lasti = im1
    del1 = xii-x(im1)
    del2 = x(i)-xii
    dels = x(i)-x(im1)
    work(1,ii) = del2/dels
    work(2,ii) = del1/dels
    if (sigmax /= 0.) go to 2
    temp = -del1*del2/(6.*dels)
    work(3,ii) = temp*(del2+dels)
    work(4,ii) = temp*(del1+dels)
    go to 3
2   delp1 = (del1+dels)/2.
    delp2 = (del2+dels)/2.
    call snhcsh (sinhm1,dummy,sigmax*del1,-1)
    call snhcsh (sinhm2,dummy,sigmax*del2,-1)
    call snhcsh (sinhms,dummy,sigmax*dels,-1)
    call snhcsh (sinhp1,dummy,sigmax*del1/2.,-1)
    call snhcsh (sinhp2,dummy,sigmax*del2/2.,-1)
    call snhcsh (dummy,coshp1,sigmax*delp1,1)
    call snhcsh (dummy,coshp2,sigmax*delp2,1)
    temp = sigmax*sigmax*dels*(sinhms+sigmax*dels)
    work(3,ii) = (sinhm2*del1-del2*(2.*(coshp2+1.)* &
                  sinhp1+sigmax*coshp2*del1))/temp
    work(4,ii) = (sinhm1*del2-del1*(2.*(coshp1+1.)* &
                  sinhp2+sigmax*coshp1*del2))/temp
3   continue
!
! find intervals of second y grid with respect to original y
! grid and perform intrpolation
!
  deltdy = 0.
  if (nd >= 2) deltdy = (dymax-dymin)/real(nd-1)
  lastj = 1
  do 8 jj=1,nd
    yjj = dymin+real(jj-1)*deltdy
    j = lastj
4   j = j+1
    if (yjj > y(j) .and. j < n) go to 4
    jm1 = j-1
    lastj = jm1
    del1 = yjj-y(jm1)
    del2 = y(j)-yjj
    dels = y(j)-y(jm1)
    c1 = del2/dels
    c2 = del1/dels
    if (sigmay /= 0.) go to 5
    temp = -del1*del2/(6.*dels)
    c3 = temp*(del2+dels)
    c4 = temp*(del1+dels)
    go to 6
5   delp1 = (del1+dels)/2.
    delp2 = (del2+dels)/2.
    call snhcsh (sinhm1,dummy,sigmay*del1,-1)
    call snhcsh (sinhm2,dummy,sigmay*del2,-1)
    call snhcsh (sinhms,dummy,sigmay*dels,-1)
    call snhcsh (sinhp1,dummy,sigmay*del1/2.,-1)
    call snhcsh (sinhp2,dummy,sigmay*del2/2.,-1)
    call snhcsh (dummy,coshp1,sigmay*delp1,1)
    call snhcsh (dummy,coshp2,sigmay*delp2,1)
    temp = sigmay*sigmay*dels*(sinhms+sigmay*dels)
    c3 = (sinhm2*del1-del2*(2.*(coshp2+1.)* &
          sinhp1+sigmay*coshp2*del1))/temp
    c4 = (sinhm1*del2-del1*(2.*(coshp1+1.)* &
          sinhp2+sigmay*coshp1*del2))/temp
6   lasti = 0
    do 8 ii=1,md
      xii = dxmin+real(ii-1)*deltdx
      i = max0 (1, lasti)
7     i = i+1
      if (xii > x(i) .and. i < m) go to 7
      im1 = i-1
      if (im1 == lasti) go to 8
      lasti = im1
      zim1 = c1*z(im1,jm1)+c2*z(im1,j) &
             +c3*zp(im1,jm1,1)+c4*zp(im1,j,1)
      zi = c1*z(i,jm1)+c2*z(i,j) &
           +c3*zp(i,jm1,1)+c4*zp(i,j,1)
      zxxim1 = c1*zp(im1,jm1,2)+c2*zp(im1,j,2) &
               +c3*zp(im1,jm1,3)+c4*zp(im1,j,3)
      zxxi = c1*zp(i,jm1,2)+c2*zp(i,j,2) &
             +c3*zp(i,jm1,3)+c4*zp(i,j,3)
8     dz(ii,jj) = work(1,ii)*zim1+work(2,ii)*zi &
                  +work(3,ii)*zxxim1+work(4,ii)*zxxi
  return
end
subroutine ode(f,neqn,y,t,tout,relerr,abserr,iflag,work,iwork)
!
!*******************************************************************************
!
!! ODE integrates a system of first order differential equations.
!
!
!     sandia mathematical program library
!     applied mathematics division 2642
!     sandia laboratories
!     albuquerque, new mexico  87115
!     january 1976
!
!   written by l. f. shampine and m. k. gordon
!
!   abstract
!
!   ode  integrates a system of  neqn  first order
!   ordinary differential equations of the form
!             dy(i)/dt = f(t,y(1),y(2),...,y(neqn))
!             y(i) given at  t .
!   the subroutine integrates from  t  to  tout .  on return the
!   parameters in the call list are set for continuing the integration.
!   the user has only to define a new value  tout  and call  ode  again.
!
!   the differential equations are actually solved by a suite of codes
!   de1,  step1, and  intrp .  ode  allocates virtual storage in the
!   arrays  work  and  iwork  and calls  de1.  de1 is a supervisor which
!   directs the solution.  it calls on the routines  step1 and  intrp
!   to advance the integration and to interpolate at output points.
!   step1 uses a modified divided difference form of the adams pece
!   formulas and local extrapolation.  it adjusts the order and step
!   size to control the local error per unit step in a generalized
!   sense.  normally each call to  step1 advances the solution one step
!   in the direction of  tout .  for reasons of efficiency  de1
!   integrates beyond  tout  internally, though never beyond
!   t+10*(tout-t), and calls  intrp  to interpolate the solution at
!   tout .  an option is provided to stop the integration at  tout  but
!   it should be used only if it is impossible to continue the
!   integration beyond  tout .
!
!   this code is completely explained and documented in the text,
!   computer solution of ordinary differential equations,  the initial
!   value problem  by l. f. shampine and m. k. gordon.
!
!   the parameters represent...
!      f -- subroutine f(t,y,yp) to evaluate derivatives yp(i)=dy(i)/dt
!      neqn -- number of equations to be integrated
!      y(*) -- solution vector at  t
!      t -- independent variable
!      tout -- point at which solution is desired
!      relerr,abserr -- relative and absolute error tolerances for local
!           error test.  at each step the code requires
!             abs(local error) <= abs(y)*relerr + abserr
!           for each component of the local error and solution vectors
!      iflag -- indicates status of integration
!      work(*),iwork(*) -- arrays to hold information internal to code
!           which is necessary for subsequent calls
!
!   first call to ode --
!
!   the user must provide storage in his calling program for the arrays
!   in the call list,
!      y(neqn), work(100+21*neqn), iwork(5),
!   declare  f  in an external statement, supply the subroutine
!   f(t,y,yp) to evaluate
!      dy(i)/dt = yp(i) = f(t,y(1),y(2),...,y(neqn))
!   and initialize the parameters...
!      neqn -- number of equations to be integrated
!      y(*) -- vector of initial conditions
!      t -- starting point of integration
!      tout -- point at which solution is desired
!      relerr,abserr -- relative and absolute local error tolerances
!      iflag -- +1,-1.  indicator to initialize the code.  normal input
!           is +1.  the user should set iflag=-1 only if it is
!           impossible to continue the integration beyond  tout .
!   all parameters except  f ,  neqn  and  tout  may be altered by the
!   code on output so must be variables in the calling program.
!
!   output from  ode  --
!
!      neqn -- unchanged
!      y(*) -- solution at  t
!      t -- last point reached in integration.  normal return has
!           t = tout .
!      tout -- unchanged
!      relerr,abserr -- normal return has tolerances unchanged.  iflag=3
!           signals tolerances increased
!      iflag = 2 -- normal return.  integration reached  tout
!            = 3 -- integration did not reach  tout  because error
!                   tolerances too small.  relerr ,  abserr  increased
!                   appropriately for continuing
!            = 4 -- integration did not reach  tout  because more than
!                   maxnum steps needed
!            = 5 -- integration did not reach  tout  because equations
!                   appear to be stiff
!            = 6 -- integration did not reach  tout  because solution
!                   vanished making pure relative error impossible.
!                   must use non-zero  abserr  to continue.
!            = 7 -- invalid input parameters (fatal error)
!           the value of  iflag  is returned negative when the input
!           value is negative and the integration does not reach  tout ,
!           i.e., -3, -4, -5, -6.
!      work(*),iwork(*) -- information generally of no interest to the
!           user but necessary for subsequent calls.
!
!   subsequent calls to  ode --
!
!   subroutine  ode  returns with all information needed to continue
!   the integration.  if the integration reached  tout , the user need
!   only define a new  tout  and call again.  if the integration did not
!   reach  tout  and the user wants to continue, he just calls again.
!   in the case  iflag=6 , the user must also alter the error criterion.
!   the output value of  iflag  is the appropriate input value for
!   subsequent calls.  the only situation in which it should be altered
!   is to stop the integration internally at the new  tout , i.e.,
!   change output  iflag=2  to input  iflag=-2 .  error tolerances may
!   be changed by the user before continuing.  all other parameters must
!   remain unchanged.
!
  logical start,phase1,nornd
  dimension y(neqn),work(*),iwork(5)
  external f
  data ialpha,ibeta,isig,iv,iw,ig,iphase,ipsi,ix,ih,ihold,istart, &
    itold,idelsn/1,13,25,38,50,62,75,76,88,89,90,91,92,93/
!
  iyy = 100
  iwt = iyy + neqn
  ip = iwt + neqn
  iyp = ip + neqn
  iypout = iyp + neqn
  iphi = iypout + neqn
  if(iabs(iflag) < 2  .or.  iabs(iflag) > 6) go to 1
  start = work(istart) > 0.0
  phase1 = work(iphase) > 0.0
  nornd = iwork(2) /= -1
 1    call de1(f,neqn,y,t,tout,relerr,abserr,iflag,work(iyy), &
    work(iwt),work(ip),work(iyp),work(iypout),work(iphi), &
    work(ialpha),work(ibeta),work(isig),work(iv),work(iw),work(ig), &
    phase1,work(ipsi),work(ix),work(ih),work(ihold),start, &
    work(itold),work(idelsn),iwork(1),nornd,iwork(3),iwork(4), &
    iwork(5))
  work(istart) = -1.0
  if(start) work(istart) = 1.0
  work(iphase) = -1.0
  if(phase1) work(iphase) = 1.0
  iwork(2) = -1
  if(nornd) iwork(2) = 1
  return
end
subroutine opchk1 (n,x,typsiz,fscale,gradtl,itnlim,rerr, &
                         stepmx,ierr)
!
!*******************************************************************************
!
!! OPCHK1 checks input for reasonableness
!
!
!     input ...
!
!       n          dimension of problem
!       x(n)       estimate of minimum of fcn
!       gradtl     tolerance at which gradient considered close
!                  enough to zero to terminate algorithm
!       itnlim     maximum number of allowable iterations
!       rerr       relative accuracy of subroutine fcn
!
!     input/output ...
!
!       typsiz(n)  scaling vector for x
!       fscale     estimate of scale of objective function fcn
!       stepmx     maximum step size
!
!     output ...
!
!       ierr       error indicator
!
  real x(n), typsiz(n)
!
!     check that parameters only take on acceptable values.
!     if not, set them to default values.
!
  ierr = 0
!
!     check dimension of problem
!
  if (n <= 0) go to 805
  if (n == 1) go to 810
!
!     compute scale matrix
!
  do 10 i = 1,n
    typsiz(i) = abs(typsiz(i))
    if (typsiz(i) == 0.0) typsiz(i) = 1.0
   10 continue
!
!     check maximum step size
!
  if (stepmx > 0.0) go to 20
  stpsiz = 0.0
  do 15 i = 1, n
     stpsiz = stpsiz + (x(i)/typsiz(i))**2
   15 continue
  stpsiz = sqrt(stpsiz)
  stepmx = max ( 1.0e3*stpsiz, 1.0e3)
   20 continue
!
!     check function scale
!
  fscale = abs(fscale)
  if (fscale == 0.0) fscale = 1.0
!
!     check gradient tolerance
!
  if (gradtl < 0.0) go to 815
!
!     check iteration limit
!
  if (itnlim <= 0) go to 820
!
!     check the accuracy of fcn
!
  if (rerr < 0.0 .or. rerr > 1.e-4) go to 825
  return
!
!     error exits
!
  805 ierr = -1
  go to 895
  810 ierr = -2
  go to 895
  815 ierr = -3
  go to 895
  820 ierr = -4
  go to 895
  825 ierr = -5
  895 return
end
subroutine opstp(n,xpls,fpls,gpls,x,itncnt,icscmx,ierr, &
             gradtl,steptl,typsiz,fscale,itnlim,iretcd,mxtake, &
             fstack,ns,sptr)
!
!*******************************************************************************
!
!! OPSTP: unconstrained minimization stopping criteria
!
!     input ...
!
!       n          dimension of problem
!       xpls(n)    new iterate x(k)
!       fpls       function value at new iterate, f(xpls)
!       gpls(n)    gradient at new iterate, g(xpls), or approximate
!       x(n)       old iterate x(k-1)
!       itncnt     current iteration k
!       icscmx     number consecutive steps >= stepmx
!       gradtl     tolerance at which relative gradient considered close
!                  enough to zero to terminate algorithm
!       steptl     relative step size at which successive iterates
!                  considered close enough to terminate algorithm
!       typsiz(n)  scaling vector for x
!       itnlim     maximum number of allowable iterations
!       iretcd     code which was set when the point xpls was obtained
!       mxtake     boolean flag indicating step of maximum length used
!       ns         length of the array fstack
!
!     input/output ...
!
!       fscale     estimate of scale of objective function
!       fstack(ns) stack of previous function values
!       sptr       pointer to an element in fstack
!
!     output ...
!
!       icscmx     number consecutive steps >= stepmx
!                  (retain value between successive calls)
!       ierr       termination code
!
  real xpls(n), gpls(n), x(n), typsiz(n), fstack(ns)
  integer sptr
  logical mxtake
!
  ierr = 0
!
!     last global step failed to locate a point lower than x
!
  if (iretcd /= 1) go to 10
     ierr = 3
     return
   10 continue
!
!     find direction in which relative gradient maximum.
!     check whether within tolerance.
!
  d = max ( abs(fpls),fscale)
  rgx = 0.0
  do 20 i = 1,n
     grd = abs(gpls(i))*max ( abs(xpls(i)),typsiz(i))
     rgx = max ( rgx, grd)
   20 continue
  jerr = 1
  if (rgx > gradtl*d) go to 30
     if (abs(fpls) <= 1.e-9) go to 100
     if (abs(fpls) > 0.5*fscale) go to 100
     fscale = abs(fpls)
   30 if (itncnt == 0) return
!
!     find direction in which relative stepsize maximum
!     check whether within tolerance.
!
  rsx = 0.0
  do 40 i = 1,n
     relstp = abs(xpls(i) - x(i))/max ( abs(xpls(i)),typsiz(i))
     rsx = max ( rsx,relstp)
   40 continue
  jerr = 2
  if (rsx <= steptl) go to 100
!
!     check if fpls is sufficiently less than the ns-th
!     previous value of fcn.
!
  if (itncnt > ns) go to 50
     sptr = itncnt
     fstack(sptr) = fpls
     go to 60
   50 sptr = sptr + 1
  if (sptr > ns) sptr = 1
  jerr = 3
  if (fpls >= (fstack(sptr) - 1.e-3*abs(fstack(sptr)))) &
          go to 100
  fstack(sptr) = fpls
!
!     check iteration limit
!
   60 jerr = 4
  if (itncnt >= itnlim) go to 100
!
!     check number of consecutive steps of size stepmx
!
  if (mxtake) go to 70
     icscmx = 0
     return
   70 icscmx = icscmx + 1
  if (icscmx >= 20) ierr = 5
  return
!
!     terminate
!
  100 ierr = jerr
  return
end
subroutine optdrv (mo,nr,n,x,fcn,typsiz,fscale,rerr, &
          itnlim,itncnt,gradtl,stepmx,steptl,xpls,fpls,gpls, &
          ierr,a,g,p,wrk0,wrk1,wrk2)
!
!*******************************************************************************
!
!! OPTDRV: driver for non-linear optimization problem
!
!     input ...
!
!       nr         row dimension of matrix
!       n          dimension of problem
!       fcn        subroutine.  fcn evaluates the function to be
!                  optimized. fcn must be declared external in the
!                  calling program. the routine has the format
!                         call fcn (n, x, fval)
!                  where x is a point and fval is the value of the
!                  function at the point.
!       rerr       relative accuracy of subroutine fcn. it is
!                  assumed that rerr is nonnegative. if rerr = 0
!                  then fcn is accurate to machine precision.
!       itnlim     maximum number of allowable iterations
!       gradtl     tolerance at which the gradient is considered
!                  close enough to zero to terminate algorithm.
!                  (used only in the subroutine opstp.)
!       steptl     relative step size at which successive iterates
!                  considered close enough to terminate algorithm
!
!     input/output ...
!
!       mo         number of rescalings of the variables.
!       x(n)       estimate of a local minimum of fcn
!       typsiz(n)  typical size for each component of x
!       fscale     estimate of scale of minimum value of fcn.
!                  (used only in the subroutine opstp.)
!       stepmx     maximum allowable step size
!
!     output ...
!
!       itncnt     number of iterations completed
!       xpls(n)    estimate of a local minimum of fcn
!       fpls       function value at xpls
!       gpls(n)    gradient at xpls
!       ierr       termination code
!
!     work spaces ...
!
!       a(n,n)     cholesky decomposition of hessian
!       g(n)       gradient at the current iterate
!       p(n)       step
!       wrk0(n)    workspace
!       wrk1(n)    workspace
!       wrk2(n)    workspace
!
!
!     internal parameters ...
!
!       rnf        noise in the subroutine fcn
!       f          function value  fcn(x)
!       fstack(ns) stack of previous function values
!       ns         length of the array fstack
!       sptr       pointer to an element in fstack
!
  dimension x(n),xpls(n),g(n),gpls(n),p(n)
  dimension typsiz(n),a(nr,n)
  dimension wrk0(n),wrk1(n),wrk2(n)
  dimension fstack(30)
  integer sptr
  logical mxtake,noupdt
  external fcn
!
!     initialization
!
  ns = 30
  stmx = stepmx
  stepmx = 0.0
  call opchk1 (n,x,typsiz,fscale,gradtl,itnlim,rerr,stepmx,ierr)
  if (ierr < 0) return
  if (mo /= 0) stepmx = max ( stmx,stepmx)
!
  rnf = 2.0*max ( rerr, epsilon ( rnf ) )
  sqrnf = sqrt(rnf)
!
  itncnt = 0
  iagflg = 0
  iretcd = -1
  icscmx = 0
!
!     evaluate fcn(x)
!
  call fcn(n,x,f)
!
!     evaluate finite difference gradient
!
  call fstofd (n, x, fcn, f, g, typsiz, sqrnf)
!
  call opstp (n,x,f,g,wrk1,itncnt,icscmx,ierr,gradtl,steptl, &
              typsiz,fscale,itnlim,iretcd,mxtake,fstack,ns,sptr)
  if (ierr == 0) go to 10
  if (mo /= 0) go to 210
!
!        apply the fixed step coordinate descent procedure
!        for one step and check if the gradient is nonzero
!
     call fxdec (fcn, n, x, f, 10.0)
!
     stepmx = 0.0
     call opchk1 (n,x,typsiz,fscale,gradtl,itnlim,rerr,stepmx,ierr)
     call fstofd (n, x, fcn, f, g, typsiz, sqrnf)
     call opstp (n,x,f,g,wrk1,itncnt,icscmx,ierr,gradtl,steptl, &
                 typsiz,fscale,itnlim,iretcd,mxtake,fstack,ns,sptr)
     if (ierr /= 0) go to 210
!
!     the hessian will be obtained by secant updates.
!     set a to the initial hessian.
!
   10 nm1 = n - 1
  do 21 j = 1,nm1
     a(j,j) = 1.0/typsiz(j)
     jp1 = j + 1
     do 20 i = jp1,n
        a(i,j) = 0.0
   20    continue
   21 continue
  a(n,n) = 1.0/typsiz(n)
  go to 101
!
!
!     iteration
!
  100 if (mo > 1) go to 101
  if (mod(itncnt,10) /= 0) go to 101
  if (itncnt + 10 >= itnlim) go to 101
     call scalex (mo, x, typsiz, n, ierr)
     if (ierr == 0) go to 101
     mo = mo + 1
     return
  101 itncnt = itncnt + 1
!
!     solve  a*p = -g  for newton step
!
  105 do 110 i = 1,n
    wrk1(i) = -g(i)
  110 continue
  call lltslv(nr,n,a,p,wrk1)
!
!     take a step, arriving at the point xpls
!
  call lnsrch(n,x,f,g,p,xpls,fpls,fcn,mxtake,iretcd, &
              stepmx,steptl,typsiz)
!
!     if a satisfactory step could not be found and forward difference
!     gradient was used, retry using a central difference gradient.
!
  if (iretcd /= 1 .or. iagflg /= 0) go to 120
!
!        set iagflg for central differences
!
     iagflg = -1
     cbrnf = rnf**(1.0/3.0)
     call fstocd (n, x, fcn, typsiz, cbrnf, g)
     go to 105
!
!     calculate gradient at xpls
!
  120 if (iagflg == 0) go to 130
     call fstocd (n, xpls, fcn, typsiz, cbrnf, gpls)
     go to 140
  130 call fstofd (n, xpls, fcn, fpls, gpls, typsiz, sqrnf)
!
!     check whether the stopping criteria satisfied
!
  140 call opstp (n,xpls,fpls,gpls,x,itncnt,icscmx,ierr,gradtl,steptl, &
              typsiz,fscale,itnlim,iretcd,mxtake,fstack,ns,sptr)
  if (ierr /= 0) go to 200
!
!     evaluate hessian at xpls
!
  call secfac(nr,n,x,g,a,xpls,gpls,itncnt,sqrnf, &
                 noupdt,wrk0,wrk1,wrk2)
!
!     update f, x, and g
!
  f = fpls
  do 160 i = 1,n
    x(i) = xpls(i)
    g(i) = gpls(i)
  160 continue
  go to 100
!
!     termination
!
!     reset xpls,fpls,gpls  if previous iterate solution
!
  200 if (ierr /= 3) return
!
  210 fpls = f
  do 220 i = 1,n
     xpls(i) = x(i)
     gpls(i) = g(i)
  220 continue
  return
end
subroutine optf (fcn,n,rerr,iter,xpls,fpls,ierr,wrk)
!
!*******************************************************************************
!
!! OPTF: interface to minimization package
!
!     input ...
!
!       fcn        name of routine to evaluate minimization function.
!                  must be declared external in calling routine.
!       n          dimension of problem
!       rerr       relative accuracy of subroutine fcn.
!
!     input/output ...
!
!       iter       on input iter is the maximum number of iterations
!                  that are permitted. on output iter is the number
!                  of iterations that were actually performed.
!       xpls(n)    local minimum
!
!     output ...
!
!       fpls       function value at local minimum xpls
!       ierr       termination code
!
!     workspace ...
!
!       wrk(n,n+8)
!
  real xpls(n), wrk(n,*)
  external fcn
!
!     equivalence wrk(n,1) = x(n)
!                 wrk(n,2) = typsiz(n)
!                 wrk(n,3) = gpls(n)
!                 wrk(n,4) = g(n)
!                 wrk(n,5) = p(n)
!                 wrk(n,6) = wrk0(n)
!                 wrk(n,7) = wrk1(n)
!                 wrk(n,8) = wrk2(n)
!                 wrk(n,9) = a(n,n)
!
!
!     set tolerances
!
  eps = max (  epsilon ( eps ),abs(rerr))
  gradtl = eps**0.4
  stepmx = 0.0
  steptl = eps
  if (eps <= 1.e-10) steptl = 10.0*eps
  if (eps < 1.e-13) steptl = 1.e2*eps
!
!     initialization
!
  mo = 0
  itnlim = iter
  iter = 0
  do 10 i = 1,n
     wrk(i,1) = xpls(i)
     wrk(i,2) = 1.0
   10 continue
  fscale = 1.0
!
!     optimize fcn
!
   20 call optdrv(mo,n,n,wrk(1,1),fcn,wrk(1,2),fscale,rerr, &
       itnlim,itncnt,gradtl,stepmx,steptl,xpls,fpls,wrk(1,3), &
       ierr,wrk(1,9),wrk(1,4),wrk(1,5),wrk(1,6),wrk(1,7), &
       wrk(1,8))
  iter = iter + itncnt
  if (ierr /= -10) return
  itnlim = itnlim - itncnt
  go to 20
end
subroutine orimp(m, n, a, ka, qr, ms, s, ip, b, x, r, exit)
!
!*******************************************************************************
!
!! ORIMP improves an approximate least squares solution of a linear system.
!
!      purpose
!        given an approximate least squares solution x of a linear
!        system ax = b obtained using orsol. orimp attempts to compute
!        an improved solution correct to machine precision.
!
!      control
!
!        dimension a(ka,n), qr(ms,n), b(m), x(m), r(m), s(n), ip(n)
!        logical exit
!        .
!        .
!        .
!        call orimp(m, n, a, ka, qr, ms, s, ip, b, x, r, exit)
!
!        where
!        m    is an integer input variable, the number of rows of a.
!        n    is an integer input variable, the number of columns of a
!             (1 < n <= m).
!        a    is a real input array, the given m by n matrix.
!        qr   is a real input array, the orthogonal and triangular
!             factors of a produced by ortho.
!        b    is a real input array, the right hand side of ax = b.
!        x    as a real input array is the approximate least squares
!             solution together with the residual information produced
!             by orsol.
!        x    as a real output array is the improved least squares
!             solution with a residual of minimum length.
!        r    is a real output array, the correction vector added to x.
!        ka   is an integer input variable, the leading dimension of
!             of a in the calling program.
!        ms   is an integer input variable, the leading dimension of
!             of qr in the calling program.
!        s    is a real input array, a relevant part of q produced by
!             ortho.
!        ip   is an integer input array, the permutation information
!             produced by ortho.
!        exit is set to the value .true. if improvement of x is success-
!             ful with a gain in accuracy of at least 50 per cent each
!             iteration and .false. otherwise.
!
!      method
!        orimp executes the iteration cycle
!              (1)  ar = b - ax
!              (2)  x = x + r
!        with a given initial x.  the residual vector b - ax is computed
!        to high accuracy by double precision.  orsol is then used to
!        solve (1).
!
  dimension a(ka,n), qr(ms,n), b(m), x(m), r(m), s(n), ip(n)
  logical exit
  double precision dsum
  data zero/0.0/, one/1.0/, four/4.0/, fourth/0.25/
!
  eps = epsilon ( eps )

  exit = .true.
  np1 = n + 1
  eps2 = eps*eps
!
  xnrm2 = zero
  do 10 i = 1,n
   10 xnrm2 = xnrm2 + x(i)*x(i)
  if (xnrm2 == zero) return
  ratio = one
!
!                                       find the residual vector.
!
   20 do 22 k = 1,m
  dsum = b(k)
  do 21 j = 1,n
   21 dsum = dsum - dble(a(k,j))*dble(x(j))
   22 r(k) = dsum
!
!                                       find the correction vector.
!
  call orsol(m, n, qr, ms, s, ip, r)
  rnrm2 = zero
  do 30 k = 1,n
   30 rnrm2 = rnrm2 + r(k)*r(k)
  if (rnrm2 <= eps2*xnrm2) return
!
!                                       form new approximate solution.
!
  do 40 k = 1,n
   40 x(k) = x(k) + r(k)
  xnrm2 = zero
  do 41 k = 1,n
   41 xnrm2 = xnrm2 + x(k)*x(k)
  if (m == n) go to 50
  do 42 k = np1,m
   42 x(k) = r(k)
!
   50 if (xnrm2 == zero) return
  rat = ratio
  ratio = rnrm2/xnrm2
  if (ratio <= fourth*rat) go to 20
!
  if (ratio <= amin1(rat,four*eps2)) return
  exit = .false.
  return
end
subroutine orsol(m, n, qr, ms, s, ip, x)
!
!*******************************************************************************
!
!! ORSOL computes the least squares solution of a factored linear system.
!
!
!      identification
!        orsol - least squares solution of a linear system given an
!                orthogonal-triangular factorization of the coefficient
!                matrix produced by subroutine ortho
!        fortran subroutine subprogram
!        aerospace research laboratories
!        wright-patterson afb, ohio  45433
!      purpose
!        orsol computes the least squares solution of the linear system
!        qrx = pax = b where q, r, and p are determined from a by ortho.
!      control
!
!        dimension qr(ms,n), s(n), ip(n), x(m)
!        .
!        .
!        .
!        call orsol(m, n, qr, ms, s, ip, x)
!
!        where
!        m  is an integer input variable, the number of rows of a.
!        n  is an integer input variable, the number of columns of a
!             (1 < n <= m).
!        qr is a real input array, the orthogonal and triangular factors
!           of a produced by ortho.
!        ms is an integer input variable, the leading dimension of
!           qr in the calling program.
!        s  is a real input array, the relevant parts of q produced by
!           ortho.
!        ip is an integer input array, the permutation information
!           produced by ortho.
!        x  as a real input array is the right-hand side b of ax = b.
!        x  as a real output array is x(i), i = 1, ..., n, the least
!           squares solution, and x(j), j = n+1, ..., m, the vector
!           whose length is the minimum of all residual b - ax.
!      method
!        the factored system qrx = pax = pb are solved in the sequence
!        of qy = pb and rx = y. full rank for the matrix a is assumed
!        which can be checked by interrogating the logical output
!        variable produced by ortho.
!      references
!        (1) peter businger and g.h. golub, linear least squares solu-
!            tions by householder transformations, numer. math. 7(1965),
!            269-276.
!        (2) n.k. tsao and p.j. nikolai, procedures using orthogonal
!            transformations for linear least squares problems, arl
!            technical report arl tr 74-0124(1974).
!
  dimension qr(ms,n), s(n), ip(n), x(m)
!
  nn = n
  if (n == m) nn = n - 1
  do 30 j = 1, nn
    jp = j + 1
    ij = ip(j)
    y = 1.0 - s(j)
    sav = x(j)
    x(j) = x(ij)
    x(ij) = sav
!                                       premultiply x with the j-th
!                                       orthogonal matrix.
    sav = x(j)
    do 10 k = jp, m
   10     sav = sav + qr(k,j)*x(k)
    ss = x(j)
    x(j) = sav/s(j)
    ss = (ss - x(j))/y
    do 20 k = jp, m
   20     x(k) = x(k) - qr(k,j)*ss
   30 continue
!                                       back substitute to find the
!                                       least squares solution.
  x(n) = x(n)/qr(n,n)
  nm = n - 1
  do 50 i = 1, nm
    ni = n - i
    nn = n
    do 40 j = 1, i
      x(ni) = x(ni) - qr(ni,nn)*x(nn)
   40     nn = nn - 1
    x(ni) = x(ni)/qr(ni,ni)
   50 continue
  return
end
subroutine orthes(nm,n,low,igh,a,ort)
!
!*******************************************************************************
!
!! ORTHES reduces a matrix to upper hessenberg form.
!
!     given a real general matrix, this subroutine
!     reduces a submatrix situated in rows and columns
!     low through igh to upper hessenberg form by
!     orthogonal similarity transformations.
!
!     this subroutine is a translation of the algol procedure orthes,
!     num. math. 12, 349-368(1968) by martin and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains the input matrix.
!
!     on output-
!
!        a contains the hessenberg matrix.  information about
!          the orthogonal transformations used in the reduction
!          is stored in the remaining triangle under the
!          hessenberg matrix,
!
!        ort contains further information about the transformations.
!          only elements low through igh are used.
!
  integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low
  real a(nm,n),ort(igh)
  real f,g,h,scale
!
  la = igh - 1
  kp1 = low + 1
  if (la < kp1) go to 200
!
  do 180 m = kp1, la
     h = 0.0
     ort(m) = 0.0
     scale = 0.0
!   scale column (algol tol then not needed)
     do 90 i = m, igh
   90    scale = scale + abs(a(i,m-1))
!
     if (scale == 0.0) go to 180
     mp = m + igh
!  for i=igh step -1 until m do --
     do 100 ii = m, igh
        i = mp - ii
        ort(i) = a(i,m-1) / scale
        h = h + ort(i) * ort(i)
  100    continue
!
     g = sqrt(h)
     if (ort(m) >= 0.0) g = -g
     h = h - ort(m) * g
     ort(m) = ort(m) - g
!  form (i-(u*ut)/h) * a
     do 130 j = m, n
        f = 0.0
!  for i=igh step -1 until m do --
        do 110 ii = m, igh
           i = mp - ii
           f = f + ort(i) * a(i,j)
  110       continue
!
        f = f / h
!
        do 120 i = m, igh
  120       a(i,j) = a(i,j) - f * ort(i)
!
  130    continue
!  form (i-(u*ut)/h)*a*(i-(u*ut)/h)
     do 160 i = 1, igh
        f = 0.0
!  for j=igh step -1 until m do --
        do 140 jj = m, igh
           j = mp - jj
           f = f + ort(j) * a(i,j)
  140       continue
!
        f = f / h
!
        do 150 j = m, igh
  150       a(i,j) = a(i,j) - f * ort(j)
!
  160    continue
!
     ort(m) = scale * ort(m)
     a(m,m-1) = scale * g
  180 continue
!
  200 return
end
subroutine orthg (usol,idmn,zn,zm,pertrb)
!
!*******************************************************************************
!
!! ORTHG orthogonalizes the array usol with respect to
!     the constant array in a weighted least squares norm
!
  dimension       usol(idmn,*)           ,zn(*)      ,zm(*)
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
  istr = is
  ifnl = ms
  jstr = js
  jfnl = ns
!
!     compute weighted inner products
!
  ute = 0.0
  ete = 0.0
  do  20 i=is,ms
     ii = i-is+1
     do  10 j=js,ns
        jj = j-js+1
        ete = ete+zm(ii)*zn(jj)
        ute = ute+usol(i,j)*zm(ii)*zn(jj)
   10    continue
   20 continue
!
!     set perturbation parameter
!
  pertrb = ute/ete
!
!     subtract off constant pertrb
!
  do  40 i=istr,ifnl
     do  30 j=jstr,jfnl
        usol(i,j) = usol(i,j)-pertrb
   30    continue
   40 continue
  return
end
subroutine ortho(m, n, qr, ms, s, ip, exit)
!
!*******************************************************************************
!
!! ORTHO orthogonally transforms an m by n matrix to upper triangular form.
!
!        fortran subroutine subprogram
!        aerospace research laboratories
!        wright-patterson afb, ohio  45433
!      purpose
!        ortho computes an implicit orthogonal matrix q and an explicit
!        upper triangular matrix r and a permutation matrix p satisfying
!        qr = pa given an m by n real matrix a.  ortho is intended for
!        use with the subroutine orsol to produce the least squares
!        solution of the equation ax = b.
!      control
!
!        dimension qr(ms,n), s(n), ip(n)
!        logical exit
!        .
!        .
!        .
!        call ortho(m, n, qr, ms, s, ip, exit)
!
!        where
!        m    is an integer input variable, the number of rows of a.
!        n    is an integer input variable, the number of columns of a,
!             (1 < n <= m).
!        qr   as a real input array is matrix a to be triangularized.
!        qr   as a real output array is the upper triangular factor r in
!             qr(i,j), i <= j, and the relevant parts of q in qr(i,j),
!             i > j.
!        ms   is an integer input variable, the leading dimension of
!             qr in the calling program.
!        s    is a real output array, the relevant parts of q.
!        ip   is an integer output array containing in ip(i), i=1,...,n,
!             the images of the permutation corresponding to the permu-
!             tation matrix p.
!        exit is set to the value .true. if the rank of a is equal to n
!             and .false. otherwise.
!      method
!        the matrix a in the array qr is reduced to upper triangular
!        form using orthogonal transformation with partial pivoting.
!      references
!        (1) peter businger and g.h. golub, linear least squares solu-
!            tions by householder transformations, numer. math. 7(1965),
!            269-276.
!        (2) n.k. tsao and p.j. nikolai, procedures using orthogonal
!            transformations for linear least squares problems, arl
!            technical report arl tr 74-0124(1974).
!
  dimension qr(ms,n), s(n), ip(n)
  logical exit
!
  exit = .true.
  nn = n
  if (n == m) nn = n - 1
  do 80 j = 1, nn
    ip(j) = j
    jp = j + 1
    kj = j
!                                       search for pivot in the j-th
!                                       column and interchange rows.
    do 10 k = jp, m
       if (abs(qr(k,j)) > abs(qr(kj,j))) kj = k
   10   continue
    if (qr(kj,j) == 0.0) go to 90
    if (kj == j) go to 30
    ip(j) = kj
    do 20 i = j, n
       sav = qr(j,i)
       qr(j,i) = qr(kj,i)
   20      qr(kj,i) = sav
!  normalize the pivoting column and find its norm.
   30   ajj = qr(j,j)
    do 31 i = jp, m
   31      qr(i,j) = qr(i,j)/ajj
    sav = 1.0
    do 40 i = jp, m
   40      sav = sav + qr(i,j)*qr(i,j)
    s(j) = -sqrt(sav)
    qr(j,j) = s(j)*ajj
    if (jp > n) go to 80
!                                       premultiply qr with the j-th
!                                       orthogonal matrix.
    y = 1.0 - s(j)
    do 70 k = jp, n
       sav = qr(j,k)
       do 50 i = jp, m
   50         sav = sav + qr(i,j)*qr(i,k)
       ss = qr(j,k)
       qr(j,k) = sav/s(j)
       ss = (ss - qr(j,k))/y
       do 60 i = jp, m
   60         qr(i,k) = qr(i,k) - qr(i,j)*ss
   70   continue
   80 continue
  return
!
   90 exit = .false.
  return
end
subroutine orthos (au, ma, aa, na, ar)
!
!*******************************************************************************
!
!! ORTHOS: orthonormal polynomial synthesis
!
!     au = coordinate arguments    (n array)
!     ma = number of columns       (m)
!     aa = matrix of polynomials   (nxm array)
!     na = number of rows          (n)
!     ar = recurrence coefficients (2*m-2 array)
!
  dimension au(*), aa(*), ar(*)
  001 sn=na
  rn=sqrt(sn)
  do 002 i=1,na
  aa(i)=1.0/rn
  002 continue
  if(ma==1)return
  003 sm=0.0
  do 004 i=1,na
  sm=sm+au(i)
  004 continue
  ar(2)=sm/sn
  sm=0.0
  l=na
  do 005 i=1,na
  l=l+1
  aa(l)=au(i)-ar(2)
  sm=sm+aa(l)*aa(l)
  005 continue
  rm=sqrt(sm)
  l=na
  do 006 i=1,na
  l=l+1
  aa(l)=aa(l)/rm
  006 continue
  sm=0.0
  l=na
  do 007 i=1,na
  l=l+1
  sm=sm+au(i)*aa(l)
  007 continue
  ar(1)=sm/rn
  if(ma==2)return
  008 do 013 m=3,ma
  sm=0.0
  k=(m-2)*na
  do 009 i=1,na
  k=k+1
  sm=sm+au(i)*aa(k)*aa(k)
  009 continue
  ar(2*m-2)=sm
  sm=0.0
  j=(m-3)*na
  do 010 i=1,na
  j=j+1
  k=j+na
  l=k+na
  aa(l)=au(i)*aa(k)-ar(2*m-2)*aa(k)-ar(2*m-5)*aa(j)
  sm=sm+aa(l)*aa(l)
  010 continue
  rm=sqrt(sm)
  l=(m-1)*na
  do 011 i=1,na
  l=l+1
  aa(l)=aa(l)/rm
  011 continue
  sm=0.0
  k=(m-2)*na
  do 012 i=1,na
  k=k+1
  l=k+na
  sm=sm+au(i)*aa(k)*aa(l)
  012 continue
  ar(2*m-3)=sm
  013 continue
  return
end
subroutine orthov (mo, na, au, ar, nf, ff, df, sf)
!
!*******************************************************************************
!
!! ORTHOV: orthonormal polynomial evaluation
!
!     mo = mode of operation
!     na = number of coordinates
!     au = argument of functions
!     ar = recurrence coefficients                (2*m-2 array)
!     nf = number of functions                    (m)
!     ff = orthonormal functions                  (m-array)
!     df = first derivatives                      (m-array)
!     sf = second derivatives                     (m-array)
!
!     call orthov (0, na, au, ar, nf, ff)         for functions
!     call orthov (1, na, au, ar, nf, ff, df)     for first derivatives
!     call orthov (2, na, au, ar, nf, ff, df, sf) for second derivatives
!
  dimension ar(*), ff(*), df(*), sf(*)
  001 sn=na
  rn=sqrt(sn)
  ff(1)=1.0/rn
  if(nf <= 1)go to 003
  ff(2)=(au-ar(2))*ff(1)/ar(1)
  if(nf==2)go to 003
  l=2
  do 002 k=3,nf
  l=l+2
  ff(k)=((au-ar(l))*ff(k-1)-ar(l-3)*ff(k-2))/ar(l-1)
  002 continue
  003 if(mo <= 0)return
  df(1)=0.0
  if(nf <= 1)go to 005
  df(2)=ff(1)/ar(1)
  if(nf==2)go to 005
  l=2
  do 004 k=3,nf
  l=l+2
  df(k)=(ff(k-1)+(au-ar(l))*df(k-1)-ar(l-3)*df(k-2))/ar(l-1)
  004 continue
  005 if(mo==1)return
  sf(1)=0.0
  if(nf <= 1)go to 007
  sf(2)=0.0
  if(nf==2)go to 007
  l=2
  do 006 k=3,nf
  l=l+2
  sf(k)=(2.0*df(k-1)+(au-ar(l))*sf(k-1)-ar(l-3)*sf(k-2))/ar(l-1)
  006 continue
  007 return
end
subroutine orthox (na, ar, nc, ac)
!
!*******************************************************************************
!
!! ORTHOX: orthonormal polynomial expansion
!
!     na = number of arguments     (n)
!     ar = recurrence coefficients (2*m-2 array)
!     nc = number of coefficients  (m)
!     ac = polynomial coefficients (m*m array)
!
  dimension ar(*), ac(*)
  001 do 002 n=1,nc
  ac(n)=0.0
  002 continue
  sn=na
  rn=sqrt(sn)
  ac(1)=1.0/rn
  if(nc==1)return
  003 tm=0.0
  l=nc
  do 004 n=1,nc
  l=l+1
  ac(l)=(tm-ar(2)*ac(n))/ar(1)
  tm=ac(n)
  004 continue
  if(nc==2)return
  005 do 007 m=3,nc
  tm=0.0
  j=(m-3)*nc
  do 006 n=1,nc
  j=j+1
  k=j+nc
  l=k+nc
  ac(l)=(tm-ar(2*m-2)*ac(k)-ar(2*m-5)*ac(j))/ar(2*m-3)
  tm=ac(k)
  006 continue
  007 continue
  return
end
subroutine ortran(nm,n,low,igh,a,ort,z)
!
!*******************************************************************************
!
!! ORTRAN accumulates the orthogonal similarity
!     transformations used in the reduction of a real general
!     matrix to upper hessenberg form by  orthes.
!
!     this subroutine is a translation of the algol procedure ortrans,
!     num. math. 16, 181-204(1970) by peters and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction by  orthes
!          in its strict lower triangle,
!
!        ort contains further information about the trans-
!          formations used in the reduction by  orthes.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by  orthes,
!
!        ort has been altered.
!
!-----------------------------------------------------------------------
!
  integer i,j,n,kl,mm,mp,nm,igh,low,mp1
  real a(nm,igh),ort(igh),z(nm,n)
  real g
!
!  initialize z to identity matrix.
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.0
!
     z(i,i) = 1.0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!  for mp=igh-1 step -1 until low+1 do --
  do 140 mm = 1, kl
     mp = igh - mm
     if (a(mp,mp-1) == 0.0) go to 140
     mp1 = mp + 1
!
     do 100 i = mp1, igh
  100    ort(i) = a(i,mp-1)
!
     do 130 j = mp, igh
        g = 0.0
!
        do 110 i = mp, igh
  110       g = g + ort(i) * z(i,j)
!  divisor below is negative of h formed in orthes.
!                double division avoids possible underflow.
        g = (g / ort(mp)) / a(mp,mp-1)
!
        do 120 i = mp, igh
  120       z(i,j) = z(i,j) + g * ort(i)
!
  130    continue
!
  140 continue
!
  200 return
end
subroutine ortrn1(n,low,igh,a,na,z,nz,ort)
!
!*******************************************************************************
!
!! ORTRN1 accumulates the orthogonal similarity
!     transformations used in the reduction of a real general
!     matrix to upper hessenberg form by  orthes.
!
!     this subroutine is a translation of the algol procedure ortrans,
!     num. math. 16, 181-204(1970) by peters and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
!
!     on input-
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n,
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction by  orthes
!          in its strict lower triangle,
!
!        na must be set to the row dimension of the 2-dimensional
!          array parameter  a  as declared in the calling program
!          dimension statement,
!
!        nz must be set to the row dimension of the 2-dimensional
!          array parameter  z  as declared in the calling program
!          dimension statement,
!
!        ort contains further information about the trans-
!          formations used in the reduction by  orthes.
!          only elements low through igh are used.
!
!     on output-
!
!        z contains the transformation matrix produced in the
!          reduction by  orthes,
!
!        ort has been altered.
!
  integer i,j,n,kl,mm,mp,na,igh,low,mp1,nz
  real a(na,igh),ort(igh),z(nz,n)
  real g
!-----------------------------------------------------------------------
!
! initialize z to identity matrix.
  do 80 i = 1, n
!
     do 60 j = 1, n
   60    z(i,j) = 0.0
!
     z(i,i) = 1.0
   80 continue
!
  kl = igh - low - 1
  if (kl < 1) go to 200
!  for mp=igh-1 step -1 until low+1 do --
  do 140 mm = 1, kl
     mp = igh - mm
     if (a(mp,mp-1) == 0.0) go to 140
     mp1 = mp + 1
!
     do 100 i = mp1, igh
  100    ort(i) = a(i,mp-1)
!
     do 130 j = mp, igh
        g = 0.0
!
        do 110 i = mp, igh
  110       g = g + ort(i) * z(i,j)
!  divisor below is negative of h formed in orthes.
!                double division avoids possible underflow.
        g = (g / ort(mp)) / a(mp,mp-1)
!
        do 120 i = mp, igh
  120       z(i,j) = z(i,j) + g * ort(i)
!
  130    continue
!
  140 continue
!
  200 return
end
subroutine padd (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! PADD: addition of real polynomials
!
  real a(*)
  real b(*)
  real c(*)
!
  la = 1
  lb = 1
  lc = 1
  do i = 1, n
     c(lc) = 0.0
     if (i <= l) c(lc) = a(la)
     if (i <= m) c(lc) = c(lc) + b(lb)
     la = la + ka
     lb = lb + kb
     lc = lc + kc
  end do

  return
end
subroutine parc (i,ii,ub,iflag,vb,lub,lj,li,f,bb,q,b,n,m,np1, &
                   lx,lxi,lr,lri,lubi)
!
!*******************************************************************************
!
!! PARC: parametric computation of the upper bounds.
!
  integer f(m),bb(m,n),q(m),b(np1),ub,vb,r,s
  integer lx(n),lxi(n)
!
  iflag = 0
  if ( b(lj) /= 0 ) go to 60
  i1 = i - 1
  if ( i1 < li ) go to 20
  iq = 0
  do 10 r=li,i1
    iq = iq + q(r)
   10 continue
  if ( iq > lr ) return
   20 r = ii
  s = f(r)
   30 if ( s /= (-1) ) go to 40
  r = r - 1
  s = f(r)
  go to 30
   40 if ( lx(s) == 0 ) return
  if ( s == lj ) go to 50
  s = bb(r,s)
  go to 30
   50 ub = lub - vb
  iflag = 1
  return
   60 i1 = i - 1
  if ( i1 < 1 ) go to 80
  iq = 0
  do 70 r=1,i1
    iq = iq + q(r)
   70 continue
  if ( iq > lri ) return
   80 do 90 j=1,n
    if ( b(j) == 1 ) go to 90
    if ( lxi(j) == 0 ) return
   90 continue
  ub = lubi - vb
  iflag = 1
  return
end
function parea ( x, y, nb )
!
!*******************************************************************************
!
!! PAREA computes the area bounded by a closed polygonal curve.
!
!
!  The curve passes
!  through a given sequence of nb points (x(i),y(i)) in the order that they are
!  indexed. the final point of the curve is assumed to be the first point
!  given. therefore, it need not be listed at the end of x and
!  y. the curve is not required to be simple.
!
  integer nb
!
  real parea
  real x(nb)
  real y(nb)
!
  n = nb
  if ( x(1) == x(n) .and. y(1) == y(n) ) then
    n = n - 1
  end if

  if ( n < 3 ) then
    parea = 0.0E+00
    return
  end if

  if ( n == 3 ) then
    parea= 0.5E+00 * ((x(2) - x(1))*(y(3) - y(1)) &
            - (x(3) - x(1))*(y(2) - y(1)))
    return
  end if

  a = x(1) * ( y(2) - y(n) ) + x(n) * ( y(1) - y(nm1) )
  do i = 2, n-1
    a = a + x(i)*(y(i+1) - y(i-1))
  end do

  parea = 0.5E+00 * a

  return
end
subroutine pchol (mo,n,m,a,b,kb,ierr)

!*****************************************************************************80
!
!! PCHOL: inverse of a positive definite symmetric matrix in packed form.
!
  real a(*), b(*), d(2)
  integer onej
!
!              matrix factorization
!
  call sppfa (a,n,ierr)
  if (ierr /= 0) return
!
!          solution of the equation ax=b
!
  onej = 1
  do j = 1,m
    call sppsl (a,n,b(onej))
    onej = onej + kb
  end do
!
!         computation of the inverse of a
!
  if ( mo == 0 ) then
    call sppdi (a,n,d,1)
  end if

  return
end
subroutine pcoeff(alpha,n,x,a,c,t)
!
!*******************************************************************************
!
!! PCOEFF ???
!
  real x(*),a(n),c(n)
  double precision xx,r,t(n)
  if (n > 1) go to 10
  c(1) = a(1)
  return
!
   10 xx = alpha
  nm1 = n-1
  do 11 i=1,n
   11 t(i) = a(i)
!
  do 21 i=1,nm1
  j = n-i
  r = xx-dble(x(j))
  do 20 k=j,nm1
   20 t(k) = t(k)+r*t(k+1)
   21 continue

  c(1:n) = t(1:n)

  return
end
subroutine pdedge (edge, indx, indy, ierr)
!
!*******************************************************************************
!
!! PDEDGE ???
!
  integer edge(4)
!
  if (iabs(edge(1)) > 1) go to 200
  if (iabs(edge(2)) > 1) go to 200
  if (iabs(edge(3)) > 1) go to 200
  if (iabs(edge(4)) > 1) go to 200
  ierr = 0
!
!               process edges 1 and 3
!
  if (edge(1)) 10,20,30
!
   10 if (edge(3) /= -1) go to 210
  indy = 0
  go to 100
!
   20 if (edge(3) == -1) go to 210
  indy = 1 + edge(3)
  go to 100
!
   30 if (edge(3) == -1) go to 210
  indy = 4 - edge(3)
!
!               process edges 2 and 4
!
  100 if (edge(2)) 110,120,130
!
  110 if (edge(4) /= -1) go to 220
  indx = 0
  return
!
  120 if (edge(4) == -1) go to 220
  indx = 1 + edge(4)
  return
!
  130 if (edge(4) == -1) go to 220
  indx = 4 - edge(4)
  return
!
!                   error return
!
  200 ierr = 2
  return
  210 ierr = 12
  return
  220 ierr = 13
  return
end
subroutine pdiv (a,ka,l,b,kb,m,c,kc,n,ierr)
!
!*******************************************************************************
!
!! PDIV: division of real polynomials
!
  real a(*), b(*), c(*)
  double precision dsum
!
  b0 = b(1)
  if (b0 == 0.0) go to 100
  ierr = 0
  c(1) = a(1)/b0
  if (n == 1) return
!
!               case when m = 1
!
  if (m > 1) go to 20
  la = 1
  lc = 1
  do 10 j = 2,n
     la = la + ka
     lc = lc + kc
     c(lc) = 0.0
     if (j <= l) c(lc) = a(la)/b0
   10 continue
  return
!
!              case when m > 1
!
   20 la = 1
  lc = 1
  do 40 j = 2,n
     la = la + ka
     lc = lc + kc
     ib = 1
     ic = lc
     dsum = 0.d0
     if (j <= l) dsum = a(la)
     imax = min (j, m)
     do 30 i = 2,imax
        ib = ib + kb
        ic = ic - kc
        dsum = dsum - dble(b(ib))*dble(c(ic))
   30    continue
     c(lc) = sngl(dsum)/b0
   40 continue
  return
!
!                error return
!
  100 ierr = 1
  return
end
subroutine peq(z, w, ierr)
!
!*******************************************************************************
!
!! PEQ: weierstrass p-function in the equianharmonic case
!     for complex argument with unit period parallelogram
!
  complex z, z1, z4, z6, w
  real zr, zi
  integer ierr, m, n
!
!     reduction to fundamental parallelogram
!
  zi = 1.1547005383792515e0*aimag(z) + 0.5e0
  m = int(zi)
  if (zi < 0e0) m = m - 1
  zr = real(z) - 0.5e0*real(m) + 0.5e0
  n = int(zr)
  if (zr < 0e0) n = n - 1
  z1 = z - real(n) - (0.5e0,0.86602540378443865e0)*float(m)
!
!     if z1=0 then z coincides with a lattice point.
!     the lattice points are poles for p.
!
  w = z1*z1
  zr = abs(real(w)) + abs(aimag(w))
  if (zr/=0e0) go to 10
  ierr = 1
  return
!
!     evaluation of p(z1)
!
   10 ierr = 0
  z4 = w*w
  z6 = z4*w
  w = 1e0/w + 6e0*z4*(5e0+z6)/(1e0-z6)**2 + z4* &
   (((((-2.6427662e-10*z6+1.610954818e-8)*z6+7.38610752879e-6)* &
   z6+4.3991444671178e-4)*z6+7.477288220490697e-2)* &
   z6-6.8484153287299201e-1)/(((((6.2252191e-10*z6+2.553314573e-7)* &
   z6-2.619832920421e-5)*z6-5.6444801847646e-4)* &
   z6+4.565553484820106e-2)*z6+1e0)
  return
end
subroutine peq1(z, w, ierr)
!
!*******************************************************************************
!
!! PEQ1: first derivative of weierstrass p-function in the
!     equianharmonic case for complex argument
!     with unit period parallelogram
!
  complex z, z1, z3, z6, w
  real zr, zi
  integer ierr, m, n
!
!     reduction to fundamental parallelogram
!
  zi = 1.1547005383792515e0*aimag(z) + 0.5e0
  m = int(zi)
  if (zi < 0e0) m = m - 1
  zr = real(z) - 0.5e0*real(m) + 0.5e0
  n = int(zr)
  if (zr < 0e0) n = n - 1
  z1 = z - real(n) - (0.5e0,0.86602540378443865e0)*float(m)
!
!     if z1=0 then z coincides with a lattice point.
!     the lattice points are poles for dp.
!
  z3 = z1*z1*z1
  z6 = z3*z3
  w = z3*(1e0-z6)**3
  zr = abs(real(w)) + abs(aimag(w))
  if (zr/=0e0) go to 10
  ierr = 1
  return
!
!     evaluation of dp(z1)
!
   10 ierr = 0
  w = (((14e0*z6+294e0)*z6+126e0)*z6-2e0)/w + &
   z3*((((((-2.95539175e-9*z6-2.6764693031e-7)*z6+2.402192743346e-5) &
   *z6+1.9656661451391e-4)*z6+1.760135529461036e-2)* &
   z6+8.1026243498822636e-1)*z6-2.73936613149196804e0)/ &
   ((((((4.6397763e-10*z6+5.413482233e-8)*z6-1.56293298374e-6)* &
   z6-1.0393701076352e-4)*z6+9.5553182532237e-4)* &
   z6+9.131106969640212e-2)*z6+1e0)
  return
end
subroutine pfit(nd,np,x,y,a,rnorm,phi,phix,ierr)
!
!*******************************************************************************
!
!! PFIT: unweighted least squares polynomial fit
!
  real x(np),y(np),a(*),phi(2,*),phix(4,np)
  real lambda
  double precision dalpha,dsum
!
  ierr=0
  if (1 <= nd.and.nd < np) go to 10
  ierr=1
  return
!
!                      initialization
!
   10 nd1=nd+1
  do 11 k=1,nd1
  a(k)=0.0
  phi(1,k)=0.0
   11 phi(2,k)=0.0
!
!                set z=a+b*x where abs(z) <= 1
!
  xmin=x(1)
  xmax=x(1)
  do 21 k=2,np
  if (x(k) >= xmin) go to 20
  xmin=x(k)
  go to 21
   20 if (x(k) > xmax) xmax=x(k)
   21 continue
  zb=2.0/(xmax-xmin)
  za=-xmin*zb-1.0
  do 22 k=1,np
   22 phix(3,k)=za+zb*x(k)
!
!           compute the closest polynomial of degree 0
!
  lambda=np
  phi(1,1)=1.0/sqrt(lambda)
  dalpha=0.d0
  dsum=0.d0
  do 30 k=1,np
  phix(1,k)=phi(1,1)
  dalpha=dalpha+dble(phix(3,k))
   30 dsum=dsum+dble(y(k))
  alpha=sngl(dalpha)/lambda
  a(1)=sngl(dsum)/lambda
  do 31 k=1,np
   31 phix(4,k)=a(1)
!
  la=2
  lb=1
  do 90 m=1,nd
  mp1=m+1
!
!          generate lambda(m)*phi(m) and evaluate it at z
!
  if (m/=1) go to 50
  phi(2,1)=-alpha*phi(1,1)
  phi(2,2)=phi(1,1)
  do 40 k=1,np
   40 phix(2,k)=(phix(3,k)-alpha)*phi(1,1)
  go to 60
!
   50 c=0.0
  do 51 k=1,m
  phi(la,k)=dble(c)-dble(alpha*phi(lb,k))-dble(lambda*phi(la,k))
   51 c=phi(lb,k)
  phi(la,mp1)=c
  do 52 k=1,np
   52 phix(la,k)=(phix(3,k)-alpha)*phix(lb,k)-lambda*phix(la,k)
!
!                compute alpha(m) and lambda(m)
!
   60 dalpha=0.d0
  dsum=0.d0
  do 61 k=1,np
  c=phix(la,k)*phix(la,k)
  dalpha=dalpha+dble(c*phix(3,k))
   61 dsum=dsum+dble(c)
  lambda=dsum
  alpha=sngl(dalpha)/lambda
  lambda=sqrt(lambda)
!
!              generate phi(m) and evaluate it at z
!
  do 70 k=1,mp1
   70 phi(la,k)=phi(la,k)/lambda
  do 71 k=1,np
   71 phix(la,k)=phix(la,k)/lambda
!
!        compute the closest polynomial of degree m or less
!                     and evaluate it at z
!
  dsum=0.d0
  do 80 k=1,np
   80 dsum=dsum+dble((y(k)-phix(4,k))*phix(la,k))
  c=dsum
  do 81 k=1,mp1
   81 a(k)=a(k)+c*phi(la,k)
  do 82 k=1,np
   82 phix(4,k)=phix(4,k)+c*phix(la,k)
!
  ls=la
  la=lb
   90 lb=ls
!
!                        compute rnorm
!
  dsum=0.d0
  do 95 k=1,np
   95 dsum=dsum+dble((y(k)-phix(4,k))**2)
  rnorm=sqrt(sngl(dsum))
!
!        convert the closest polynomial from a polynomial
!                  in z to a polynomial in x
!
  a(1)=a(1)+za*a(2)
  a(2)=zb*a(2)
  if (nd==1) return
  phi(1,1)=za
  phi(1,2)=zb
  do 102 m=2,nd
  mp1=m+1
  c=0.0
  do 100 k=1,m
  temp=phi(1,k)*zb
  phi(1,k)=phi(1,k)*za+c
  100 c=temp
  phi(1,mp1)=c
  do 101 k=1,m
  101 a(k)=a(k)+a(mp1)*phi(1,k)
  102 a(mp1)=a(mp1)*phi(1,mp1)
  return
end
function pi ( )
!
!*******************************************************************************
!
!! PI returns the value of pi.
!
!
!  Modified:
!
!    04 December 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real PI, the value of pi.
!
  real pi
!
  pi = 3.14159265358979323846264338327950288419716939937510E+00

  return
end
subroutine pi1 (n,m,p,w,q,i,b,bb,kub,bl,lb,pbl,v,xl, &
                  np1,n5,bs,ps,ws,xs,iwk)
!
!*******************************************************************************
!
!! PI1 computes a feasible solution to the current knapsack problem.
!
!
!  the solution is stored in array  xl , the
!  corresponding value in  lb .
!
  integer m
  integer n
!
  integer bb(m,n)
  integer bl(m,np1),xl(m,n),iwk(n5)
  integer p(n),w(n),q(m),b(np1),pbl(m),v(m)
  integer bs(n),ps(np1),ws(np1),xs(n)
  integer pb,qs,sb,u
!
! step 1
!
  u = 0
  do 10 j=1,n
    if ( b(j) == 0 ) go to 10
    u = u + 1
    bs(u) = j
   10 continue
  do 20 j=i,m
    pbl(j) = 0
    v(j) = 0
   20 continue
  lb = 0
  ikub = kub
  if ( u == 0 ) return
  ns = 0
  sb = 0
  do 30 j=1,u
    jj = bs(j)
    if ( bb(i,jj) /= 0 ) go to 30
    if ( w(jj) > q(i) ) go to 30
    ns = ns + 1
    sb = sb + w(jj)
    bl(i,ns) = jj
    ps(ns) = p(jj)
    ws(ns) = w(jj)
   30 continue
  ii = i
!
! step 2
!
   40 pbl(ii) = ns
  if ( sb > q(ii) ) go to 60
  pb = 0
  if ( ns == 0 ) go to 80
  do 50 j=1,ns
    pb = pb + ps(j)
    xl(ii,j) = 1
   50 continue
  go to 80
   60 qs = q(ii)
  kub = 0
  if ( ii == m ) kub = ikub
  call sknp (ns,qs,kub,pb,n,np1,n5,ps,ws,xs,iwk)
  do 70 j=1,ns
    xl(ii,j) = xs(j)
   70 continue
   80 lb = lb + pb
  ikub = ikub - pb
  v(ii) = pb
  bl(ii,ns+1) = n + 1
!
! step 3
!
  if ( ii == m ) return
  jb = 1
  jbs = 0
  do 100 j=1,u
    if ( bs(j) < bl(ii,jb) ) go to 90
    jb = jb + 1
    if ( xl(ii,jb-1) == 1 ) go to 100
   90   jbs = jbs + 1
    bs(jbs) = bs(j)
  100 continue
  u = jbs
  if ( u == 0 ) return
  ns = 0
  sb = 0
  ii = ii + 1
  do 110 j=1,u
    jj = bs(j)
    if( w(jj) > q(ii) ) go to 110
    ns = ns + 1
    sb = sb + w(jj)
    bl(ii,ns) = jj
    ps(ns) = p(jj)
    ws(ns) =  w(jj)
  110 continue
  go to 40
end
subroutine pinv (a, d, n, q)
!
!*******************************************************************************
!
!! PINV: computation of the inverse of the power series
!                  sum (a(i)*x**i, i = 1,2,...)
!
  real a(n), d(n), q(*)
!
!     num = (n*(n + 1))/2
!     real q(num)
!
!
!                 compute the coefficient matrix q
!
  q(1) = 1.0
  k = 2
  do 10 i = 2,n
     q(k) = 0.0
   10 k = k + i
!
  jj = 1
  do 22 j = 2,n
     l0 = jj
     jj = (j*(j + 1))/2
     k = jj
     do 21 i = j,n
        sum = 0.0
        m = i - j + 2
        ll = l0
        do 20 l = j,i
           sum = sum + a(m)*q(ll)
           m = m - 1
           ll = ll + (l - 1)
   20       continue
        q(k) = sum
        k = k + i
   21    continue
   22 continue
!
!              compute the coefficients of the inverse
!
  k = 1
  do 31 j = 1,n
     u = 1.0/(j*a(1)**j)
     sum = 0.0
     do l = 1,j
        sum = sum + u*q(k)
        s = l + j - 1
        t = l
        u = -(s*u)/(t*a(1))
        k = k + 1
     end do
     d(j) = sum
   31 continue
  return
end
subroutine pjac (neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, &
     f, jac, rpar, ipar)
!
!*******************************************************************************
!
!! PJAC sets up the iteration matrix (involving the jacobian) for the
!   integration package sfode.
!
!***routines called  vnwrms,sgefa,sgbfa
!
  integer neq, nyh, iwm, i, i1, i2, ier, ii, iownd, iowns, j, j1, &
     jj, jstart, kflag, l, lenp, maxord, mba, mband, meb1, meband, &
     meth, miter, ml, ml3, mu, n, nfe, nje, nq, nqu, nst
  external f, jac
  real y, yh, ewt, ftem, savf, wm, &
     rownd, rowns, el0, h, hmin, hmxi, hu, tn, uround, &
     con, di, fac, hl0, r, r0, srur, yi, yj, yjj, vnwrms
  dimension         y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), &
     wm(*), iwm( *), rpar(*), ipar(*)
  common /debdf1/ rownd, rowns(210), &
     el0, h, hmin, hmxi, hu, tn, uround, iownd(14), iowns(6), &
     ier, jstart, kflag, l, meth, miter, maxord, n, nq, nst, nfe, &
     nje, nqu
!
! pjac is called by stod  to compute and process the matrix
! p = i - h*el(1)*j , where j is an approximation to the jacobian.
! here j is computed by the user-supplied routine jac if
! miter = 1 or 4, or by finite differencing if miter = 2, 3, or 5.
! if miter = 3, a diagonal approximation to j is used.
! j is stored in wm and replaced by p.  if miter /= 3, p is then
! subjected to lu decomposition in preparation for later solution
! of linear systems with p as coefficient matrix. this is done
! by sgefa if miter = 1 or 2, and by sgbfa if miter = 4 or 5.
!
! in addition to variables described previously, communication
! with pjac uses the following..
! y    = array containing predicted values on entry.
! ftem = work array of length n (acor in stod ).
! savf = array containing f evaluated at predicted y.
! wm   = real work space for matrices.  on output it contains the
!        inverse diagonal matrix if miter = 3 and the lu decomposition
!        of p if miter is 1, 2 , 4, or 5.
!        storage of matrix elements starts at wm(3).
!        wm also contains the following matrix-related data..
!        wm(1) = sqrt(uround), used in numerical jacobian increments.
!        wm(2) = h*el0, saved for later use if miter = 3.
! iwm  = integer work space containing pivot information, starting at
!        iwm(21), if miter is 1, 2, 4, or 5.  iwm also contains the
!        band parameters ml = iwm(1) and mu = iwm(2) if miter is 4 or 5.
! el0  = el(1) (input).
! ier  = output error flag,  = 0 if no trouble, /= 0 if
!        p matrix found to be singular.
! this routine also uses the common variables el0, h, tn, uround,
! miter, n, nfe, and nje.
!
  nje = nje + 1
  hl0 = h*el0
  go to (100, 200, 300, 400, 500), miter
! if miter = 1, call jac and multiply by scalar.
 100  lenp = n*n
  do 110 i = 1,lenp
 110    wm(i+2) = 0.0e0
  call jac (tn, y, wm(3), n, rpar, ipar)
  con = -hl0
  do 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
  go to 240
! if miter = 2, make n calls to f to approximate j.
 200  fac = vnwrms (n, savf, ewt)
  r0 = 1000.0e0*abs(h)*uround*real(n)*fac
  if (r0 == 0.0e0) r0 = 1.0e0
  srur = wm(1)
  j1 = 2
  do 230 j = 1,n
    yj = y(j)
    r = max ( srur*abs(yj),r0*ewt(j))
    y(j) = y(j) + r
    fac = -hl0/r
    call f (tn, y, ftem, rpar, ipar)
    do 220 i = 1,n
 220      wm(i+j1) = (ftem(i) - savf(i))*fac
    y(j) = yj
    j1 = j1 + n
 230    continue
  nfe = nfe + n
! add identity matrix.
 240  j = 3
  do 250 i = 1,n
    wm(j) = wm(j) + 1.0e0
 250    j = j + (n + 1)
! do lu decomposition on p.
  call sgefa (wm(3), n, n, iwm(21), ier)
  return
! if miter = 3, construct a diagonal approximation to j and p.
 300  wm(2) = hl0
  ier = 0
  r = el0*0.1e0
  do 310 i = 1,n
 310    y(i) = y(i) + r*(h*savf(i) - yh(i,2))
  call f (tn, y, wm(3), rpar, ipar)
  nfe = nfe + 1
  do 320 i = 1,n
    r0 = h*savf(i) - yh(i,2)
    di = 0.1e0*r0 - h*(wm(i+2) - savf(i))
    wm(i+2) = 1.0e0
    if (abs(r0) < uround*ewt(i)) go to 320
    if (abs(di) == 0.0e0) go to 330
    wm(i+2) = 0.1e0*r0/di
 320    continue
  return
 330  ier = -1
  return
! if miter = 4, call jac and multiply by scalar.
 400  ml = iwm(1)
  mu = iwm(2)
  ml3 =  3
  mband = ml + mu + 1
  meband = mband + ml
  lenp = meband*n
  do 410 i = 1,lenp
 410    wm(i+2) = 0.0e0
  call jac (tn, y, wm(ml3), meband, rpar, ipar)
  con = -hl0
  do 420 i = 1,lenp
 420    wm(i+2) = wm(i+2)*con
  go to 570
! if miter = 5, make mband calls to f to approximate j.
 500  ml = iwm(1)
  mu = iwm(2)
  mband = ml + mu + 1
  mba = min (mband,n)
  meband = mband + ml
  meb1 = meband - 1
  srur = wm(1)
  fac = vnwrms (n, savf, ewt)
  r0 = 1000.0e0*abs(h)*uround*real(n)*fac
  if (r0 == 0.0e0) r0 = 1.0e0
  do 560 j = 1,mba
    do 530 i = j,n,mband
      yi = y(i)
      r = max ( srur*abs(yi),r0*ewt(i))
 530      y(i) = y(i) + r
    call f (tn, y, ftem, rpar, ipar)
    do 550 jj = j,n,mband
      y(jj) = yh(jj,1)
      yjj = y(jj)
      r = max ( srur*abs(yjj),r0*ewt(jj))
      fac = -hl0/r
      i1 = max (jj-mu,1)
      i2 = min (jj+ml,n)
      ii = jj*meb1 - ml + 2
      do 540 i = i1,i2
 540        wm(ii+i) = (ftem(i) - savf(i))*fac
 550      continue
 560    continue
  nfe = nfe + mba
! add identity matrix.
 570  ii = mband + 2
  do 580 i = 1,n
    wm(ii) = wm(ii) + 1.0e0
 580    ii = ii + meband
! do lu decomposition of p.
  call sgbfa (wm(3), meband, n, ml, mu, iwm(21), ier)
  return
end
subroutine pkill(r,s1,s2,h,k,p)
!
!*******************************************************************************
!
!! PKILL: elliptical coverage function
!
     real k, k8, k9, n, x(43), y(43)
!
!        rt2 = sqrt(2)
!        rtpinv = 1/sqrt(pi)
!
     data rt2/1.4142135623731/
     data rtpinv/.56418958354776/
!
!        b = a1**2
!        c = 2*(1 - eps1)
!
     data a/4.892/, a1/5.387/, a2/3.8775/, a3/5.16/
     data err/1.e-6/, eps1/1.04e-8/
     data b/29.019769/, c/1.9999999792/
!
     data x(1)  /.238619186083197/
     data x(2)  /.661209386466265/
     data x(3)  /.932469514203152/
     data x(4)  /.183434642495650/
     data x(5)  /.525532409916329/
     data x(6)  /.796666477413627/
     data x(7)  /.960289856497536/
     data x(8)  /.125233408511469/
     data x(9)  /.367831498998180/
     data x(10) /.587317954286617/
     data x(11) /.769902674194305/
     data x(12) /.904117256370475/
     data x(13) /.981560634246719/
     data x(14) /9.50125098376374e-2/
     data x(15) /.281603550779259/
     data x(16) /.458016777657227/
     data x(17) /.617876244402644/
     data x(18) /.755404408355003/
     data x(19) /.865631202387831/
     data x(20) /.944575023073232/
     data x(21) /.989400934991649/
     data x(22) /7.65265211334973e-2/
     data x(23) /.227785851141645/
     data x(24) /.373706088715420/
     data x(25) /.510867001950827/
     data x(26) /.636053680726515/
     data x(27) /.746331906460151/
     data x(28) /.839116971822219/
     data x(29) /.912234428251326/
     data x(30) /.963971927277914/
     data x(31) /.993128599185095/
     data x(32) /6.40568928626056e-2/
     data x(33) /.191118867473616/
     data x(34) /.315042679696163/
     data x(35) /.433793507626045/
     data x(36) /.545421471388840/
     data x(37) /.648093651936976/
     data x(38) /.740124191578554/
     data x(39) /.820001985973903/
     data x(40) /.886415527004401/
     data x(41) /.938274552002733/
     data x(42) /.974728555971309/
     data x(43) /.995187219997021/
!
     data y(1)  /.467913934572691/
     data y(2)  /.360761573048139/
     data y(3)  /.171324492379170/
     data y(4)  /.362683783378362/
     data y(5)  /.313706645877887/
     data y(6)  /.222381034453374/
     data y(7)  /.101228536290376/
     data y(8)  /.249147045813403/
     data y(9)  /.233492536538355/
     data y(10) /.203167426723066/
     data y(11) /.160078328543346/
     data y(12) /.106939325995318/
     data y(13) /4.7175336386512e-2/
     data y(14) /.189450610455068/
     data y(15) /.182603415045924/
     data y(16) /.169156519395003/
     data y(17) /.149595988815577/
     data y(18) /.124628971255534/
     data y(19) /9.51585116824928e-2/
     data y(20) /6.22535239386479e-2/
     data y(21) /2.71524594117541e-2/
     data y(22) /.152753387131726/
     data y(23) /.149172986472604/
     data y(24) /.142096109318382/
     data y(25) /.131688638449177/
     data y(26) /.118194531961518/
     data y(27) /.101930119817240/
     data y(28) /8.32767415767047e-2/
     data y(29) /6.26720483341091e-2/
     data y(30) /4.06014298003869e-2/
     data y(31) /1.76140071391521e-2/
     data y(32) /.127938195346752/
     data y(33) /.125837456346828/
     data y(34) /.121670472927803/
     data y(35) /.115505668053726/
     data y(36) /.107444270115966/
     data y(37) /9.76186521041139e-2/
     data y(38) /8.61901615319533e-2/
     data y(39) /7.334648141108031e-2/
     data y(40) /5.92985849154368e-2/
     data y(41) /4.42774388174198e-2/
     data y(42) /2.85313886289337e-2/
     data y(43) /1.23412297999872e-2/
!
!
!                  check if p=0 or p=1
!
     p = 0.0
     tol = err*s1*s2
     rr = r*r
     if (rr <= tol) return
!
     h2 = h*h + k*k
     d  = max ( s1,s2)
     t  = r - a1*d
     if (t < 0.0) go to 10
          if (t*t < h2) go to 10
               p = 1.0
               return
!
   10    h8 = abs(h)
     k8 = abs(k)
     if (r + a*s1 <= h8) return
     if (r + a*s2 <= k8) return
     s0 = sqrt(h2)
     if (s1 /= s2) go to 20
          h8 = s0
          k8 = 0.0
          if (r + a*s1 <= h8) return
!
   20    if (s0 <= r) go to 50
          d = (s0 - r)/d
          if (rr*exp(-0.5*d*d) <= tol) return
          if (s0 < r + a1*amin1(s1,s2)) go to 50
!
     if (h8*k8 == 0.0) go to 50
     h9 = h8/s1
     k9 = k8/s2
     d = h9*h9 + k9*k9
     if (d <= b) go to 50
!
     q = (s2/s1)**2
     f = q*h9*h9 + k9*k9
     z1 = (f/d)*(r/s2)**2
     z = d - z1 - b
     if (z <= 0.0) go to 30
     if (z*z >= 4.0*b*z1) return
!
   30    z1 = b*s1*s1*(h*h + q*k*k)/h2
     z = h2 - rr - z1
     if (z <= 0.0) go to 50
     if (z*z >= 4.0*rr*z1) return
!
!             find the limits of integration
!
   50    z  = k8 + a3 * s2
     u  = k8 - a3 * s2
     s0 = s1
     s  = s2
     i  = 0
!
   60    z  = r - z
     e0 = 0.0
     if (z > 0.0) e0 = sqrt(z/r)
     if (u >= 0.0) go to 61
          e  = 1.0 - e0
          h5 = 0.0
          go to 70
   61    e  = sqrt(1.0 - u/r) - e0
     h5 = 1.0
!
   70    if (i /= 0) go to 80
          i  = 1
          t  = e0
          f  = e
          h6 = h5
          z  = h8 + a3 * s1
          u  = h8 - a3 * s1
          go to 60
!
   80    if (f >= e) go to 100
          e0 = t
          e  = f
          t  = h8
          h8 = k8
          k8 = t
          h5 = h6
          s0 = s2
          s  = s1
!
!        select the appropriate integration process
!
  100    e = 0.5*e
     n = e*r*(0.34/s0 + 1.0/(.025*abs(r-k8) + 5.0*s))
     if (n < 2.75) go to 101
          j  = 31
          n1 = 12
          go to 110
  101    if (n < 1.35) go to 102
          j  = 21
          n1 = 10
          go to 110
  102    if (n < 0.75) go to 103
          j  = 13
          n1 =  8
          go to 110
  103    if (n < 0.35) go to 104
          j  =  7
          n1 =  6
          go to 110
  104    if (n < 0.15) go to 105
          j  =  3
          n1 =  4
          go to 110
  105    j  = 0
     n1 = 3
!
!              perform gaussian integration
!
  110    m  = n1 + n1
     r8 = r/(rt2*s0)
     h8 = h8/(rt2*s0)
     rr = r/(rt2*s)
     k8 = k8/(rt2*s)
     q  = rtpinv*e*r8
     i  = -n1
     z  = 0.0
     sum = 0.0
     if (k8 == 0.0) go to 200
!
     do 170 l = 1,m
     if (i == 0) i = 1
          ii = j + iabs(i)
          t  = e*(1.0 + sign(x(ii),real(i))) + e0
          tt = t*t
          d  = r8*(1.0 - tt)
          u  = h8 - d
          f  = exp(-u*u)
!
          if (h8 /= 0.0) go to 120
               f = f + f
               go to 130
  120         if (h5 /= 0.0) go to 130
               u = h8 + d
               f = f + exp(-u*u)
!
  130         if (z == 0.0) go to 140
               p = c
               go to 161
!
  140         d = rr*t*sqrt(2.0 - tt)
          u = k8 - d
          if (abs(u) < a2) go to 150
          if (u > 0.0) go to 170
               p = c
               z = 1.0
               go to 161
!
  150         p = erfc2(u)
          u = k8 + d
          if (u < a2) go to 160
               p = p - eps1
               go to 161
!
  160         p = p - erfc2(u)
  161         sum = sum + f*p*t*y(ii)
  170    i = i + 1
     p = q*sum
     return
!
  200    do 250 l = 1,m
     if (i == 0) i = 1
          ii = j + iabs(i)
          t  = e*(1.0 + sign(x(ii),real(i))) + e0
          tt = t*t
          d  = r8*(1.0 - tt)
          u  = h8 - d
          f  = exp(-u*u)

          if (h8 /= 0.0) go to 210
               f = f + f
               go to 220
  210         if (h5 /= 0.0) go to 220
               u = h8 + d
               f = f + exp(-u*u)

  220         if (z == 0.0) go to 230
               p = c
               go to 241

  230         u = rr*t*sqrt(2.0 - tt)
          if (u < a2) go to 240
               p = c
               z = 1.0
               go to 241

  240         p = 2.0*(1.0 - erfc2(u))
  241         sum = sum + f*p*t*y(ii)
  250    i = i + 1
     p = q*sum
     return
end
subroutine pkill3(r,s1,s2,h,k,p)
!
!*******************************************************************************
!
!! PKILL3: elliptical coverage function
!
     real k, k8, k9, n, x(21), y(21)
!
!        rt2 = sqrt(2)
!        rtpinv = 1/sqrt(pi)
!
     data rt2/1.4142135623731/
     data rtpinv/.56418958354776/
!
!        b = a1**2
!        c = 2*(1 - eps1)
!
     data a/3.291/, a1/3.89895/, a2/2.898/, a3/3.70/
     data err/1.e-3/, eps1/1.5e-5/
     data b/15.2018111/, c/1.99997/
!
     data x(1)  /.238619186083197/
     data x(2)  /.661209386466265/
     data x(3)  /.932469514203152/
     data x(4)  /.183434642495650/
     data x(5)  /.525532409916329/
     data x(6)  /.796666477413627/
     data x(7)  /.960289856497536/
     data x(8)  /.125233408511469/
     data x(9)  /.367831498998180/
     data x(10) /.587317954286617/
     data x(11) /.769902674194305/
     data x(12) /.904117256370475/
     data x(13) /.981560634246719/
     data x(14) /9.50125098376374e-2/
     data x(15) /.281603550779259/
     data x(16) /.458016777657227/
     data x(17) /.617876244402644/
     data x(18) /.755404408355003/
     data x(19) /.865631202387831/
     data x(20) /.944575023073232/
     data x(21) /.989400934991649/
!
     data y(1)  /.467913934572691/
     data y(2)  /.360761573048139/
     data y(3)  /.171324492379170/
     data y(4)  /.362683783378362/
     data y(5)  /.313706645877887/
     data y(6)  /.222381034453374/
     data y(7)  /.101228536290376/
     data y(8)  /.249147045813403/
     data y(9)  /.233492536538355/
     data y(10) /.203167426723066/
     data y(11) /.160078328543346/
     data y(12) /.106939325995318/
     data y(13) /4.7175336386512e-2/
     data y(14) /.189450610455068/
     data y(15) /.182603415045924/
     data y(16) /.169156519395003/
     data y(17) /.149595988815577/
     data y(18) /.124628971255534/
     data y(19) /9.51585116824928e-2/
     data y(20) /6.22535239386479e-2/
     data y(21) /2.71524594117541e-2/
!
!
!                  check if p=0 or p=1
!
     p = 0.0
     tol = err*s1*s2
     rr = r*r
     if (rr <= tol) return
!
     h2 = h*h + k*k
     d  = max ( s1,s2)
     t  = r - a1*d
     if (t < 0.0) go to 10
          if (t*t < h2) go to 10
               p = 1.0
               return
!
   10    h8 = abs(h)
     k8 = abs(k)
     if (r + a*s1 <= h8) return
     if (r + a*s2 <= k8) return
     s0 = sqrt(h2)
     if (s1 /= s2) go to 20
          h8 = s0
          k8 = 0.0
          if (r + a*s1 <= h8) return
!
   20    if (s0 <= r) go to 50
          d = (s0 - r)/d
          if (rr*exp(-0.5*d*d) <= tol) return
          if (s0 < r + a1*amin1(s1,s2)) go to 50
!
     if (h8*k8 == 0.0) go to 50
     h9 = h8/s1
     k9 = k8/s2
     d = h9*h9 + k9*k9
     if (d <= b) go to 50
!
     q = (s2/s1)**2
     f = q*h9*h9 + k9*k9
     z1 = (f/d)*(r/s2)**2
     z = d - z1 - b
     if (z <= 0.0) go to 30
     if (z*z >= 4.0*b*z1) return
!
   30    z1 = b*s1*s1*(h*h + q*k*k)/h2
     z = h2 - rr - z1
     if (z <= 0.0) go to 50
     if (z*z >= 4.0*rr*z1) return
!
!             find the limits of integration
!
   50    z  = k8 + a3 * s2
     u  = k8 - a3 * s2
     s0 = s1
     s  = s2
     i  = 0
!
   60    z  = r - z
     e0 = 0.0
     if (z > 0.0) e0 = sqrt(z/r)
     if (u >= 0.0) go to 61
          e  = 1.0 - e0
          h5 = 0.0
          go to 70
   61    e  = sqrt(1.0 - u/r) - e0
     h5 = 1.0
!
   70    if (i /= 0) go to 80
          i  = 1
          t  = e0
          f  = e
          h6 = h5
          z  = h8 + a3 * s1
          u  = h8 - a3 * s1
          go to 60
!
   80    if (f >= e) go to 100
          e0 = t
          e  = f
          t  = h8
          h8 = k8
          k8 = t
          h5 = h6
          s0 = s2
          s  = s1
!
!        select the appropriate integration process
!
  100    e = 0.5*e
     n = e*r*(0.34/s0 + 1.0/(.025*abs(r-k8) + 5.0*s))
     if (n < 2.0) go to 101
          j  = 13
          n1 =  8
          go to 110
  101    if (n < 0.675) go to 102
          j  =  7
          n1 =  6
          go to 110
  102    if (n < 0.50) go to 103
          j  =  3
          n1 =  4
          go to 110
  103    j  = 0
     n1 = 3
!
!              perform gaussian integration
!
  110    m  = n1 + n1
     r8 = r/(rt2*s0)
     h8 = h8/(rt2*s0)
     rr = r/(rt2*s)
     k8 = k8/(rt2*s)
     q  = rtpinv*e*r8
     i  = -n1
     z  = 0.0
     sum = 0.0
     if (k8 == 0.0) go to 200
!
     do 170 l = 1,m
     if (i == 0) i = 1
          ii = j + iabs(i)
          t  = e*(1.0 + sign(x(ii),real(i))) + e0
          tt = t*t
          d  = r8*(1.0 - tt)
          u  = h8 - d
          f  = exp(-u*u)
!
          if (h8 /= 0.0) go to 120
               f = f + f
               go to 130
  120         if (h5 /= 0.0) go to 130
               u = h8 + d
               f = f + exp(-u*u)
!
  130         if (z == 0.0) go to 140
               p = c
               go to 161
!
  140         d = rr*t*sqrt(2.0 - tt)
          u = k8 - d
          if (abs(u) < a2) go to 150
          if (u > 0.0) go to 170
               p = c
               z = 1.0
               go to 161
!
  150         p = erfc2(u)
          u = k8 + d
          if (u < a2) go to 160
               p = p - eps1
               go to 161
!
  160         p = p - erfc2(u)
  161         sum = sum + f*p*t*y(ii)
  170    i = i + 1
     p = q*sum
     return
!
  200    do 250 l = 1,m
     if (i == 0) i = 1
          ii = j + iabs(i)
          t  = e*(1.0 + sign(x(ii),real(i))) + e0
          tt = t*t
          d  = r8*(1.0 - tt)
          u  = h8 - d
          f  = exp(-u*u)
!
          if (h8 /= 0.0) go to 210
               f = f + f
               go to 220
  210         if (h5 /= 0.0) go to 220
               u = h8 + d
               f = f + exp(-u*u)
!
  220         if (z == 0.0) go to 230
               p = c
               go to 241
!
  230         u = rr*t*sqrt(2.0 - tt)
          if (u < a2) go to 240
               p = c
               z = 1.0
               go to 241
!
  240         p = 2.0*(1.0 - erfc2(u))
  241         sum = sum + f*p*t*y(ii)
  250    i = i + 1
     p = q*sum
     return
end
subroutine plcopy (a,ka,m,b,kb,n)
!
!*******************************************************************************
!
!! PLCOPY: copying real polynomials
!
  real a(*), b(*)
!
  la = 1
  lb = 1
  jmax = min (m, n)
  do 10 j = 1,jmax
     b(lb) = a(la)
     la = la + ka
     lb = lb + kb
   10 continue
  if (jmax == n) return
!
  mp1 = m + 1
  do 20 j = mp1,n
     b(lb) = 0.0
     lb = lb + kb
   20 continue
  return
end
subroutine plem(z, w, ierr)
!
!*******************************************************************************
!
!! PLEM: weierstrass p-function in the lemniscatic case
!     for complex argument with unit period parallelogram
!
  complex z, z1, z4, z6, w
  real zr, zi
  integer ierr, m, n
!
!     reduction to fundamental parallelogram
!
  zr = real(z) + 0.5e0
  zi = aimag(z) + 0.5e0
  m = int(zr)
  n = int(zi)
  if (zr < 0e0) m = m - 1
  if (zi < 0e0) n = n - 1
  z1 = z - real(m) - (0e0,1e0)*float(n)
!
!     if z1=0 then z coincides with a lattice point.
!     the lattice points are poles for p.
!
  w = z1*z1
  zr = abs(real(w)) + abs(aimag(w))
  if (zr/=0e0) go to 10
  ierr = 1
  return
!
!     evaluation of p(z1)
!
   10 ierr = 0
  z4 = w*w
  z6 = z4*w

  w = 1.0E+00 / w &
    + 4.0E+00 * w * ( 3.0E+00 + z4 ) / ( 1.0E+00 - z4 )**2 &
    + w * ((((((((-7.233108e-11*z4+1.714197273e-8)*z4-2.5369036492e-7)* &
    z4-7.98710206868e-6)*z4+6.4850606909737e-4)*z4+7.39624629362938e-3) &
    *z4+2.012382768497244e-2)*z4+7.1177297543136598e-1)* &
    z4-2.54636399353830738e0) / (((((((( &
    5.1161516e-10*z4 &
    +6.61289408e-9) *z4 &
    +4.4618987048e-7)*z4 &
    -8.42694918892e-6)*z4 &
    +4.42886829095e-6)* z4 &
    -4.22629935217101e-3)*z4 &
    +2.577496871700433e-2)* z4 &
    +4.2359940482277074e-1)*z4 + 1.0E+00 )

  return
end
subroutine plem1(z, w, ierr)
!
!*******************************************************************************
!
!! PLEM1: first derivative of weierstrass p-function in the
!     lemniscatic case for complex argument
!     with unit period parallelogram
!
  complex z, z1, z3, z4, w
  real zr, zi
  integer ierr, m, n
!
!     reduction to fundamental parallelogram
!
  zr = real(z) + 0.5e0
  zi = aimag(z) + 0.5e0
  m = int(zr)
  n = int(zi)
  if (zr < 0e0) m = m - 1
  if (zi < 0e0) n = n - 1
  z1 = z - real(m) - (0e0,1e0)*float(n)
!
!     if z1=0 then z coincides with a lattice point.
!     the lattice points are poles for dp.
!
  z3 = z1*z1*z1
  z4 = z3*z1
  w = (z1*(1e0-z4))**3
  zr = abs(real(w)) + abs(aimag(w))
  if (zr/=0e0) go to 10
  ierr = 1
  return
!
!     evaluation of dp(z1)
!
   10 ierr = 0
  w = (((1e1*z4+9e1)*z4+3e1)*z4-2e0)/w + &
   z1*((((((((((-3.9046302e-9*z4-1.001487137e-8)*z4+5.9573043092e-7) &
   *z4-2.482518130524e-5)*z4+1.4557266595395e-4)* &
   z4+4.56633655643206e-3)*z4+6.224782572111135e-2)* &
   z4+1.038527937794269e-2)*z4+1.19804620802637942e0)* &
   z4+6.42791439683811718e0)*z4-5.09272798707661477e0)/ &
   ((((((((((4.726888e-11*z4-3.0667983e-9)*z4+1.0087596089e-7)* &
   z4-8.060683451e-8)*z4+1.184299251664e-5)*z4-2.3096723361547e-4)* &
   z4-2.90730903142055e-3)*z4+1.338392411135511e-2)* &
   z4+2.3098639320021426e-1)*z4+8.4719880964554148e-1)*z4+1e0)
  return
end
subroutine plpwr(r,a,ka,m,b,kb,n,ierr)
!
!*******************************************************************************
!
!! PLPWR: set b = a**r where a is a real polynomial
!
  real a(*), b(*)
  real jm1
  double precision coeff, dsum, rp1
!
  a0 = a(1)
  if (a0 <= 0.0) go to 100
  ierr = 0
  b(1) = a0**r
  if (n == 1) return
!
!            case when m = 1 or r = 0
!
  if (m > 1 .and. r /= 0.0) go to 20
  lb = 1
  do 10 j = 2,n
     lb = lb + kb
     b(lb) = 0.0
   10 continue
  return
!
!                  general case
!
   20 rp1 = dble(r) + 1.d0
  lb = 1
  do 40 j = 2,n
     lb = lb + kb
     jm1 = j - 1
     ia = 1
     ib = lb
     coeff = -jm1
     dsum = 0.d0
     imax = min (j, m)
     do 30 i = 2,imax
        ia = ia + ka
        ib = ib - kb
        coeff = coeff + rp1
        dsum = dsum + coeff*dble(a(ia))*dble(b(ib))
   30    continue
     b(lb) = sngl(dsum)/(jm1*a0)
   40 continue
  return
!
!                error return
!
  100 ierr = 1
  return
end
subroutine pmult (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! PMULT: multiplication of real polynomials
!
  real a(*), b(*), c(*)
  double precision dsum
!
  lc = 1
  jmax = min (l + m - 1, n)
  do 40 j = 1,jmax
     if (j <= l) go to 10
        imin = 1 + (j - l)
        la = 1 + (l - 1)*ka
        lb = 1 + (imin - 1)*kb
        go to 20
   10    imin = 1
     la = 1 + (j - 1)*ka
     lb = 1
!
   20    imax = min (j, m)
     dsum = 0.d0
     do 30 i = imin,imax
        dsum = dsum + dble(a(la))*dble(b(lb))
        la = la - ka
        lb = lb + kb
   30    continue
     c(lc) = dsum
   40 lc = lc + kc
  if (jmax == n) return
!
  jmin = jmax + 1
  do 60 j = jmin,n
     c(lc) = 0.0
   60 lc = lc + kc
  return
end
function pndf(x,ind)
!
!*******************************************************************************
!
!! PNDF: evaluate the normal probability density function.
!
!     a = 1/sqrt(2)
!     c = sqrt(2/pi)
!
  data a/.707106781186548/
  data c/.797884560802865/
!
  t = a*x
  if (ind /= 0) go to 20
  if (x < -8.0) go to 10
  pndf = 0.5*erfc1(0,-t)
  return
   10 pndf = c/erfc1(1,-t)
  return
   20 if (x > 8.0) go to 30
  pndf = 0.5*erfc1(0,t)
  return
   30 pndf = c/erfc1(1,t)
  return
end
function pninv (p, q, z, ierr)
!
!*******************************************************************************
!
!! PNINV: evaluation of the inverse normal distribution function
!
!
!     let f(t) = 1/(sqrt(2*pi)*exp(-t*t/2)). then the function
!
!        prob(x) = integral from minus infinity to x of f(t)
!
!     is the normal distribution function of zero mean and unit
!     variance. for 0 <= p <= 1, w = pninv(p,q,z,ierr) where
!     prob(w) = p. it is assumed that q = 1 - p and z = p - q.
!
!     ierr is a variable that reports the status of the results.
!
!       ierr = 0  no input errors were detected. w was computed.
!       ierr = 1  either p or q is incorrect.
!       ierr = 2  z is incorrect.
!
  real pninv
!
!     rt2 = sqrt(2)
!
  data rt2 /1.414213562373095/
!
  if (p < 0.0 .or. q  <  0.0) go to 100
  eps = max (  epsilon ( eps ),1.e-15)
  t = 0.5 + (0.5 - (p + q))
  if (abs(t) > 2.0*eps) go to 100
!
  ierr = 0
  t = amin1(p,q)
  if (t /= 0.0) go to 10
  pninv = sign( huge ( pninv ),z)
  return
!
   10 p1 = abs(z)
  q1 = 2.0*t
  w = erfinv(p1,q1)
  if (w < 0.0) go to 110
  pninv = rt2*w
  if (z < 0.0) pninv = -pninv
  return
!
!                         error return
!
  100 ierr = 1
  pninv = 0.0
  return
  110 ierr = 2
  pninv = 0.0
  return
end
subroutine poca(r,a,x,y)
!
!*******************************************************************************
!
!! POCA ???
!
  x=r*cos(a)
  y=r*sin(a)
  return
end
double precision function polydd(x)
!
!*******************************************************************************
!
!! POLYDD evaluates the current polynomial piece represented
!     by the divided differences ddtemp on the point set xdd.
!
  double precision a, accur, b, bleft, bright, charf, ddtemp, &
   dsctol, error, errori, factor, fintrp, fleft, fright, norm, &
   xbreak, xdd, xintrp, xleft, xright, buffer
  dimension xbreak(20), dbreak(20), bleft(20), bright(20)
  dimension xleft(50), xright(50)
  dimension ddtemp(20,20), factor(20), fintrp(18), fleft(10), &
   fright(10), xdd(20), xintrp(18)
  integer both, break, dbreak, degree, edist, right, rightx, smooth
  logical discrd
  double precision x
!
  common /inputz/ a, b, accur, norm, charf, xbreak, bleft, bright, &
   dbreak, degree, smooth, level, edist, nbreak, kntdim, npardm
  common /resulz/ error, knots
  common /kontrl/ dsctol, errori, xleft, xright, break, both, &
   factor, ibreak, interp, left, maxaux, maxknt, maxpar, maxstk, &
   npar, nstack, right, discrd, buffer
  common /comdif/ ddtemp, fintrp, fleft, fright, xdd, xintrp, &
   leftx, nintrp, rightx
!
  polydd = ddtemp(degree+1,1)
  do 10 k=1,degree
    j = degree + 1 - k
    polydd = ddtemp(j,1) + (x-xdd(j))*polydd
   10 continue
  return
end
subroutine polyev(n,sr,si,pr,pi,qr,qi,pvr,pvi)
!
!*******************************************************************************
!
!! POLYEV evaluates a polynomial p at s by the horner recurrence algo.,
!     placing the partial sums in q and the computed value in pv.
!
  double precision pr(n),pi(n),qr(n),qi(n),sr,si,pvr,pvi,t
!
  qr(1) = pr(1)
  qi(1) = pi(1)
  pvr = qr(1)
  pvi = qi(1)
  do 10 i = 2,n
     t = pvr*sr - pvi*si + pr(i)
     pvi = pvr*si + pvi*sr + pi(i)
     pvr = t
     qr(i) = pvr
     qi(i) = pvi
   10 continue
  return
end
subroutine ppadd (n,ierror,a,c,cbp,bp,bh)
!
!*******************************************************************************
!
!! PPADD computes the eigenvalues of the periodic tridiagonal matrix
!     with coefficients an,bn,cn
!
! n   is the order of the bh and bp polynomials.
!     on output bp contains the eigenvalues.
! cbp is the same as bp except type complex.
! bh  is used to temporarily store the roots of the b hat polynomial
!     which enters through bp.
!
  complex         cf         ,cx         ,fsg        ,hsg        , &
                  dd         ,f          ,fp         ,fpp        , &
                  cdis       ,r1         ,r2         ,r3         , &
                  cbp
  dimension       a(*)       ,c(*)       ,bp(*)      ,bh(*)      , &
                  cbp(*)
  external        psgf       ,ppspf      ,ppsgf
  common /cblkt/  npp        ,k          ,eps        ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  scnv = sqrt(cnv)
  iz = n
  izm = iz-1
  izm2 = iz-2
  if (bp(n)-bp(1))  10,420, 30
   10 do  20 j=1,n
     nt = n-j
     bh(j) = bp(nt+1)
   20 continue
  go to  50
   30 do  40 j=1,n
     bh(j) = bp(j)
   40 continue
   50 ncmplx = 0
  modiz = mod(iz,2)
  is = 1
  if (modiz)  60, 70, 60
   60 if (a(1)) 100,420, 70
   70 xl = bh(1)
  db = bh(3)-bh(1)
   80 xl = xl-db
  if (psgf(xl,iz,c,a,bh))  80, 80, 90
   90 sgn = -1.
  cbp(1) = cmplx(bsrh(xl,bh(1),iz,c,a,bh,psgf,sgn),0.)
  is = 2
  100 if = iz-1
  if (modiz) 110,120,110
  110 if (a(1)) 120,420,150
  120 xr = bh(iz)
  db = bh(iz)-bh(iz-2)
  130 xr = xr+db
  if (psgf(xr,iz,c,a,bh)) 130,140,140
  140 sgn = 1.
  cbp(iz) = cmplx(bsrh(bh(iz),xr,iz,c,a,bh,psgf,sgn),0.)
  if = iz-2
  150 do 360 ig=is,if,2
     xl = bh(ig)
     xr = bh(ig+1)
     sgn = -1.
     xm = bsrh(xl,xr,iz,c,a,bh,ppspf,sgn)
     psg = psgf(xm,iz,c,a,bh)
     if (abs(psg)-eps) 180,180,160
  160    if (psg*ppsgf(xm,iz,c,a,bh)) 170,180,190
!
!     case of a real zero
!
  170    sgn = 1.
     cbp(ig) = cmplx(bsrh(bh(ig),xm,iz,c,a,bh,psgf,sgn),0.)
     sgn = -1.
     cbp(ig+1) = cmplx(bsrh(xm,bh(ig+1),iz,c,a,bh,psgf,sgn),0.)
     go to 360
!
!     case of a multiple zero
!
  180    cbp(ig) = cmplx(xm,0.)
     cbp(ig+1) = cmplx(xm,0.)
     go to 360
!
!     case of a complex zero
!
  190    it = 0
     icv = 0
     cx = cmplx(xm,0.)
  200    fsg = (1.,0.)
     hsg = (1.,0.)
     fp = (0.,0.)
     fpp = (0.,0.)
     do 210 j=1,iz
        dd = 1./(cx-bh(j))
        fsg = fsg*a(j)*dd
        hsg = hsg*c(j)*dd
        fp = fp+dd
        fpp = fpp-dd*dd
  210    continue
     if (modiz) 230,220,230
  220    f = (1.,0.)-fsg-hsg
     go to 240
  230    f = (1.,0.)+fsg+hsg
  240    i3 = 0
     if (cabs(fp)) 260,260,250
  250    i3 = 1
     r3 = -f/fp
  260    i2 = 0
     if (cabs(fpp)) 320,320,270
  270    i2 = 1
     cdis = csqrt(fp**2-2.*f*fpp)
     r1 = cdis-fp
     r2 = -fp-cdis
     if (cabs(r1)-cabs(r2)) 290,290,280
  280    r1 = r1/fpp
     go to 300
  290    r1 = r2/fpp
  300    r2 = 2.*f/fpp/r1
     if (cabs(r2) < cabs(r1)) r1 = r2
     if (i3) 330,330,310
  310    if (cabs(r3) < cabs(r1)) r1 = r3
     go to 330
  320    r1 = r3
  330    cx = cx+r1
     it = it+1
     if (it > 50) go to 420
     if (cabs(r1) > scnv) go to 200
     if (icv) 340,340,350
  340    icv = 1
     go to 200
  350    cbp(ig) = cx
     cbp(ig+1) = conjg(cx)
  360 continue
  if (cabs(cbp(n))-cabs(cbp(1))) 370,420,390
  370 nhalf = n/2
  do 380 j=1,nhalf
     nt = n-j
     cx = cbp(j)
     cbp(j) = cbp(nt+1)
     cbp(nt+1) = cx
  380 continue
  390 ncmplx = 1
  do 400 j=2,iz
     if (aimag(cbp(j))) 430,400,430
  400 continue
  ncmplx = 0
  do 410 j=2,iz
     bp(j) = real(cbp(j))
  410 continue
  go to 430
  420 ierror = 4
  430 continue
  return
end
function ppsgf (x,iz,c,a,bh)
!
!*******************************************************************************
!
!! PPSGF: ???
!
  dimension       a(*)       ,c(*)       ,bh(*)
  sum = 0.
  do  10 j=1,iz
     sum = sum-1./(x-bh(j))**2
   10 continue
  ppsgf = sum
  return
end
function ppspf (x,iz,c,a,bh)
!
!*******************************************************************************
!
!! PPSPF: ???
!
  dimension       a(*)       ,c(*)       ,bh(*)
  sum = 0.
  do  10 j=1,iz
     sum = sum+1./(x-bh(j))
   10 continue
  ppspf = sum
  return
end
subroutine ppval (x, a, l, n, xi, yi, ni)
!
!*******************************************************************************
!
!! PPVAL evaluates a piecewise polynomial at the
!         abscissas in xi. it is assumed that the coefficients
!         of the polynomials which form the pp are given.
!
!       --input--
!
!         x   - array of the first n abscissas (in increasing order)
!               that define the pp.
!         a   - matrix that contains the coefficients of the poly-
!               nomials  which form the pp. if i = 1,...,n then the
!               pp has the value
!                    a(1,i) + a(2,i)*dx + ... + a(l,i)*dx**(l-1)
!               for x(i) <= xx < x(i+1).  here dx = xx-x(i).
!         l   - order of the piecewise polynomial.
!         n   - the number of polynomials that define the pp.
!               n must be greater than or equal to 1.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the pp is to be evaluated.
!         ni  - the number of abscissas at which the pp is to be
!               evaluated.  if ni is greater than 1 then xi and yi
!               must be arrays of dimension ni or larger.
!               it is assumed that ni is greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the pp at xi
!
!
  dimension x(n), a(l,n), xi(ni), yi(ni)
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  lm1 = l - 1
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  il = 1
  ir = n
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx-x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   40 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 40
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = n
  go to 100
   90 i = 1
!
!     evaluation
!
  100 dx = xx - x(i)
  s = a(l,i)
  if (l == 1) go to 120
  do 110 j = 1,lm1
  lmj = l - j
  110 s = a(lmj,i) + dx*s
  120 yi(k) = s
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  if (xx-xi(k-1)) 130,120,40
  130 il = 1
  ir = min (i+1,n)
  go to 10
end
subroutine prod0 (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,y,m,a,b,c,d,w,u)
!
!*******************************************************************************
!
!! PROD0 applies a sequence of matrix operations to the vector x and
! stores the result in y.
!
! bd,bm1,bm2 arrays containing roots of certian b polynomials.
! nd,nm1,nm2 the lengths of the arrays bd,bm1,bm2 respectively.
! aa         array containing scalar multipliers of the vector x.
! na         the length of the array aa.
! x,y        matrix operations are applied to x and the result is y.
! a,b,c      arrays which contain the tridiagonal matrix.
! m          the order of the matrix.
! d,w,u      working arrays.
! is         determines whether or not a change in sign is made.
!
  dimension       a(*)       ,b(*)       ,c(*)       ,x(*)       , &
                  y(*)       ,d(*)       ,w(*)       ,bd(*)      , &
                  bm1(*)     ,bm2(*)     ,aa(*)      ,u(*)
!
  do  10 j=1,m
     w(j) = x(j)
     y(j) = w(j)
   10 continue
  mm = m-1
  id = nd
  ibr = 0
  m1 = nm1
  m2 = nm2
  ia = na
   20 if (ia)  50, 50, 30
   30 rt = aa(ia)
  if (nd == 0) rt = -rt
  ia = ia-1
!
! scalar multiplication
!
  do  40 j=1,m
     y(j) = rt*w(j)
   40 continue
   50 if (id) 250,250, 60
   60 rt = bd(id)
  id = id-1
  if (id == 0) ibr = 1
!
! begin solution to system
!
  d(m) = a(m)/(b(m)-rt)
  w(m) = y(m)/(b(m)-rt)
  do  70 j=2,mm
     k = m-j
     den = b(k+1)-rt-c(k+1)*d(k+2)
     d(k+1) = a(k+1)/den
     w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den
   70 continue
  den = b(1)-rt-c(1)*d(2)
  w(1) = 1.
  if (den)  80, 90, 80
   80 w(1) = (y(1)-c(1)*w(2))/den
   90 do 100 j=2,m
     w(j) = w(j)-d(j)*w(j-1)
  100 continue
  if (na) 130,130, 20
  110 do 120 j=1,m
     y(j) = w(j)
  120 continue
  ibr = 1
  go to  20
  130 if (m1) 140,140,150
  140 if (m2) 110,110,200
  150 if (m2) 170,170,160
  160 if (abs(bm1(m1))-abs(bm2(m2))) 200,200,170
  170 if (ibr) 180,180,190
  180 if (abs(bm1(m1)-bd(id))-abs(bm1(m1)-rt)) 110,190,190
  190 rt = rt-bm1(m1)
  m1 = m1-1
  go to 230
  200 if (ibr) 210,210,220
  210 if (abs(bm2(m2)-bd(id))-abs(bm2(m2)-rt)) 110,220,220
  220 rt = rt-bm2(m2)
  m2 = m2-1
  230 do 240 j=1,m
     y(j) = y(j)+rt*w(j)
  240 continue
  go to  20
  250 return
end
subroutine prodp (nd,bd,nm1,bm1,nm2,bm2,na,aa,x,y,m,a,b,c,d,u,w)
!
!*******************************************************************************
!
!! PRODP applies a sequence of matrix operations to the vector x and
! stores the result in y.   (periodic boundary conditions)
!
! bd,bm1,bm2 arrays containing roots of certian b polynomials.
! nd,nm1,nm2 the lengths of the arrays bd,bm1,bm2 respectively.
! aa         array containing scalar multipliers of the vector x.
! na         length of the array aa.
! x,y        matrix operations are applied to x and the result is y.
! a,b,c      arrays which contain the tridiagonal matrix.
! m          the order of the matrix.
! d,u,w      working arrays.
! is         determines whether or not a change in sign is made.
!
  dimension       a(*)       ,b(*)       ,c(*)       ,x(*)       , &
                  y(*)       ,d(*)       ,u(*)       ,bd(*)      , &
                  bm1(*)     ,bm2(*)     ,aa(*)      ,w(*)
!
  do  10 j=1,m
     y(j) = x(j)
     w(j) = y(j)
   10 continue
  mm = m-1
  mm2 = m-2
  id = nd
  ibr = 0
  m1 = nm1
  m2 = nm2
  ia = na
   20 if (ia)  50, 50, 30
   30 rt = aa(ia)
  if (nd == 0) rt = -rt
  ia = ia-1
  do  40 j=1,m
     y(j) = rt*w(j)
   40 continue
   50 if (id) 280,280, 60
   60 rt = bd(id)
  id = id-1
  if (id == 0) ibr = 1
!
! begin solution to system
!
  bh = b(m)-rt
  ym = y(m)
  den = b(1)-rt
  d(1) = c(1)/den
  u(1) = a(1)/den
  w(1) = y(1)/den
  v = c(m)
  if (mm2-2)  90, 70, 70
   70 do  80 j=2,mm2
     den = b(j)-rt-a(j)*d(j-1)
     d(j) = c(j)/den
     u(j) = -a(j)*u(j-1)/den
     w(j) = (y(j)-a(j)*w(j-1))/den
     bh = bh-v*u(j-1)
     ym = ym-v*w(j-1)
     v = -v*d(j-1)
   80 continue
   90 den = b(m-1)-rt-a(m-1)*d(m-2)
  d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den
  w(m-1) = (y(m-1)-a(m-1)*w(m-2))/den
  am = a(m)-v*d(m-2)
  bh = bh-v*u(m-2)
  ym = ym-v*w(m-2)
  den = bh-am*d(m-1)
  if (den) 100,110,100
  100 w(m) = (ym-am*w(m-1))/den
  go to 120
  110 w(m) = 1.
  120 w(m-1) = w(m-1)-d(m-1)*w(m)
  do 130 j=2,mm
     k = m-j
     w(k) = w(k)-d(k)*w(k+1)-u(k)*w(m)
  130 continue
  if (na) 160,160, 20
  140 do 150 j=1,m
     y(j) = w(j)
  150 continue
  ibr = 1
  go to  20
  160 if (m1) 170,170,180
  170 if (m2) 140,140,230
  180 if (m2) 200,200,190
  190 if (abs(bm1(m1))-abs(bm2(m2))) 230,230,200
  200 if (ibr) 210,210,220
  210 if (abs(bm1(m1)-bd(id))-abs(bm1(m1)-rt)) 140,220,220
  220 rt = rt-bm1(m1)
  m1 = m1-1
  go to 260
  230 if (ibr) 240,240,250
  240 if (abs(bm2(m2)-bd(id))-abs(bm2(m2)-rt)) 140,250,250
  250 rt = rt-bm2(m2)
  m2 = m2-1
  260 do 270 j=1,m
     y(j) = y(j)+rt*w(j)
  270 continue
  go to  20
  280 return
end
function psgf (x,iz,c,a,bh)
!
!*******************************************************************************
!
!! PSGF ???
!
  dimension       a(*)       ,c(*)       ,bh(*)
  fsg = 1.
  hsg = 1.
  do  10 j=1,iz
     dd = 1./(x-bh(j))
     fsg = fsg*a(j)*dd
     hsg = hsg*c(j)*dd
   10 continue
  if (mod(iz,2))  30, 20, 30
   20 psgf = 1.0-fsg-hsg
  return
   30 psgf = 1.0+fsg+hsg
  return
end
function psi ( xx )
!
!*******************************************************************************
!
!! PSI evalulates the digamma function.
!
!
!     psi(xx) is assigned the value 0 when the digamma function cannot
!     be computed.
!
!     the main computation involves evaluation of rational chebyshev
!     approximations published in math. comp. 27, 123-127(1973) by
!     cody, strecok and thacher.
!
!
!     psi was written at argonne national laboratory for the funpack
!     package of special function subroutines. psi was modified by
!     a.h. morris (nswc).
!
  real p1(7)
  real p2(4)
  real psi
  real q1(6), q2(4)
  double precision dx0
!
!
!     piov4 = pi/4
!     dx0 = zero of psi to extended precision
!
!
  data piov4/.785398163397448e0/
  data dx0/1.461632144968362341262659542325721325d0/
!
!
!     coefficients for rational approximation of
!     psi(x) / (x - x0),  0.5 <= x <= 3.0
!
!
  data p1(1)/.895385022981970e-02/,  p1(2)/.477762828042627e+01/, &
       p1(3)/.142441585084029e+03/,  p1(4)/.118645200713425e+04/, &
       p1(5)/.363351846806499e+04/,  p1(6)/.413810161269013e+04/, &
       p1(7)/.130560269827897e+04/
  data q1(1)/.448452573429826e+02/,  q1(2)/.520752771467162e+03/, &
       q1(3)/.221000799247830e+04/,  q1(4)/.364127349079381e+04/, &
       q1(5)/.190831076596300e+04/,  q1(6)/.691091682714533e-05/
!
!
!     coefficients for rational approximation of
!     psi(x) - ln(x) + 1 / (2*x),  x > 3.0
!
!
  data p2(1)/-.212940445131011e+01/, p2(2)/-.701677227766759e+01/, &
       p2(3)/-.448616543918019e+01/, p2(4)/-.648157123766197e+00/
  data q2(1)/ .322703493791143e+02/, q2(2)/ .892920700481861e+02/, &
       q2(3)/ .546117738103215e+02/, q2(4)/ .777788548522962e+01/
!
!
!     machine dependent constants ...
!
!        xmax1  = the smallest positive floating point constant
!                 with entirely integer representation.  also used
!                 as negative of lower bound on acceptable negative
!                 arguments and as the positive argument beyond which
!                 psi may be represented as alog(x).
!
!        xsmall = absolute argument below which pi*cotan(pi*x)
!                 may be represented by 1/x.
!
!
  xmax1 = real ( huge ( 1 ) )
  xmax1 = amin1(xmax1, 1.0/ epsilon ( xmax1 ) )
  xsmall = 1.0e-9
!
  x = xx
  aug = 0.0e0
  if (x >= 0.5e0) go to 200
!
!     x < 0.5,  use reflection formula
!     psi(1-x) = psi(x) + pi * cotan(pi*x)
!
  if (abs(x) > xsmall) go to 100
  if (x == 0.0e0) go to 400
!
!     0 < abs(x) <= xsmall.  use 1/x as a substitute
!     for  pi*cotan(pi*x)
!
  aug = -1.0e0 / x
  go to 150
!
!     reduction of argument for cotan
!
  100 w = - x
  sgn = piov4
  if (w > 0.0e0) go to 120
  w = - w
  sgn = -sgn
!
!     make an error exit if x <= -xmax1
!---------------------------------------------------------------------
  120 if (w >= xmax1) go to 400
  nq = int(w)
  w = w - real(nq)
  nq = int(w*4.0e0)
  w = 4.0e0 * (w - real(nq) * .25e0)
!---------------------------------------------------------------------
!     w is now related to the fractional part of  4.0 * x.
!     adjust argument to correspond to values in first
!     quadrant and determine sign
!---------------------------------------------------------------------
  n = nq / 2
  if ((n+n) /= nq) w = 1.0e0 - w
  z = piov4 * w
  m = n / 2
  if ((m+m) /= n) sgn = - sgn
!---------------------------------------------------------------------
!     determine final value for  -pi*cotan(pi*x)
!---------------------------------------------------------------------
  n = (nq + 1) / 2
  m = n / 2
  m = m + m
  if (m /= n) go to 140
!---------------------------------------------------------------------
!     check for singularity
!---------------------------------------------------------------------
  if (z == 0.0e0) go to 400
!---------------------------------------------------------------------
!     use cos/sin as a substitute for cotan, and
!     sin/cos as a substitute for tan
!---------------------------------------------------------------------
  aug = sgn * ((cos(z) / sin(z)) * 4.0e0)
  go to 150
  140 aug = sgn * ((sin(z) / cos(z)) * 4.0e0)
  150 x = 1.0e0 - x
  200 if (x > 3.0e0) go to 300
!---------------------------------------------------------------------
!     0.5 <= x <= 3.0
!---------------------------------------------------------------------
  den = x
  upper = p1(1) * x
!
  do 210 i = 1, 5
     den = (den + q1(i)) * x
     upper = (upper + p1(i+1)) * x
  210 continue
!
  den = (upper + p1(7)) / (den + q1(6))
  xmx0 = dble(x) - dx0
  psi = den * xmx0 + aug
  return
!---------------------------------------------------------------------
!     if x >= xmax1, psi = ln(x)
!---------------------------------------------------------------------
  300 if (x >= xmax1) go to 350
!---------------------------------------------------------------------
!     3.0 < x  <  xmax1
!---------------------------------------------------------------------
  w = 1.0e0 / (x * x)
  den = w
  upper = p2(1) * w
!
  do 310 i = 1, 3
     den = (den + q2(i)) * w
     upper = (upper + p2(i+1)) * w
  310 continue
!
  aug = upper / (den + q2(4)) - 0.5e0 / x + aug
  350 psi = aug + alog(x)
  return
!---------------------------------------------------------------------
!     error return
!---------------------------------------------------------------------
  400 psi = 0.0e0
  return
end
subroutine psi_values ( n, x, fx )
!
!*******************************************************************************
!
!! PSI_VALUES returns some values of the Psi or Digamma function for testing.
!
!
!  Discussion:
!
!    PSI(X) = d LN ( GAMMA ( X ) ) / d X = GAMMA'(X) / GAMMA(X)
!
!    PSI(1) = - Euler's constant.
!
!    PSI(X+1) = PSI(X) + 1 / X.
!
!  Modified:
!
!    17 May 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 11
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    -0.5772156649E+00, -0.4237549404E+00, -0.2890398966E+00, &
    -0.1691908889E+00, -0.0613845446E+00, -0.0364899740E+00, &
     0.1260474528E+00,  0.2085478749E+00,  0.2849914333E+00, &
     0.3561841612E+00,  0.4227843351E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
    1.0E+00,  1.1E+00,  1.2E+00,  1.3E+00, &
    1.4E+00,  1.5E+00,  1.6E+00,  1.7E+00, &
    1.8E+00,  1.9E+00,  2.0E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine psubt (a,ka,l,b,kb,m,c,kc,n)
!
!*******************************************************************************
!
!! PSUBT: subtraction of real polynomials
!
  real a(*), b(*), c(*)
!
  la = 1
  lb = 1
  lc = 1
  do 10 i = 1,n
     c(lc) = 0.0
     if (i <= l) c(lc) = a(la)
     if (i <= m) c(lc) = c(lc) - b(lb)
     la = la + ka
     lb = lb + kb
     lc = lc + kc
   10 continue
  return
end
subroutine qagi(f,bound,inf,epsabs,epsrel,result,abserr, &
    neval,ier,limit,lenw,last,iwork,work)
!
!*******************************************************************************
!
!! QAGI approximates an integral over an infinite interval.
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            bound  - real
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - real
!                     absolute accuracy requested
!
!            epsrel - real
!                     relative accuracy requested
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative, limit < 1,
!                             or lenw < 4 * limit.
!                             result, abserr, neval, last are
!                             set to zero.
!
!         dimensioning parameters
!            limit - integer
!                    dimensioning parameter for iwork
!                    limit determines the maximum number
!                    of subintervals in the partition of the given
!                    integration interval (a,b), limit >= 1.
!                    if limit < 1, the routine will end with
!                    ier = 6.
!
!            lenw  - integer
!                    dimensioning parameter for work
!                    lenw must be at least limit*4.
!                    if lenw < limit*4, the routine will end
!                    with ier = 6.
!
!            last  - integer
!                    on return, last equals the number of
!                    subintervals produced in the subdivision
!                    process, which determines the number of significant
!                    elements actually in the work arrays.
!
!         work arrays
!            iwork - integer
!                    vector of dimension at least limit, the first
!                    k elements of which contain pointers
!                    to the error estimates over the subintervals,
!                    such that work(limit*3+iwork(1)),... ,
!                    work(limit*3+iwork(k)) form a decreasing
!                    sequence, with k = last if last <= (limit/2+2), and
!                    k = limit+1-last otherwise
!
!            work  - real
!                    vector of dimension at least lenw
!                    on return
!                    work(1), ..., work(last) contain the left
!                     end points of the subintervals in the
!                     partition of (a,b),
!                    work(limit+1), ..., work(limit+last) contain
!                     the right end points,
!                    work(limit*2+1), ..., work(limit*2+last)
!                     contain the integral approximations over
!                     the subintervals,
!                    work(limit*3+1), ..., work(limit*3+last)
!                     contain the error estimates.
!
!        subroutines or functions needed
!              - qagie
!              - qk15i
!              - qpsrt
!              - qelg
!              - f (user provided function)
!
!
  real abserr,bound,epsabs,epsrel,f,result,work
  integer ier,iwork,lenw,limit,l1,l2,l3,neval
!
  dimension iwork(limit),work(lenw)
!
  external f
!
!         check validity of limit and lenw.
!
  ier = 6
  neval = 0
  last = 0
  result = 0.0e+00
  abserr = 0.0e+00
  if (limit < 1 .or. lenw  <  limit*4) return
!
!         prepare call for qagie.
!
  l1 = limit+1
  l2 = limit+l1
  l3 = limit+l2
!
  call qagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, &
    neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last)
  return
end
subroutine qagi1(f,phi,y,c,bound,inf,epsabs,epsrel,result,abserr, &
    neval,ier,limit,lenw,last,iwork,work)
!
!*******************************************************************************
!
!! QAGI1 approximates an integral over an infinite interval.
!
!
! 2.     purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)). f has the
!           arguments x and phi where phi is a function.
!
! 3.     calling sequence
!           call qagi1(f,phi,bound,inf,epsabs,epsrel,result,abserr,
!                 neval,ier,limit,lenw,last,iwork,work)
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!                     f has the arguments x and phi.
!
!            phi    - real
!                     function subprogram having a single real argument.
!                     the actual name for phi must be declared external
!                     in the driver program.
!
!            bound  - real
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            y      - real
!                     parameter for use in xcond.  ordinate of
!                     horizontal line along which integration
!                     is performed.
!
!            c       - real
!                      parameter for use in acond and xcond.
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - real
!                     absolute accuracy requested
!            epsrel - real
!                     relative accuracy requested
!                     if  epsabs <= 0
!                     and epsrel < max(50*rel.mach.acc.,0.5e-14),
!                     the routine will end with ier = 6.
!
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid, because
!                             (epsabs <= 0 and
!                              epsrel < max(50*rel.mach.acc.,0.5e-14))
!                              or limit < 1 or lenw < limit*4.
!                             result, abserr, neval, last are set to
!                             zero. exept when limit or lenw is
!                             invalid, iwork(1), work(limit*2+1) and
!                             work(limit*3+1) are set to zero,
!                             work(1) is set to a and work(limit+1)
!                             to b.
!
!         dimensioning parameters
!            limit - integer
!                    dimensioning parameter for iwork
!                    limit determines the maximum number
!                    of subintervals in the partition of the given
!                    integration interval (a,b), limit >= 1.
!                    if limit < 1, the routine will end with
!                    ier = 6.
!
!            lenw  - integer
!                    dimensioning parameter for work
!                    lenw must be at least limit*4.
!                    if lenw < limit*4, the routine will end
!                    with ier = 6.
!
!            last  - integer
!                    on return, last equals the number of
!                    subintervals produced in the subdivision
!                    process, which determines the number of significant
!                    elements actually in the work arrays.
!
!         work arrays
!            iwork - integer
!                    vector of dimension at least limit, the first
!                    k elements of which contain pointers
!                    to the error estimates over the subintervals,
!                    such that work(limit*3+iwork(1)),... ,
!                    work(limit*3+iwork(k)) form a decreasing
!                    sequence, with k = last if last <= (limit/2+2), and
!                    k = limit+1-last otherwise
!
!            work  - real
!                    vector of dimension at least lenw
!                    on return
!                    work(1), ..., work(last) contain the left
!                     end points of the subintervals in the
!                     partition of (a,b),
!                    work(limit+1), ..., work(limit+last) contain
!                     the right end points,
!                    work(limit*2+1), ..., work(limit*2+last)
!                     contain the integral approximations over
!                     the subintervals,
!                    work(limit*3+1), ..., work(limit*3+last)
!                     contain the error estimates.
!
! 4.     subroutines or functions needed
!              - qagie1
!              - qk15i1
!              - qpsrt
!              - qelg
!              - f (user provided function)
!              - phi (user provided function)
!
!
!
  real    abserr,bound,epsabs,epsrel,f,result,work
  integer ier,iwork,lenw,limit,l1,l2,l3,neval
!
  dimension iwork(limit),work(lenw)
!
  external f, phi
!
!         check validity of limit and lenw.
!
!***first executable statement  qagi1
  ier = 6
  neval = 0
  last = 0
  result = 0.0e+00
  abserr = 0.0e+00
  if(limit < 1.or.lenw < limit*4) return
!
!         prepare call for qagie1.
!
  l1 = limit+1
  l2 = limit+l1
  l3 = limit+l2
!
  call qagie1(f,phi,y,c,bound,inf,epsabs,epsrel,limit,result,abserr, &
    neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last)
  return
end
subroutine qagie ( f, bound, inf, epsabs, epsrel, limit, result, abserr, &
  neval, ier, alist, blist, rlist, elist, iord, last )
!
!*******************************************************************************
!
!! QAGIE approximates an integral over an infinite interval.
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            bound  - real
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - real
!                     absolute accuracy requested
!
!            epsrel - real
!                     relative accuracy requested
!
!            limit  - integer
!                     gives an upper bound on the number of
!                     subintervals in the partition of (a,b),
!                     limit >= 1
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative.
!                             result, abserr, neval, last, rlist(1),
!                             elist(1) and iord(1) are set to zero.
!                             alist(1) and blist(1) are set to 0
!                             and 1 respectively.
!
!            alist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the left
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            blist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the right
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            rlist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the integral
!                     approximations on the subintervals
!
!            elist  - real
!                     vector of dimension at least limit,  the first
!                      last  elements of which are the moduli
!                     of the absolute error estimates on the
!                     subintervals
!
!            iord   - integer
!                     vector of dimension limit, the first k
!                     elements of which are pointers to the
!                     error estimates over the subintervals,
!                     such that elist(iord(1)), ..., elist(iord(k))
!                     form a decreasing sequence, with k = last
!                     if last <= (limit/2+2), and k = limit+1-last
!                     otherwise
!
!            last   - integer
!                     number of subintervals actually produced
!                     in the subdivision process
!
!        subroutines or functions needed
!              - qk15i
!              - qpsrt
!              - qelg
!              - f (user-provided function)
!
!
  integer limit
!
  real abseps
  real abserr
  real alist
  real area
  real area1
  real area12
  real area2
  real a1
  real a2
  real blist
  real boun
  real bound
  real b1
  real b2
  real correc
  real defabs
  real defab1
  real defab2
  real dres
  real elist
  real epmach
  real epsabs
  real epsrel
  real erlarg
  real erlast
  real errbnd
  real errmax
  real error1
  real error2
  real erro12
  real errsum
  real ertest
  logical extrap
  real f
  logical noext
  integer nres
  integer nrmax
  integer numrl2
  real oflow
  real rerr
  real resabs
  real reseps
  real result
  real res3la
  real rlist
  real rlist2
  real small
  real uflow

  integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, &
    ktmin,last,maxerr,neval
!
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
    res3la(3),rlist(limit),rlist2(52)
!
  external f
!
!            the dimension of rlist2 is determined by the value of
!            limexp in subroutine qelg.
!
!
!            list of major variables
!            -----------------------
!
!           alist     - list of left end points of all subintervals
!                       considered up to now
!           blist     - list of right end points of all subintervals
!                       considered up to now
!           rlist(i)  - approximation to the integral over
!                       (alist(i),blist(i))
!           rlist2    - array of dimension at least (limexp+2),
!                       containing the part of the epsilon table
!                       wich is still needed for further computations
!           elist(i)  - error estimate applying to rlist(i)
!           maxerr    - pointer to the interval with largest error
!                       estimate
!           errmax    - elist(maxerr)
!           erlast    - error on the interval currently subdivided
!                       (before that subdivision has taken place)
!           area      - sum of the integrals over the subintervals
!           errsum    - sum of the errors over the subintervals
!           errbnd    - requested accuracy max(epsabs,epsrel*
!                       abs(result))
!           *****1    - variable for the left subinterval
!           *****2    - variable for the right subinterval
!           last      - index for subdivision
!           nres      - number of calls to the extrapolation routine
!           numrl2    - number of elements currently in rlist2. if an
!                       appropriate approximation to the compounded
!                       integral has been obtained, it is put in
!                       rlist2(numrl2) after numrl2 has been increased
!                       by one.
!           small     - length of the smallest interval considered up
!                       to now, multiplied by 1.5
!           erlarg    - sum of the errors over the intervals larger
!                       than the smallest interval considered up to now
!           extrap    - logical variable denoting that the routine
!                       is attempting to perform extrapolation. i.e.
!                       before subdividing the smallest interval we
!                       try to decrease the value of erlarg.
!           noext     - logical variable denoting that extrapolation
!                       is no longer allowed (true-value)
!
!            machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!           oflow is the largest positive magnitude.
!
  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
  oflow = huge ( oflow )
!
!  Check epsabs and epsrel
!
  neval = 0
  last = 0
  result = 0.0
  abserr = 0.0
  alist(1) = 0.0
  blist(1) = 1.0
  rlist(1) = 0.0
  elist(1) = 0.0
  iord(1) = 0

  if ( epsabs < 0.0E+00 ) then
    ier = 6
    return
  end if

  if ( epsrel  <  0.0E+00 ) then
    ier = 6
    return
  end if

  ier = 0

  rerr = epsrel
  rerr = max ( rerr, 50.0E+00 * epmach )
  rerr = max ( rerr, 0.5E-14 )
!
!
!           first approximation to the integral
!
!
!           determine the interval to be mapped onto (0,1).
!           if inf = 2 the integral is computed as i = i1+i2, where
!           i1 = integral of f over (-infinity,0),
!           i2 = integral of f over (0,+infinity).
!
  boun = bound
  if(inf==2) boun = 0.0e+00

  call qk15i(f,boun,inf,0.0e+00,0.1e+01,result,abserr, &
    defabs,resabs)
!
!           test on accuracy
!
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  dres = abs(result)
  errbnd = max ( epsabs,rerr*dres)
  if(abserr <= 1.0e+02*epmach*defabs.and.abserr >  &
    errbnd) ier = 2
  if ( limit == 1 ) ier = 1

  if ( ier /= 0 .or. (abserr <= errbnd.and.abserr/=resabs).or. &
    abserr==0.0e+00) go to 130
!
!  Initialization
!
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  correc = 0.0e+00
  nrmax = 1
  nres = 0
  ktmin = 0
  numrl2 = 2
  extrap = .false.
  noext = .false.
  ierro = 0
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0

  if ( dres >= (0.1E+01 - 0.5E+02 * epmach ) * defabs ) then
    ksgn = 1
  else
    ksgn = -1
  end if
!
!           main do-loop
!
!
  do 90 last = 2,limit
!
!           bisect the subinterval with nrmax-th largest
!           error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5e+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call qk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1)
    call qk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2)
!
!           improve previous approximations to integral
!           and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1==error1.or.defab2==error2)go to 15
    if(abs(rlist(maxerr)-area12) > 0.1e-04*abs(area12) &
    .or.erro12 < 0.99e+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
10  continue

    if(last > 10.and.erro12 > errmax) iroff3 = iroff3+1
15  continue
    rlist(maxerr) = area1
    rlist(last) = area2
    errbnd = max ( epsabs,rerr*abs(area))
!
!           test for roundoff error and eventually
!           set error flag.
!
    if(iroff1+iroff2 >= 10.or.iroff3 >= 20) ier = 2
    if(iroff2 >= 5) ierro = 3
!
!           set error flag in the case that the number of
!           subintervals equals limit.
!
    if(last==limit) ier = 1
!
!           set error flag in the case of bad integrand behaviour
!           at some points of the integration range.
!
    if(max ( abs(a1),abs(b2)) <= (0.1e+01+0.1e+03*epmach)* &
    (abs(a2)+0.1e+04*uflow)) ier = 4
!
!           append the newly-created intervals to the list.
!
    if(error2 > error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   continue

    alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!           call subroutine qpsrt to maintain the descending ordering
!           in the list of error estimates and select the
!           subinterval with nrmax-th largest error estimate (to be
!           bisected next).
!
   30   continue

    call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
    if(errsum <= errbnd) go to 115
    if(ier/=0) go to 100
    if(last==2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if(abs(b1-a1) > small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!           test whether the interval to be bisected next is the
!           smallest interval.
!
    if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
    extrap = .true.
    nrmax = 2

   40   continue

    if(ierro==3.or.erlarg <= ertest) go to 60
!
!           the smallest interval has the largest error.
!           before bisecting decrease the sum of the errors
!           over the larger intervals (erlarg) and perform
!           extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last > (2+limit/2)) jupbnd = limit+3-last

    do k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
      if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
      nrmax = nrmax+1
    end do
!
!           perform extrapolation.
!
60  continue

    numrl2 = numrl2+1
    rlist2(numrl2) = area
    call qelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin > 5.and.abserr < 0.1e-02*errsum) ier = 5
    if(abseps >= abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest = max (epsabs,rerr*abs(reseps))
    if(abserr <= ertest) go to 100
!
!  Prepare bisection of the smallest interval.
!
70  continue

    if ( numrl2 == 1 ) noext = .true.
    if ( ier == 5 ) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small * 0.5e+00
    erlarg = errsum
    go to 90
80  continue

    small = 0.375e+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area

90  continue
!
!           set final result and error estimate.
!
!
  100 if(abserr==oflow) go to 115
  if((ier+ierro)==0) go to 110
  if(ierro==3) abserr = abserr+correc
  if(ier==0) ier = 3
  if(result/=0.0e+00.and.area/=0.0e+00)go to 105
  if(abserr > errsum)go to 115
  if(area==0.0e+00) go to 130
  go to 110
  105 if(abserr/abs(result) > errsum/abs(area))go to 115
!
!           test on divergence
!
  110 if(ksgn==(-1).and.max ( abs(result),abs(area)) <=  &
   defabs*0.1e-01) go to 130

  if( 0.1e-01 > (result/area) .or. &
    (result/area) > 0.1e+03 .or. &
    errsum > abs(area) ) then
    ier = 6
  end if

  go to 130
!
!           compute global integral sum.
!
  115 result = 0.0e+00
  do k = 1,last
    result = result+rlist(k)
  end do
  abserr = errsum
  130 neval = 30*last-15
  if(inf==2) neval = 2*neval
  if(ier > 2) ier=ier-1

  return
end
subroutine qagie1 ( f, phi, y, c, bound, inf, epsabs, epsrel, limit, result, &
  abserr, neval, ier, alist, blist, rlist, elist, iord, last )
!
!*******************************************************************************
!
!! QAGIE1 approximates an integral over an infinite interval.
!
!
!
! 2.     purpose
!           the routine calculates an approximation  result  to a given
!           integral    i = integral of  f  over (bound,+infinity)
!                    or i = integral of  f  over (-infinity,bound)
!                    or i = integral of  f  over (-infinity,+infinity),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
! 3.     calling sequence
!             call qagie1(f,phi,bound,inf,epsabs,epsrel,limit,result,
!                 abserr,neval,ier,alist,blist,rlist,elist,iord,last)
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!                     f has the arguments x and phi.
!
!            phi    - real
!                     function subprogram having a single real argument.
!                     the actual name for phi must be declared external
!                     in the driver program.
!
!            bound  - real
!                     finite bound of integration range
!                     (has no meaning if interval is doubly-infinite)
!
!            y      - real
!                     parameter for use in xcond.  ordinate of
!                     horizontal line along which integration
!                     is performed.
!
!            c      - real
!                     parameter for use in acond and xcond.
!
!            inf    - integer
!                     indicating the kind of integration range
!                     involved
!                     inf = 1 corresponds to  (bound,+infinity),
!                     inf = -1            to  (-infinity,bound),
!                     inf = 2             to (-infinity,+infinity).
!
!            epsabs - real
!                     absolute accuracy requested
!            epsrel - real
!                     relative accuracy requested
!                     if  epsabs <= 0
!                     and epsrel < max(50*rel.mach.acc.,0.5e-14),
!                     the routine will end with ier = 6.
!
!            limit  - integer
!                     gives an upper bound on the number of
!                     subintervals in the partition of (a,b),
!                     limit >= 1
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                   - ier > 0 abnormal termination of the routine. the
!                             estimates for result and error are less
!                             reliable. it is assumed that the requested
!                             accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more
!                             subdivisions by increasing the value
!                             of limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a local
!                             difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the
!                             subranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is
!                             detected, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour occurs
!                             at some points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             roundoff error is detected in the
!                             extrapolation table.
!                             it is assumed that the requested tolerance
!                             cannot be achieved, and that the returned
!                             result is the best which can be obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted that
!                             divergence can occur with any other value
!                             of ier.
!                         = 6 the input is invalid, because
!                             (epsabs <= 0 and
!                              epsrel < max(50*rel.mach.acc.,0.5e-14)),
!                             result, abserr, neval, last, rlist(1),
!                             elist(1) and iord(1) are set to zero.
!                             alist(1) and blist(1) are set to 0
!                             and 1 respectively.
!
!            alist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the left
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            blist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the right
!                     end points of the subintervals in the partition
!                     of the transformed integration range (0,1).
!
!            rlist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the integral
!                     approximations on the subintervals
!
!            elist  - real
!                     vector of dimension at least limit,  the first
!                      last  elements of which are the moduli
!                     of the absolute error estimates on the
!                     subintervals
!
!            iord   - integer
!                     vector of dimension limit, the first k
!                     elements of which are pointers to the
!                     error estimates over the subintervals,
!                     such that elist(iord(1)), ..., elist(iord(k))
!                     form a decreasing sequence, with k = last
!                     if last <= (limit/2+2), and k = limit+1-last
!                     otherwise
!
!            last   - integer
!                     number of subintervals actually produced
!                     in the subdivision process
!
! 4.     subroutines or functions needed
!              - qk15i1
!              - qpsrt
!              - qelg
!              - f (user-provided function)
!              - phi (user-provided function)
!
!
!
  real abseps,abserr,alist,area,area1,area12,area2,a1, &
    a2,blist,boun,bound,b1,b2,correc,defabs,defab1,defab2, &
    dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, &
    errmax,error1,error2,erro12,errsum,ertest,f,oflow,resabs, &
    reseps,result,res3la,rlist,rlist2,small,uflow
  integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, &
    ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
  logical extrap,noext
!
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
    res3la(3),rlist(limit),rlist2(52)
!
  external f, phi
!
!            the dimension of rlist2 is determined by the value of
!            limexp in subroutine qelg.
!
!
!            list of major variables
!
!
!           alist     - list of left end points of all subintervals
!                       considered up to now
!           blist     - list of right end points of all subintervals
!                       considered up to now
!           rlist(i)  - approximation to the integral over
!                       (alist(i),blist(i))
!           rlist2    - array of dimension at least (limexp+2),
!                       containing the part of the epsilon table
!                       wich is still needed for further computations
!           elist(i)  - error estimate applying to rlist(i)
!           maxerr    - pointer to the interval with largest error
!                       estimate
!           errmax    - elist(maxerr)
!           erlast    - error on the interval currently subdivided
!                       (before that subdivision has taken place)
!           area      - sum of the integrals over the subintervals
!           errsum    - sum of the errors over the subintervals
!           errbnd    - requested accuracy max(epsabs,epsrel*
!                       abs(result))
!           *****1    - variable for the left subinterval
!           *****2    - variable for the right subinterval
!           last      - index for subdivision
!           nres      - number of calls to the extrapolation routine
!           numrl2    - number of elements currently in rlist2. if an
!                       appropriate approximation to the compounded
!                       integral has been obtained, it is put in
!                       rlist2(numrl2) after numrl2 has been increased
!                       by one.
!           small     - length of the smallest interval considered up
!                       to now, multiplied by 1.5
!           erlarg    - sum of the errors over the intervals larger
!                       than the smallest interval considered up to now
!           extrap    - logical variable denoting that the routine
!                       is attempting to perform extrapolation. i.e.
!                       before subdividing the smallest interval we
!                       try to decrease the value of erlarg.
!           noext     - logical variable denoting that extrapolation
!                       is no longer allowed (true-value)
!
!            machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!           oflow is the largest positive magnitude.
!
   epmach = epsilon ( epmach )
!
!           test on validity of parameters
!
!
  ier = 0
  neval = 0
  last = 0
  result = 0.0e+00
  abserr = 0.0e+00
  alist(1) = 0.0e+00
  blist(1) = 0.1e+01
  rlist(1) = 0.0e+00
  elist(1) = 0.0e+00
  iord(1) = 0
  if(epsabs <= 0.0e+00.and.epsrel < max ( 0.5e+02*epmach,0.5e-14)) &
    ier = 6
  if(ier==6) go to 999
!
!
!           first approximation to the integral
!
!
!           determine the interval to be mapped onto (0,1).
!           if inf = 2 the integral is computed as i = i1+i2, where
!           i1 = integral of f over (-infinity,0),
!           i2 = integral of f over (0,+infinity).
!
  boun = bound
  if(inf==2) boun = 0.0e+00
  call qk15i1(f,phi,y,c,boun,inf,0.0e+00,0.1e+01,result,abserr, &
    defabs,resabs)
!
!           test on accuracy
!
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  dres = abs(result)
  errbnd = max ( epsabs,epsrel*dres)
  if(abserr <= 1.0e+02*epmach*defabs.and.abserr >  &
    errbnd) ier = 2
  if(limit==1) ier = 1
  if(ier/=0.or.(abserr <= errbnd.and.abserr/=resabs).or. &
    abserr==0.0e+00) go to 130
!
!           initialization
!           --------------
!
  uflow = tiny ( uflow )
  oflow = huge ( oflow )
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  correc = 0.0e+00
  nrmax = 1
  nres = 0
  ktmin = 0
  numrl2 = 2
  extrap = .false.
  noext = .false.
  ierro = 0
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0
  ksgn = -1
  if(dres >= (0.1e+01-0.5e+02*epmach)*defabs) ksgn = 1
!
!           main do-loop
!           ------------
!
  do 90 last = 2,limit
!
!           bisect the subinterval with nrmax-th largest
!           error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5e+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call qk15i1(f,phi,y,c,boun,inf,a1,b1,area1,error1,resabs,defab1)
    call qk15i1(f,phi,y,c,boun,inf,a2,b2,area2,error2,resabs,defab2)
!
!           improve previous approximations to integral
!           and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1==error1.or.defab2==error2)go to 15
    if(abs(rlist(maxerr)-area12) > 0.1e-04*abs(area12) &
    .or.erro12 < 0.99e+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
   10   if(last > 10.and.erro12 > errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
    rlist(last) = area2
    errbnd = max ( epsabs,epsrel*abs(area))
!
!           test for roundoff error and eventually
!           set error flag.
!
    if(iroff1+iroff2 >= 10.or.iroff3 >= 20) ier = 2
    if(iroff2 >= 5) ierro = 3
!
!           set error flag in the case that the number of
!           subintervals equals limit.
!
    if(last==limit) ier = 1
!
!           set error flag in the case of bad integrand behaviour
!           at some points of the integration range.
!
    if(max ( abs(a1),abs(b2)) <= (0.1e+01+0.1e+03*epmach)* &
    (abs(a2)+0.1e+04*uflow)) ier = 4
!
!           append the newly-created intervals to the list.
!
    if(error2 > error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!           call subroutine qpsrt to maintain the descending ordering
!           in the list of error estimates and select the
!           subinterval with nrmax-th largest error estimate (to be
!           bisected next).
!
   30   call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
    if(errsum <= errbnd) go to 115
    if(ier/=0) go to 100
    if(last==2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if(abs(b1-a1) > small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!           test whether the interval to be bisected next is the
!           smallest interval.
!
    if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
    extrap = .true.
    nrmax = 2
   40   if(ierro==3.or.erlarg <= ertest) go to 60
!
!           the smallest interval has the largest error.
!           before bisecting decrease the sum of the errors
!           over the larger intervals (erlarg) and perform
!           extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last > (2+limit/2)) jupbnd = limit+3-last
    do 50 k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
      if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
      nrmax = nrmax+1
   50   continue
!
!           perform extrapolation.
!
   60   numrl2 = numrl2+1
    rlist2(numrl2) = area
    call qelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin > 5.and.abserr < 0.1e-02*errsum) ier = 5
    if(abseps >= abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest = max ( epsabs,epsrel*abs(reseps))
    if(abserr <= ertest) go to 100
!
!            prepare bisection of the smallest interval.
!
   70   if(numrl2==1) noext = .true.
    if(ier==5) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small*0.5e+00
    erlarg = errsum
    go to 90
   80   small = 0.375e+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area
   90 continue
!
!           set final result and error estimate.
!           ------------------------------------
!
  100 if(abserr==oflow) go to 115
  if((ier+ierro)==0) go to 110
  if(ierro==3) abserr = abserr+correc
  if(ier==0) ier = 3
  if(result/=0.0e+00.and.area/=0.0e+00)go to 105
  if(abserr > errsum)go to 115
  if(area==0.0e+00) go to 130
  go to 110
  105 if(abserr/abs(result) > errsum/abs(area))go to 115
!
!  Test on divergence
!
  110 continue

  if(ksgn==(-1).and.max ( abs(result),abs(area)) <=  &
   defabs*0.1e-01) go to 130

  if ( 0.1e-01 > (result/area) .or. &
    (result/area) > 0.1e+03 .or. &
    errsum > abs(area) ) then
    ier = 6
  end if

  go to 130
!
!  Compute global integral sum.
!
  115 continue
  result = 0.0e+00
  do k = 1,last
    result = result+rlist(k)
  end do
  abserr = errsum
  130 neval = 30*last-15
  if(inf==2) neval = 2*neval
  if(ier > 2) ier=ier-1
  999 return
end
subroutine qags(f,a,b,epsabs,epsrel,result,abserr, &
    neval,ier,limit,lenw,last,iwork,work)
!
!*******************************************************************************
!
!! QAGS approximates an integral.
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           definite integral   i = integral of  f  over (a,b),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            a      - real
!                     lower limit of integration
!
!            b      - real
!                     upper limit of integration
!
!            epsabs - real
!                     absolute accuracy requested
!
!            epsrel - real
!                     relative accuracy requested
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                     ier > 0 abnormal termination of the routine
!                             the estimates for integral and error are
!                             less reliable. it is assumed that the
!                             requested accuracy has not been achieved.
!
!                     ier = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more sub-
!                             divisions by increasing the value of
!                             limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a
!                             local difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the sub-
!                             ranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is detec-
!                             ted, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour
!                             occurs at some  points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             it is presumed that the requested
!                             tolerance cannot be achieved, and that the
!                             returned result is the best which can be
!                             obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted
!                             that divergence can occur with any other
!                             value of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative, limit < 1,
!                             or lenw < 4 * limit.
!                             result, abserr, neval, last are
!                             set to zero.
!
!         dimensioning parameters
!            limit - integer
!                    dimensioning parameter for iwork
!                    limit determines the maximum number
!                    of subintervals in the partition of the given
!                    integration interval (a,b), limit >= 1.
!                    if limit < 1, the routine will end with
!                    ier = 6.
!
!            lenw  - integer
!                    dimensioning parameter for work
!                    lenw must be at least limit*4.
!                    if lenw < limit*4, the routine will end
!                    with ier = 6.
!
!            last  - integer
!                    on return, last equals the number of
!                    subintervals produced in the subdivision
!                    process, which determines the number of
!                    significant elements actually in the work
!                    arrays.
!
!         work arrays
!            iwork - integer
!                    vector of dimension at least limit, the first k
!                    elements of which contain pointers
!                    to the error estimates over the subintervals
!                    such that work(limit*3+iwork(1)),... ,
!                    work(limit*3+iwork(k)) form a decreasing
!                    sequence, with k = last if last <= (limit/2+2), and
!                    k = limit+1-last otherwise
!
!            work  - real
!                    vector of dimension at least lenw
!                    on return
!                    work(1), ..., work(last) contain the left
!                     end points of the subintervals in the
!                     partition of (a,b),
!                    work(limit+1), ..., work(limit+last) contain
!                     the right end points,
!                    work(limit*2+1), ..., work(limit*2+last)
!                     contain the integral approximations over
!                     the subintervals,
!                    work(limit*3+1), ..., work(limit*3+last)
!                     contain the error estimates.
!
!         subroutines or functions needed
!              - qagse
!              - qk21f
!              - qpsrt
!              - qelg
!              - f (user-provided function)
!
!
  real a,abserr,b,epsabs,epsrel,f,result,work
  integer ier,iwork,lenw,limit,l1,l2,l3,neval
!
  dimension iwork(limit),work(lenw)
!
  external f
!
!         check validity of limit and lenw.
!
  ier = 6
  neval = 0
  last = 0
  result = 0.0
  abserr = 0.0
  if (limit < 1 .or. lenw  <  limit*4) return
!
!         prepare call for qagse.
!
  l1 = limit+1
  l2 = limit+l1
  l3 = limit+l2
!
  call qagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, &
    ier,work(1),work(l1),work(l2),work(l3),iwork,last)
  return
end
subroutine qagse(f,a,b,epsabs,epsrel,limit,result,abserr, &
    neval,ier,alist,blist,rlist,elist,iord,last)
!
!*******************************************************************************
!
!! QAGSE approximates an integral.
!
!
!        purpose
!           the routine calculates an approximation  result  to a given
!           definite integral   i = integral of  f  over (a,b),
!           hopefully satisfying following claim for accuracy
!           abs(i-result) <= max(epsabs,epsrel*abs(i)).
!
!        parameters
!         on entry
!            f      - real
!                     function subprogram defining the integrand
!                     function f(x). the actual name for f needs to be
!                     declared e x t e r n a l in the driver program.
!
!            a      - real
!                     lower limit of integration
!
!            b      - real
!                     upper limit of integration
!
!            epsabs - real
!                     absolute accuracy requested
!
!            epsrel - real
!                     relative accuracy requested
!
!            limit  - integer
!                     gives an upperbound on the number of
!                     subintervals in the partition of (a,b)
!
!         on return
!            result - real
!                     approximation to the integral
!
!            abserr - real
!                     estimate of the modulus of the absolute error,
!                     which should equal or exceed abs(i-result)
!
!            neval  - integer
!                     number of integrand evaluations
!
!            ier    - integer
!                     ier = 0 normal and reliable termination of the
!                             routine. it is assumed that the requested
!                             accuracy has been achieved.
!                     ier > 0 abnormal termination of the routine
!                             the estimates for integral and error are
!                             less reliable. it is assumed that the
!                             requested accuracy has not been achieved.
!
!                         = 1 maximum number of subdivisions allowed
!                             has been achieved. one can allow more sub-
!                             divisions by increasing the value of
!                             limit (and taking the according
!                             dimension adjustments into account).
!                             however, if this yields no improvement
!                             it is advised to analyze the integrand
!                             in order to determine the integration
!                             difficulties. if the position of a
!                             local difficulty can be determined (e.g.
!                             singularity, discontinuity within the
!                             interval) one will probably gain from
!                             splitting up the interval at this point
!                             and calling the integrator on the sub-
!                             ranges. if possible, an appropriate
!                             special-purpose integrator should be used,
!                             which is designed for handling the type
!                             of difficulty involved.
!                         = 2 the occurrence of roundoff error is detec-
!                             ted, which prevents the requested
!                             tolerance from being achieved.
!                             the error may be under-estimated.
!                         = 3 extremely bad integrand behaviour
!                             occurs at some  points of the integration
!                             interval.
!                         = 4 the algorithm does not converge.
!                             it is presumed that the requested
!                             tolerance cannot be achieved, and that the
!                             returned result is the best which can be
!                             obtained.
!                         = 5 the integral is probably divergent, or
!                             slowly convergent. it must be noted
!                             that divergence can occur with any other
!                             value of ier.
!                         = 6 the input is invalid because epsabs
!                             or epsrel is negative.
!                             result, abserr, neval, last, rlist(1),
!                             iord(1) and elist(1) are set to zero.
!                             alist(1) and blist(1) are set to a and b
!                             respectively.
!
!            alist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the left
!                     end points of the subintervals in the partition
!                     of the given integration range (a,b)
!
!            blist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the right
!                     end points of the subintervals in the partition
!                     of the given integration range (a,b)
!
!            rlist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the integral
!                     approximations on the subintervals
!
!            elist  - real
!                     vector of dimension at least limit, the first
!                      last  elements of which are the moduli
!                     of the absolute error estimates on the
!                     subinervals
!
!            iord   - integer
!                     vector of dimension at least limit, the first k
!                     elements of which are pointers to the error
!                     estimates over the subintervals, such
!                     that elist(iord(1)), ..., elist(iord(k))
!                     form a decreasing sequence, with k = last
!                     if last <= (limit/2+2), and k = limit+1-last
!                     otherwise
!
!            last   - integer
!                     number of subintervals actually produced in the
!                     subdivision process
!
!         subroutines or functions needed
!              - qk21f
!              - qpsrt
!              - qelg
!              - f (user-provided function)
!              - fortran abs, max1, amin1
!
!
  real a,abseps,abserr,alist,area,area1,area12,area2,a1,a2, &
    b,blist,b1,b2,correc,defabs,defab1,defab2,dres,elist, &
    epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, &
    error1,error2,erro12,errsum,ertest,f,oflow,rerr,resabs, &
    reseps,result,res3la,rlist,rlist2,small,uflow
  integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, &
    ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
  logical extrap,noext
!
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
   res3la(3),rlist(limit),rlist2(52)
!
  external f
!
!            the dimension of rlist2 is determined by the value of
!            limexp in subroutine qelg (rlist2 should be of dimension
!            (limexp+2) at least).
!
!            list of major variables
!            -----------------------
!
!           alist     - list of left end points of all subintervals
!                       considered up to now
!           blist     - list of right end points of all subintervals
!                       considered up to now
!           rlist(i)  - approximation to the integral over
!                       (alist(i),blist(i))
!           rlist2    - array of dimension at least limexp+2
!                       containing the part of the epsilon table
!                       which is still needed for further computations
!           elist(i)  - error estimate applying to rlist(i)
!           maxerr    - pointer to the interval with largest error
!                       estimate
!           errmax    - elist(maxerr)
!           erlast    - error on the interval currently subdivided
!                       (before that subdivision has taken place)
!           area      - sum of the integrals over the subintervals
!           errsum    - sum of the errors over the subintervals
!           errbnd    - requested accuracy max(epsabs,epsrel*
!                       abs(result))
!           *****1    - variable for the left interval
!           *****2    - variable for the right interval
!           last      - index for subdivision
!           nres      - number of calls to the extrapolation routine
!           numrl2    - number of elements currently in rlist2. if an
!                       appropriate approximation to the compounded
!                       integral has been obtained it is put in
!                       rlist2(numrl2) after numrl2 has been increased
!                       by one.
!           small     - length of the smallest interval considered
!                       up to now, multiplied by 1.5
!           erlarg    - sum of the errors over the intervals larger
!                       than the smallest interval considered up to now
!           extrap    - logical variable denoting that the routine
!                       is attempting to perform extrapolation
!                       i.e. before subdividing the smallest interval
!                       we try to decrease the value of erlarg.
!           noext     - logical variable denoting that extrapolation
!                       is no longer allowed (true value)
!
!            machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!           oflow is the largest positive magnitude.
!
  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
  oflow = huge ( oflow )
!
!            check epsabs and epsrel
!
!
  neval = 0
  last = 0
  result = 0.0
  abserr = 0.0
  alist(1) = a
  blist(1) = b
  rlist(1) = 0.0
  elist(1) = 0.0
  ier = 6
  if (epsabs < 0.0 .or. epsrel  <  0.0) go to 999
  ier = 0
  rerr = max ( epsrel, 50.0*epmach, 0.5e-14)
!
!           first approximation to the integral
!
!
  ierro = 0
  call qk21f(f,a,b,result,abserr,defabs,resabs,id)
  if (id /= 0) go to 999
!
!           test on accuracy.
!
  dres = abs(result)
  errbnd = max ( epsabs,rerr*dres)
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  if(abserr <= 1.0e+02*epmach*defabs.and.abserr >  &
    errbnd) ier = 2
  if(limit==1) ier = 1
  if(ier/=0.or.(abserr <= errbnd.and.abserr/=resabs).or. &
    abserr==0.0e+00) go to 140
!
!           initialization
!           --------------
!
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  correc = 0.0e+00
  nrmax = 1
  nres = 0
  numrl2 = 2
  ktmin = 0
  extrap = .false.
  noext = .false.
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0
  ksgn = -1
  if(dres >= (0.1e+01-0.5e+02*epmach)*defabs) ksgn = 1
!
!           main do-loop
!
!
  do 90 last = 2,limit
!
!           bisect the subinterval with the nrmax-th largest
!           error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5e+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call qk21f(f,a1,b1,area1,error1,resabs,defab1,ier)
    if (ier /= 0) go to 100
    call qk21f(f,a2,b2,area2,error2,resabs,defab2,ier)
!
!           improve previous approximations to integral
!           and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1==error1.or.defab2==error2) go to 15
    if(abs(rlist(maxerr)-area12) > 0.1e-04*abs(area12) &
    .or.erro12 < 0.99e+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
   10   if(last > 10.and.erro12 > errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
    rlist(last) = area2
    errbnd = max ( epsabs,rerr*abs(area))
!
!           test for roundoff error and eventually
!           set error flag.
!
    if(iroff1+iroff2 >= 10.or.iroff3 >= 20) ier = 2
    if(iroff2 >= 5) ierro = 3
!
!           set error flag in the case that the number of
!           subintervals equals limit.
!
    if(last==limit) ier = 1
!
!           set error flag in the case of bad integrand behaviour
!           at a point of the integration range.
!
    if(max ( abs(a1),abs(b2)) <= (0.1e+01+0.1e+03*epmach)* &
    (abs(a2)+0.1e+04*uflow)) ier = 4
!
!           append the newly-created intervals to the list.
!
    if(error2 > error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!           call subroutine qpsrt to maintain the descending ordering
!           in the list of error estimates and select the
!           subinterval with nrmax-th largest error estimate (to be
!           bisected next).
!
   30   call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
! ***jump out of do-loop
    if(errsum <= errbnd) go to 115
! ***jump out of do-loop
    if(ier/=0) go to 100
    if(last==2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if(abs(b1-a1) > small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!           test whether the interval to be bisected next is the
!           smallest interval.
!
    if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
    extrap = .true.
    nrmax = 2
   40   if(ierro==3.or.erlarg <= ertest) go to 60
!
!           the smallest interval has the largest error.
!           before bisecting decrease the sum of the errors
!           over the larger intervals (erlarg) and perform
!           extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last > (2+limit/2)) jupbnd = limit+3-last
    do 50 k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
! ***jump out of do-loop
      if(abs(blist(maxerr)-alist(maxerr)) > small) go to 90
      nrmax = nrmax+1
   50   continue
!
!           perform extrapolation.
!
   60   numrl2 = numrl2+1
    rlist2(numrl2) = area
    call qelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin > 5.and.abserr < 0.1e-02*errsum) ier = 5
    if(abseps >= abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest = max ( epsabs,rerr*abs(reseps))
! ***jump out of do-loop
    if(abserr <= ertest) go to 100
!
!           prepare bisection of the smallest interval.
!
   70   if(numrl2==1) noext = .true.
    if(ier==5) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small*0.5e+00
    erlarg = errsum
    go to 90
   80   small = abs(b-a)*0.375e+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area
   90 continue
!
!           set final result and error estimate.
!
!
  100 if(abserr==oflow) go to 115
  if(ier+ierro==0) go to 110
  if(ierro==3) abserr = abserr+correc
  if(ier==0) ier = 3
  if(result/=0.0e+00.and.area/=0.0e+00) go to 105
  if(abserr > errsum) go to 115
  if(area==0.0e+00) go to 130
  go to 110
  105 if(abserr/abs(result) > errsum/abs(area)) go to 115
!
!           test on divergence.
!
  110 if(ksgn==(-1).and.max ( abs(result),abs(area)) <=  &
   defabs*0.1e-01) go to 130
  if(0.1e-01 > (result/area).or.(result/area) > 0.1e+03 &
   .or.errsum > abs(area)) ier = 6
  go to 130
!
!           compute global integral sum.
!
  115 result = 0.0e+00
  do 120 k = 1,last
     result = result+rlist(k)
  120 continue
  abserr = errsum
  130 if(ier > 2) ier = ier-1
  140 neval = 42*last-21
  999 return
end
subroutine qdcrt (a, z)
!
!*******************************************************************************
!
!! QDCRT computes the roots of a real quadratic polynomial.
!
!              a(1) + a(2)*z + a(3)*z**2
!     and stores the results in z. it is assumed that a(3)
!     is nonzero.
!
!
  real a(3)
  real eps
  complex z(2)
!
  eps = epsilon ( eps )
  if (a(1) == 0.0) go to 40
  d = a(2)*a(2) - 4.0*a(1)*a(3)
  if (abs(d) <= 2.0*eps*a(2)*a(2)) go to 20
  r = sqrt(abs(d))
  if (d < 0.0) go to 30
!
!                 distinct real roots
!
  if (a(2) /= 0.0) go to 10
     x = abs(0.5*r/a(3))
     z(1) = cmplx(x, 0.0)
     z(2) = cmplx(-x, 0.0)
     return
   10 w = -(a(2) + sign(r,a(2)))
  z(1) = cmplx(2.0*a(1)/w, 0.0)
  z(2) = cmplx(0.5*w/a(3), 0.0)
  return
!
!                  equal real roots
!
   20 z(1) = cmplx(-0.5*a(2)/a(3), 0.0)
  z(2) = z(1)
  return
!
!                   complex roots
!
   30 x = -0.5*a(2)/a(3)
  y = abs(0.5*r/a(3))
  z(1) = cmplx(x, y)
  z(2) = cmplx(x,-y)
  return
!
!                 case when a(1) = 0
!
   40 z(1) = (0.0, 0.0)
  z(2) = cmplx(-a(2)/a(3), 0.0)
  return
end
subroutine qelg(n,epstab,result,abserr,res3la,nres)
!
!*******************************************************************************
!
!! QELG: epsilon algorithm
!
!
! 2.        purpose
!              the routine determines the limit of a given sequence of
!              approximations, by means of the epsilon algorithm
!              of p. wynn.
!              an estimate of the absolute error is also given.
!              the condensed epsilon table is computed. only those
!              elements needed for the computation of the next diagonal
!              are preserved.
!
! 3.        calling sequence
!              call qelg(n,epstab,result,abserr,res3la,nres)
!
!           parameters
!              n      - integer
!                       epstab(n) contains the new element in the
!                       first column of the epsilon table.
!
!              epstab - real
!                       vector of dimension 52 containing the
!                       elements of the two lower diagonals of
!                       the triangular epsilon table
!                       the elements are numbered starting at the
!                       right-hand corner of the triangle.
!
!              result - real
!                       resulting approximation to the integral
!
!              abserr - real
!                       estimate of the absolute error computed from
!                       result and the 3 previous results
!
!              res3la - real
!                       vector of dimension 3 containing the last 3
!                       results
!
!              nres   - integer
!                       number of calls to the routine
!                       (should be zero at first call)
!
! 4.        subroutines or functions needed
!
!
!
  real abserr,delta1,delta2,delta3,epmach,epsinf,epstab, &
    error,err1,err2,err3,e0,e1,e1abs,e2,e3,oflow,res, &
    result,res3la,ss,tol1,tol2,tol3
  integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num
  dimension epstab( *),res3la(*)
!
!           list of major variables
!
!
!           e0     - the 4 elements on which the
!           e1       computation of a new element in
!           e2       the epsilon table is based
!           e3                 e0
!                        e3    e1    new
!                              e2
!           newelm - number of elements to be computed in the new
!                    diagonal
!           error  - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
!           result - the element in the new diagonal with least value
!                    of error
!
!           machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           oflow is the largest positive magnitude.
!           limexp is the maximum number of elements the epsilon
!           table can contain. if this number is reached, the upper
!           diagonal of the epsilon table is deleted.
!
!***first executable statement  qelg
  epmach = epsilon ( epmach )
  oflow = huge ( oflow )
  nres = nres+1
  abserr = oflow
  result = epstab(n)
  if(n < 3) go to 100
  limexp = 50
  epstab(n+2) = epstab(n)
  newelm = (n-1)/2
  epstab(n) = oflow
  num = n
  k1 = n
  do 40 i = 1,newelm
    k2 = k1-1
    k3 = k1-2
    res = epstab(k1+2)
    e0 = epstab(k3)
    e1 = epstab(k2)
    e2 = res
    e1abs = abs(e1)
    delta2 = e2-e1
    err2 = abs(delta2)
    tol2 = max ( abs(e2),e1abs)*epmach
    delta3 = e1-e0
    err3 = abs(delta3)
    tol3 = max ( e1abs,abs(e0))*epmach
    if(err2 > tol2.or.err3 > tol3) go to 10
!
!           if e0, e1 and e2 are equal to within machine
!           accuracy, convergence is assumed.
!           result = e2
!           abserr = abs(e1-e0)+abs(e2-e1)
!
    result = res
    abserr = err2+err3
! ***jump out of do-loop
    go to 100
   10   e3 = epstab(k1)
    epstab(k1) = e1
    delta1 = e1-e3
    err1 = abs(delta1)
    tol1 = max ( e1abs,abs(e3))*epmach
!
!           if two elements are very close to each other, omit
!           a part of the table by adjusting the value of n
!
    if(err1 <= tol1.or.err2 <= tol2.or.err3 <= tol3) go to 20
    ss = 0.1e+01/delta1+0.1e+01/delta2-0.1e+01/delta3
    epsinf = abs(ss*e1)
!
!           test to detect irregular behaviour in the table, and
!           eventually omit a part of the table adjusting the value
!           of n.
!
    if(epsinf > 0.1e-03) go to 30
   20   n = i+i-1
! ***jump out of do-loop
    go to 50
!
!           compute a new element and eventually adjust
!           the value of result.
!
   30   res = e1+0.1e+01/ss
    epstab(k1) = res
    k1 = k1-2
    error = err2+abs(res-e2)+err3
    if(error > abserr) go to 40
    abserr = error
    result = res
   40 continue
!
!           shift the table.
!
   50 if(n==limexp) n = 2*(limexp/2)-1
  ib = 1
  if((num/2)*2==num) ib = 2
  ie = newelm+1
  do 60 i=1,ie
    ib2 = ib+2
    epstab(ib) = epstab(ib2)
    ib = ib2
   60 continue
  if(num==n) go to 80
  indx = num-n+1
  do 70 i = 1,n
    epstab(i)= epstab(indx)
    indx = indx+1
   70 continue
   80 if(nres >= 4) go to 90
  res3la(nres) = result
  abserr = oflow
  go to 100
!
!           compute error estimate
!
   90 abserr = abs(result-res3la(3))+abs(result-res3la(2)) &
    +abs(result-res3la(1))
  res3la(1) = res3la(2)
  res3la(2) = res3la(3)
  res3la(3) = result
  100 abserr = max ( abserr,0.5e+01*epmach*abs(result))
  return
end
subroutine qform ( m, n, q, ldq )
!
!*******************************************************************************
!
!! QFORM produces the explicit QR factorization of a matrix.
!
!
!  Discussion:
!
!    The QR factorization of a matrix is usually accumulated in implicit
!    form, that is, as a series of orthogonal transformations of the
!    original matrix.  This routine carries out those transformations,
!    to explicitly exhibit the factorization construced by QRFAC.
!
!  Parameters:
!
!    Input, integer M, is a positive integer input variable set to the number
!    of rows of A and the order of Q.
!
!    Input, integer N, is a positive integer input variable set to the number
!    of columns of A.
!
!    Input/output, real Q(LDQ,M).  Q is an M by M array.
!    On input the full lower trapezoid in the first min(M,N) columns of Q
!    contains the factored form.
!    On output, Q has been accumulated into a square matrix.
!
!    Input, integer LDQ, is a positive integer input variable not less
!    than M which specifies the leading dimension of the array Q.
!
  integer ldq
  integer m
  integer n
!
  integer i
  integer j
  integer jm1
  integer k
  integer l
  integer minmn
  real q(ldq,m)
  real temp
  real wa(m)
!
  minmn = min ( m, n )

  do j = 2, minmn
    q(1:j-1,j) = 0.0E+00
  end do
!
!  Initialize remaining columns to those of the identity matrix.
!
  do j = n+1, m
    do i = 1, m
      q(i,j) = 0.0E+00
    end do
    q(j,j) = 1.0E+00
  end do
!
!  Accumulate Q from its factored form.
!
  do l = 1, minmn

    k = minmn - l + 1

    wa(k:m) = q(k:m,k)

    q(k:m,k) = 0.0E+00
    q(k,k) = 1.0E+00

    if ( wa(k) /= 0.0E+00 ) then

      do j = k, m
        temp = dot_product ( wa(k:m), q(k:m,j) ) / wa(k)
        do i = k, m
          q(i,j) = q(i,j) - temp * wa(i)
        end do
      end do

    end if

  end do

  return
end
subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
!
!*******************************************************************************
!
!! QK15I: integration rule
!
!
! 2.        purpose
!              the original (infinite) integration range is mapped
!              onto the interval (0,1) and (a,b) is a part of (0,1).
!              it is the purpose to compute
!              i = integral of transformed integrand over (a,b),
!              j = integral of abs(transformed integrand) over (a,b).
!
! 3.        calling sequence
!              call qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
!
!           parameters
!            on entry
!              f      - real
!                       function subprogram defining the integrand
!                       function f(x). the actual name for f needs
!                       to be declared e x t e r n a l in the
!                       calling program.
!
!              boun   - real
!                       finite bound of original integration
!                       range (set to zero if inf = +2)
!
!              inf    - integer
!                       if inf = -1, the original interval is
!                                   (-infinity,bound),
!                       if inf = +1, the original interval is
!                                   (bound,+infinity),
!                       if inf = +2, the original interval is
!                                   (-infinity,+infinity) and
!                       the integral is computed as the sum of two
!                       integrals, one over (-infinity,0)
!                       and one over (0,+infinity).
!
!              a      - real
!                       lower limit for integration over subrange
!                       of (0,1)
!
!              b      - real
!                       upper limit for integration over subrange
!                       of (0,1)
!
!            on return
!              result - real
!                       approximation to the integral i
!                       result is computed by applying the 15-point
!                       kronrod rule(resk) obtained by optimal
!                       addition of abscissae to the 7-point gauss
!                       rule(resg).
!
!              abserr - real
!                       estimate of the modulus of the absolute error,
!                       which should equal or exceed abs(i-result)
!
!              resabs - real
!                       approximation to the integral j
!
!              resasc - real
!                       approximation to the integral of
!                       abs((transformed integrand)-i/(b-a))
!                       over (a,b)
!
! 4.        subroutines or functions needed
!                 - f (user-provided function)
!

  real a,absc,absc1,absc2,abserr,b,boun,centr,dinf,epmach, &
    f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, &
    resg,resk,reskh,result,tabsc1,tabsc2, &
    uflow,wg,wgk,xgk
  integer inf,j,min0
  external f
!
  dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
!
!           the abscissae and weights are supplied for the interval
!           (-1,1).  because of symmetry only the positive abscissae and
!           their corresponding weights are given.
!
!           xgk    - abscissae of the 15-point kronrod rule
!                    xgk(2), xgk(4), ... abscissae of the 7-point
!                    gauss rule
!                    xgk(1), xgk(3), ...  abscissae which are optimally
!                    added to the 7-point gauss rule
!
!           wgk    - weights of the 15-point kronrod rule
!
!           wg     - weights of the 7-point gauss rule, corresponding
!                    to the abscissae xgk(2), xgk(4), ...
!                    wg(1), wg(3), ... are set to zero.
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), &
    xgk(8)/ &
       0.9914553711208126e+00,     0.9491079123427585e+00, &
       0.8648644233597691e+00,     0.7415311855993944e+00, &
       0.5860872354676911e+00,     0.4058451513773972e+00, &
       0.2077849550078985e+00,     0.0000000000000000e+00/
!
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), &
    wgk(8)/ &
       0.2293532201052922e-01,     0.6309209262997855e-01, &
       0.1047900103222502e+00,     0.1406532597155259e+00, &
       0.1690047266392679e+00,     0.1903505780647854e+00, &
       0.2044329400752989e+00,     0.2094821410847278e+00/
!
  data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ &
       0.0000000000000000e+00,     0.1294849661688697e+00, &
       0.0000000000000000e+00,     0.2797053914892767e+00, &
       0.0000000000000000e+00,     0.3818300505051189e+00, &
       0.0000000000000000e+00,     0.4179591836734694e+00/
!
!
!           list of major variables
!
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc*  - abscissa
!           tabsc* - transformed abscissa
!           fval*  - function value
!           resg   - result of the 7-point gauss formula
!           resk   - result of the 15-point kronrod formula
!           reskh  - approximation to the mean value of the transformed
!                    integrand over (a,b), i.e. to i/(b-a)
!
!           machine dependent constants
!           ---------------------------
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!
!***first executable statement  qk15i
  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
  dinf = min (1,inf)
!
  centr = 0.5e+00*(a+b)
  hlgth = 0.5e+00*(b-a)
  tabsc1 = boun+dinf*(0.1e+01-centr)/centr
  fval1 = f(tabsc1)
  if(inf==2) fval1 = fval1+f(-tabsc1)
  fc = (fval1/centr)/centr
!
!           compute the 15-point kronrod approximation to
!           the integral, and estimate the error.
!
  resg = wg(8)*fc
  resk = wgk(8)*fc
  resabs = abs(resk)
  do 10 j=1,7
    absc = hlgth*xgk(j)
    absc1 = centr-absc
    absc2 = centr+absc
    tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1
    tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2
    fval1 = f(tabsc1)
    fval2 = f(tabsc2)
    if(inf==2) fval1 = fval1+f(-tabsc1)
    if(inf==2) fval2 = fval2+f(-tabsc2)
    fval1 = (fval1/absc1)/absc1
    fval2 = (fval2/absc2)/absc2
    fv1(j) = fval1
    fv2(j) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(j)*fsum
    resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
   10 continue
  reskh = resk*0.5e+00
  resasc = wgk(8)*abs(fc-reskh)
  do 20 j=1,7
    resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
  result = resk*hlgth
  resasc = resasc*hlgth
  resabs = resabs*hlgth
  abserr = abs((resk-resg)*hlgth)
  if(resasc/=0.0e+00.and.abserr/=0.e0) abserr = resasc* &
   amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00)
  if(resabs > uflow/(0.5e+02*epmach)) abserr = max &
   ((epmach*0.5e+02)*resabs,abserr)
  return
end
subroutine qk15i1(f,phi,y,c,boun,inf,a,b,result,abserr,resabs, &
  resasc)
!
!*******************************************************************************
!
!! QK15I1: integration rule
!
!
! 2.        purpose
!              the original (infinite) integration range is mapped
!              onto the interval (0,1) and (a,b) is a part of (0,1).
!              it is the purpose to compute
!              i = integral of transformed integrand over (a,b),
!              j = integral of abs(transformed integrand) over (a,b).
!
! 3.        calling sequence
!           call qk15i1(f,phi,boun,inf,a,b,result,abserr,resabs,resasc)
!
!           parameters
!            on entry
!              f      - real
!                       function subprogram defining the integrand
!                       function f(x). the actual name for f needs
!                       to be declared e x t e r n a l in the
!                       calling program. f has the arguments x and
!                       phi.
!
!              phi    - real
!                       function subprogram having a single real
!                       argument. the actual name for phi must be
!                       dechared external in the driver program.
!
!              boun   - real
!                       finite bound of original integration
!                       range (set to zero if inf = +2)
!
!              inf    - integer
!                       if inf = -1, the original interval is
!                                   (-infinity,bound),
!                       if inf = +1, the original interval is
!                                   (bound,+infinity),
!                       if inf = +2, the original interval is
!                                   (-infinity,+infinity) and
!                       the integral is computed as the sum of two
!                       integrals, one over (-infinity,0)
!                       and one over (0,+infinity).
!
!              a      - real
!                       lower limit for integration over subrange
!                       of (0,1)
!
!              b      - real
!                       upper limit for integration over subrange
!                       of (0,1)
!
!            on return
!              result - real
!                       approximation to the integral i
!                       result is computed by applying the 15-point
!                       kronrod rule(resk) obtained by optimal
!                       addition of abscissae to the 7-point gauss
!                       rule(resg).
!
!              abserr - real
!                       estimate of the modulus of the absolute error,
!                       which should equal or exceed abs(i-result)
!
!              resabs - real
!                       approximation to the integral j
!
!              resasc - real
!                       approximation to the integral of
!                       abs((transformed integrand)-i/(b-a))
!                       over (a,b)
!
! 4.        subroutines or functions needed
!                 - f (user-provided function)
!                 - phi (user-provided function)
!                 - fortran abs, amax1, amin1, min0
!

  real a,absc,absc1,absc2,abserr,b,boun,centr,dinf,epmach, &
    f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, &
    resg,resk,reskh,result,tabsc1,tabsc2, &
    uflow,wg,wgk,xgk
  integer inf,j,min0
  external f, phi
!
  dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
!
!           the abscissae and weights are supplied for the interval
!           (-1,1).  because of symmetry only the positive abscissae and
!           their corresponding weights are given.
!
!           xgk    - abscissae of the 15-point kronrod rule
!                    xgk(2), xgk(4), ... abscissae of the 7-point
!                    gauss rule
!                    xgk(1), xgk(3), ...  abscissae which are optimally
!                    added to the 7-point gauss rule
!
!           wgk    - weights of the 15-point kronrod rule
!
!           wg     - weights of the 7-point gauss rule, corresponding
!                    to the abscissae xgk(2), xgk(4), ...
!                    wg(1), wg(3), ... are set to zero.
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), &
    xgk(8)/ &
       0.9914553711208126e+00,     0.9491079123427585e+00, &
       0.8648644233597691e+00,     0.7415311855993944e+00, &
       0.5860872354676911e+00,     0.4058451513773972e+00, &
       0.2077849550078985e+00,     0.0000000000000000e+00/
!
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), &
    wgk(8)/ &
       0.2293532201052922e-01,     0.6309209262997855e-01, &
       0.1047900103222502e+00,     0.1406532597155259e+00, &
       0.1690047266392679e+00,     0.1903505780647854e+00, &
       0.2044329400752989e+00,     0.2094821410847278e+00/
!
  data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ &
       0.0000000000000000e+00,     0.1294849661688697e+00, &
       0.0000000000000000e+00,     0.2797053914892767e+00, &
       0.0000000000000000e+00,     0.3818300505051189e+00, &
       0.0000000000000000e+00,     0.4179591836734694e+00/
!
!
!           list of major variables
!
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc*  - abscissa
!           tabsc* - transformed abscissa
!           fval*  - function value
!           resg   - result of the 7-point gauss formula
!           resk   - result of the 15-point kronrod formula
!           reskh  - approximation to the mean value of the transformed
!                    integrand over (a,b), i.e. to i/(b-a)
!
!           machine dependent constants
!
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!
!***first executable statement  qk15i1
  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
  dinf = min (1,inf)
!
  centr = 0.5e+00*(a+b)
  hlgth = 0.5e+00*(b-a)
  tabsc1 = boun+dinf*(0.1e+01-centr)/centr
  fval1 = f(tabsc1,y,c,phi)
  if(inf==2) fval1 = fval1+f(-tabsc1,y,c,phi)
  fc = (fval1/centr)/centr
!
!           compute the 15-point kronrod approximation to
!           the integral, and estimate the error.
!
  resg = wg(8)*fc
  resk = wgk(8)*fc
  resabs = abs(resk)
  do 10 j=1,7
    absc = hlgth*xgk(j)
    absc1 = centr-absc
    absc2 = centr+absc
    tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1
    tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2
    fval1 = f(tabsc1,y,c,phi)
    fval2 = f(tabsc2,y,c,phi)
    if(inf==2) fval1 = fval1+f(-tabsc1,y,c,phi)
    if(inf==2) fval2 = fval2+f(-tabsc2,y,c,phi)
    fval1 = (fval1/absc1)/absc1
    fval2 = (fval2/absc2)/absc2
    fv1(j) = fval1
    fv2(j) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(j)*fsum
    resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
   10 continue
  reskh = resk*0.5e+00
  resasc = wgk(8)*abs(fc-reskh)
  do 20 j=1,7
    resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
  result = resk*hlgth
  resasc = resasc*hlgth
  resabs = resabs*hlgth
  abserr = abs((resk-resg)*hlgth)
  if(resasc/=0.0e+00.and.abserr/=0.e0) abserr = resasc* &
   amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00)
  if(resabs > uflow/(0.5e+02*epmach)) abserr = amax1 &
   ((epmach*0.5e+02)*resabs,abserr)
  return
end
subroutine qk21f(f,a,b,result,abserr,resabs,resasc,isig)
!
!*******************************************************************************
!
!! QK21F: integration rules
!              standard fortran subroutine
!              real version
!
! 2.        purpose
!              to compute i = integral of f over (a,b), with error
!                             estimate
!                         j = integral of abs(f) over (a,b)
!
! 3.        calling sequence
!              call qk21f(f,a,b,result,abserr,resabs,resasc,isig)
!
!           parameters
!            on entry
!              f      - real
!                       function subprogram defining the integrand
!                       function f(x). the actual name for f needs
!                       to be declared e x t e r n a l in the
!                       calling program.
!
!              a      - real
!                       lower limit of integration
!
!              b      - real
!                       upper limit of integration
!
!            on return
!              result - real
!                       approximation to the integral i
!                       result is computed by applying the 21-point
!                       kronrod rule (resk) obtained by optimal
!                       addition of abscissae to the 10-point gauss
!                       rule (resg).
!
!              abserr - real
!                       estimate of the modulus of the absolute error,
!                       which should not exceed abs(i-result)
!
!              resabs - real
!                       approximation to the integral j
!
!              resasc - real
!                       approximation to the integral of abs(f-i/(b-a))
!                       over (a,b)
!
!              isig   - integer
!                       isig=0  the integral was approximated.
!                       isig=5  the interval (a,b) is too short.
!                               the integral cannot be computed.
!
! 4.        subroutines or functions needed
!                 - f (user-provided function)
  real a,absc,abserr,b,centr,dhlgth,epmach,f,fc,fsum,fval1,fval2, &
    fv1,fv2,hlgth,resabs,resasc,resg,resk,reskh,result, &
    uflow,wg,wgk,xgk
  integer isig,j,jtw,jtwm1
  external f
!
  dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11)
!
!           the abscissae and weights are given for the interval (-1,1).
!           because of symmetry only the positive abscissae and their
!           corresponding weights are given.
!
!           xgk    - abscissae of the 21-point kronrod rule
!                    xgk(2), xgk(4), ...  abscissae of the 10-point
!                    gauss rule
!                    xgk(1), xgk(3), ...  abscissae which are optimally
!                    added to the 10-point gauss rule
!
!           wgk    - weights of the 21-point kronrod rule
!
!           wg     - weights of the 10-point gauss rule
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), &
    xgk(8),xgk(9),xgk(10),xgk(11)/ &
           0.9956571630258081e+00,     0.9739065285171717e+00, &
       0.9301574913557082e+00,     0.8650633666889845e+00, &
       0.7808177265864169e+00,     0.6794095682990244e+00, &
       0.5627571346686047e+00,     0.4333953941292472e+00, &
       0.2943928627014602e+00,     0.1488743389816312e+00, &
       0.0000000000000000e+00/
!
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), &
    wgk(8),wgk(9),wgk(10),wgk(11)/ &
       0.1169463886737187e-01,     0.3255816230796473e-01, &
       0.5475589657435200e-01,     0.7503967481091995e-01, &
       0.9312545458369761e-01,     0.1093871588022976e+00, &
       0.1234919762620659e+00,     0.1347092173114733e+00, &
       0.1427759385770601e+00,     0.1477391049013385e+00, &
       0.1494455540029169e+00/
!
  data wg(1),wg(2),wg(3),wg(4),wg(5)/ &
       0.6667134430868814e-01,     0.1494513491505806e+00, &
       0.2190863625159820e+00,     0.2692667193099964e+00, &
       0.2955242247147529e+00/
!
!
!           list of major variables
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc   - abscissa
!           fval*  - function value
!           resg   - result of the 10-point gauss formula
!           resk   - result of the 21-point kronrod formula
!           reskh  - approximation to the mean value of f over (a,b),
!                    i.e. to i/(b-a)
!
!
!           machine dependent constants
!
!           epmach is the largest relative spacing.
!           uflow is the smallest positive magnitude.
!
  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
!
  centr = 0.5e+00*(a+b)
  hlgth = 0.5e+00*(b-a)
  dhlgth = abs(hlgth)
!
!             check if the interval (a,b) is too short
!
  isig = 5
  absc = abs(centr) + dhlgth*0.14e+00
  if (absc == abs(centr)) return
!
!           compute the 21-point kronrod approximation to
!           the integral, and estimate the absolute error.
!
  isig = 0
  resg = 0.0e+00
  fc = f(centr)
  resk = wgk(11)*fc
  resabs = abs(resk)
  do 10 j=1,5
    jtw = 2*j
    absc = hlgth*xgk(jtw)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtw) = fval1
    fv2(jtw) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(jtw)*fsum
    resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2))
   10 continue
  do 15 j = 1,5
    jtwm1 = 2*j-1
    absc = hlgth*xgk(jtwm1)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtwm1) = fval1
    fv2(jtwm1) = fval2
    fsum = fval1+fval2
    resk = resk+wgk(jtwm1)*fsum
    resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2))
   15 continue
  reskh = resk*0.5e+00
  resasc = wgk(11)*abs(fc-reskh)
  do 20 j=1,10
    resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
  result = resk*hlgth
  resabs = resabs*dhlgth
  resasc = resasc*dhlgth
  abserr = abs((resk-resg)*hlgth)
  if(resasc/=0.0e+00.and.abserr/=0.0e+00) &
    abserr = resasc*amin1(0.1e+01, &
    (0.2e+03*abserr/resasc)**1.5e+00)
  if(resabs > uflow/(0.5e+02*epmach)) abserr = amax1 &
    ((epmach*0.5e+02)*resabs,abserr)
  return
end
subroutine qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
!
!*******************************************************************************
!
!! QPSRT: ordering routine
!              standard fortran subroutine
!              real version
!
! 2.        purpose
!              this routine maintains the descending ordering
!              in the list of the local error estimates resulting from
!              the interval subdivision process. at each call two error
!              estimates are inserted using the sequential search
!              method, top-down for the largest error estimate
!              and bottom-up for the smallest error estimate.
!
! 3.        calling sequence
!              call qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
!
!           parameters (meaning at output)
!              limit  - integer
!                       maximum number of error estimates the list
!                       can contain
!
!              last   - integer
!                       number of error estimates currently
!                       in the list
!
!              maxerr - integer
!                       maxerr points to the nrmax-th largest error
!                       estimate currently in the list
!
!              ermax  - real
!                       nrmax-th largest error estimate
!                       ermax = elist(maxerr)
!
!              elist  - real
!                       vector of dimension last containing
!                       the error estimates
!
!              iord   - integer
!                       vector of dimension last, the first k
!                       elements of which contain pointers
!                       to the error estimates, such that
!                       elist(iord(1)),... , elist(iord(k))
!                       form a decreasing sequence, with
!                       k = last if last <= (limit/2+2), and
!                       k = limit+1-last otherwise
!
!              nrmax  - integer
!                       maxerr = iord(nrmax)
!
! 4.        no subroutines or functions needed
!
!
!
  real elist,ermax,errmax,errmin
  integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, &
    nrmax
  dimension elist(last),iord(last)
!
!           check whether the list contains more than
!           two error estimates.
!
!***first executable statement  qpsrt
  if(last > 2) go to 10
  iord(1) = 1
  iord(2) = 2
  go to 90
!
!           this part of the routine is only executed
!           if, due to a difficult integrand, subdivision
!           increased the error estimate. in the normal case
!           the insert procedure should start after the
!           nrmax-th largest error estimate.
!
   10 errmax = elist(maxerr)
  if(nrmax==1) go to 30
  ido = nrmax-1
  do 20 i = 1,ido
    isucc = iord(nrmax-1)
! ***jump out of do-loop
    if(errmax <= elist(isucc)) go to 30
    iord(nrmax) = isucc
    nrmax = nrmax-1
   20    continue
!
!           compute the number of elements in the list to
!           be maintained in descending order. this number
!           depends on the number of subdivisions still
!           allowed.
!
   30 jupbn = last
  if(last > (limit/2+2)) jupbn = limit+3-last
  errmin = elist(last)
!
!           insert errmax by traversing the list top-down,
!           starting comparison from the element elist(iord(nrmax+1)).
!
  jbnd = jupbn-1
  ibeg = nrmax+1
  if(ibeg > jbnd) go to 50
  do 40 i=ibeg,jbnd
    isucc = iord(i)
! ***jump out of do-loop
    if(errmax >= elist(isucc)) go to 60
    iord(i-1) = isucc
   40 continue
   50 iord(jbnd) = maxerr
  iord(jupbn) = last
  go to 90
!
!           insert errmin by traversing the list bottom-up.
!
   60 iord(i-1) = maxerr
  k = jbnd
  do 70 j=i,jbnd
    isucc = iord(k)
! ***jump out of do-loop
    if(errmin < elist(isucc)) go to 80
    iord(k+1) = isucc
    k = k-1
   70 continue
  iord(i) = last
  go to 90
   80 iord(k+1) = last
!
!           set maxerr and ermax.
!
   90 maxerr = iord(nrmax)
  ermax = elist(maxerr)
  return
end
subroutine qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm )
!
!*******************************************************************************
!
!! QRFAC computes a QR factorization using Householder transformations.
!
!
!  Discussion:
!
!    This subroutine uses Householder transformations with column
!    pivoting (optional) to compute a QR factorization of the
!    M by N matrix A.  That is, QRFAC determines an orthogonal
!    matrix Q, a permutation matrix P, and an upper trapezoidal
!    matrix R with diagonal elements of nonincreasing magnitude,
!    such that A*P = Q*R.  The Householder transformation for
!    column K, K = 1,2,...,min(M,N), is of the form
!
!      I - ( 1 / U(K) ) * U * U'
!
!    where U has zeros in the first K-1 positions.  The form of
!    this transformation and the method of pivoting first
!    appeared in the corresponding LINPACK subroutine.
!
!  Reference:
!
!    More, Garbow and Hillstrom,
!    User Guide for MINPACK-1
!    Argonne National Laboratory,
!    Argonne, Illinois.
!
!  Parameters:
!
!    Input, integer M, the number of rows of A.
!
!    Input, integer N, the number of columns of A.
!
!    Input/output, real A(LDA,N), the M by N array.
!    On input, A contains the matrix for which the QR factorization is to
!    be computed.  On output, the strict upper trapezoidal part of A contains
!    the strict upper trapezoidal part of R, and the lower trapezoidal
!    part of A contains a factored form of Q (the non-trivial elements of
!    the U vectors described above).
!
!    Input, integer LDA, the leading dimension of A, which must
!    be no less than M.
!
!    Input, logical PIVOT, is TRUE if column pivoting is to be carried out.
!
!    Output, integer IPVT(LIPVT), defines the permutation matrix P such
!    that A*P = Q*R.  Column J of P is column IPVT(J) of the identity matrix.
!    If PIVOT is false, IPVT is not referenced.
!
!    Input, integer LIPVT, the dimension of IPVT, which should be N if
!    pivoting is used.
!
!    Output, real RDIAG(N), contains the diagonal elements of R.
!
!    Output, real ACNORM(N), the norms of the corresponding columns of the
!    input matrix A.  If this information is not needed, then ACNORM can
!    coincide with RDIAG.
!
  integer lda
  integer lipvt
  integer n
!
  real a(lda,n)
  real acnorm(n)
  real ajnorm
  real enorm
  real epsmch
  integer i
  integer ipvt(lipvt)
  integer j
  integer k
  integer kmax
  integer m
  integer minmn
  logical pivot
  real rdiag(n)
  real temp
  real wa(n)
!
  epsmch = epsilon ( epsmch )
!
!  Compute the initial column norms and initialize several arrays.
!
  do j = 1, n
    acnorm(j) = enorm ( m, a(1,j) )
  end do

  rdiag(1:n) = acnorm(1:n)
  wa(1:n) = acnorm(1:n)

  if ( pivot ) then
    do j = 1, n
      ipvt(j) = j
    end do
  end if
!
!  Reduce A to R with Householder transformations.
!
  minmn = min ( m, n )

  do j = 1, minmn
!
!  Bring the column of largest norm into the pivot position.
!
    if ( pivot ) then

      kmax = j

      do k = j, n
        if ( rdiag(k) > rdiag(kmax) ) kmax = k
      end do

      if ( kmax /= j ) then

        do i = 1, m
          call r_swap ( a(i,j), a(i,kmax) )
        end do

        rdiag(kmax) = rdiag(j)
        wa(kmax) = wa(j)

        call i4_swap ( ipvt(j), ipvt(kmax) )

      end if

    end if
!
!  Compute the Householder transformation to reduce the
!  J-th column of A to a multiple of the J-th unit vector.
!
    ajnorm = enorm ( m-j+1, a(j,j) )

    if ( ajnorm /= 0.0E+00 ) then

      if ( a(j,j) < 0.0E+00 ) then
        ajnorm = -ajnorm
      end if

      a(j:m,j) = a(j:m,j) / ajnorm
      a(j,j) = a(j,j) + 1.0E+00
!
!  Apply the transformation to the remaining columns and update the norms.
!
      do k = j+1, n

        temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j)

        a(j:m,k) = a(j:m,k) - temp * a(j:m,j)

        if ( pivot .and. rdiag(k) /= 0.0E+00 ) then

          temp = a(j,k) / rdiag(k)
          rdiag(k) = rdiag(k) * sqrt ( max ( 0.0E+00, 1.0E+00-temp**2 ) )

          if ( 0.05E+00 * ( rdiag(k) / wa(k) )**2 <= epsmch ) then
            rdiag(k) = enorm ( m-j, a(j+1,k) )
            wa(k) = rdiag(k)
          end if

        end if

      end do

    end if

    rdiag(j) = -ajnorm

  end do

  return
end
subroutine qrsolv ( n, r, ldr, ipvt, diag, qtb, x, sdiag )
!
!*******************************************************************************
!
!! QRSOLV solves a rectangular linear system A*x=b in the least squares sense.
!
!
!  Discussion:
!
!    Given an M by N matrix A, an N by N diagonal matrix D,
!    and an M-vector B, the problem is to determine an X which
!    solves the system
!
!      A*X = B
!      D*X = 0
!
!    in the least squares sense.
!
!    This subroutine completes the solution of the problem
!    if it is provided with the necessary information from the
!    QR factorization, with column pivoting, of A.  That is, if
!    Q*P = Q*R, where P is a permutation matrix, Q has orthogonal
!    columns, and R is an upper triangular matrix with diagonal
!    elements of nonincreasing magnitude, then QRSOLV expects
!    the full upper triangle of R, the permutation matrix p,
!    and the first N components of Q'*B.
!
!    The system is then equivalent to
!
!      R*Z = Q'*B
!      P'*D*P*Z = 0
!
!    where X = P*Z.  If this system does not have full rank,
!    then a least squares solution is obtained.  On output QRSOLV
!    also provides an upper triangular matrix S such that
!
!      P'*(A'*A + D*D)*P = S'*S.
!
!    S is computed within QRSOLV and may be of separate interest.
!
!  Reference:
!
!    More, Garbow and Hillstrom,
!    User Guide for MINPACK-1
!    Argonne National Laboratory,
!    Argonne, Illinois.
!
!  Parameters:
!
!    Input, integer N, the order of R.
!
!    Input/output, real R(LDR,N), the N by N matrix.
!    On input the full upper triangle must contain the full upper triangle
!    of the matrix R.  On output the full upper triangle is unaltered, and
!    the strict lower triangle contains the strict upper triangle
!    (transposed) of the upper triangular matrix S.
!
!    Input, integer LDR, the leading dimension of R, which must be
!    at least N.
!
!    Input, integer IPVT(N), defines the permutation matrix P such that
!    A*P = Q*R.  Column J of P is column IPVT(J) of the identity matrix.
!
!    Input, real DIAG(N), the diagonal elements of the matrix D.
!
!    Input, real QTB(N), the first N elements of the vector Q'*B.
!
!    Output, real X(N), the least squares solution.
!
!    Output, real SDIAG(N), the diagonal elements of the upper triangular
!    matrix S.
!
  integer ldr
  integer n
!
  real c
  real cotan
  real diag(n)
  integer i
  integer ipvt(n)
  integer j
  integer k
  integer l
  integer nsing
  real qtb(n)
  real qtbpj
  real r(ldr,n)
  real s
  real sdiag(n)
  real sum2
  real t
  real temp
  real wa(n)
  real x(n)
!
!  Copy R and Q'*B to preserve input and initialize S.
!
!  In particular, save the diagonal elements of R in X.
!
  do j = 1, n
    r(j:n,j) = r(j,j:n)
    x(j) = r(j,j)
  end do

  wa(1:n) = qtb(1:n)
!
!  Eliminate the diagonal matrix D using a Givens rotation.
!
  do j = 1, n
!
!  Prepare the row of D to be eliminated, locating the
!  diagonal element using P from the QR factorization.
!
    l = ipvt(j)

    if ( diag(l) /= 0.0E+00 ) then

      sdiag(j:n) = 0.0E+00
      sdiag(j) = diag(l)
!
!  The transformations to eliminate the row of D
!  modify only a single element of Q'*B
!  beyond the first N, which is initially zero.
!
      qtbpj = 0.0E+00

      do k = j, n
!
!  Determine a Givens rotation which eliminates the
!  appropriate element in the current row of D.
!
        if ( sdiag(k) /= 0.0E+00 ) then

          if ( abs ( r(k,k) ) < abs ( sdiag(k) ) ) then
            cotan = r(k,k) / sdiag(k)
            s = 0.5E+00 / sqrt ( 0.25E+00 + 0.25E+00 * cotan**2 )
            c = s * cotan
          else
            t = sdiag(k) / r(k,k)
            c = 0.5E+00 / sqrt ( 0.25E+00 + 0.25E+00 * t**2 )
            s = c * t
          end if
!
!  Compute the modified diagonal element of R and
!  the modified element of (Q'*B,0).
!
          r(k,k) = c * r(k,k) + s * sdiag(k)
          temp = c * wa(k) + s * qtbpj
          qtbpj = - s * wa(k) + c * qtbpj
          wa(k) = temp
!
!  Accumulate the tranformation in the row of S.
!
          do i = k+1, n
            temp = c * r(i,k) + s * sdiag(i)
            sdiag(i) = - s * r(i,k) + c * sdiag(i)
            r(i,k) = temp
          end do

        end if

      end do

    end if
!
!  Store the diagonal element of S and restore
!  the corresponding diagonal element of R.
!
    sdiag(j) = r(j,j)
    r(j,j) = x(j)

  end do
!
!  Solve the triangular system for Z.  If the system is
!  singular, then obtain a least squares solution.
!
  nsing = n

  do j = 1, n
    if ( sdiag(j) == 0.0E+00 .and. nsing == n ) nsing = j - 1
    if ( nsing < n ) then
      wa(j) = 0.0E+00
    end if
  end do

  do k = 1, nsing
    j = nsing - k + 1
    sum2 = 0.0E+00
    do i = j+1, nsing
      sum2 = sum2 + r(i,j) * wa(i)
    end do
    wa(j) = ( wa(j) - sum2 ) / sdiag(j)
  end do
!
!  Permute the components of Z back to components of X.
!
  do j = 1, n
    l = ipvt(j)
    x(l) = wa(j)
  end do

  return
end
subroutine qrupdt (nr,n,a,u,v)
!
!*******************************************************************************
!
!! QRUPDT finds an orthogonal matrix (q*) and an upper triangular
!          matrix (r*) such that (q*)(r*) = r + u(v+)
!
!
!     parameters ...
!
!       nr      row dimension of the matrix
!       n       order of the matrix
!       a(n,n)  on input,  contains r
!               on output, contains (r*)
!       u(n)    vector
!       v(n)    vector
!
!
  real a(nr,n), u(n), v(n)
!
!                determine last non-zero in u
!
  k = n
   10 if (u(k) /= 0.0 .or. k == 1) go to 20
     k = k - 1
     go to 10
!
!               k-1 jacobi rotations transform
!             r + u(v+)  to  (r*) + (u(1)*e1)(v+)
!                 which is upper hessenberg
!
   20 km1 = k - 1
  if (k <= 1) go to 40
  do 30 ii = 1,km1
     i = k - ii
     call jrot (nr,n,a,i,u(i),-u(i+1),r)
     u(i) = r
   30 continue
!
! set r = r + (u(1)*e1)(v+)
!
   40 do 50 j = 1,n
     a(1,j) = a(1,j) + u(1)*v(j)
   50 continue
  if (k <= 1) return
!
!       k-1 jacobi rotations transform upper hessenberg r
!                   to upper triangular r*
!
  do 60 i = 1,km1
     call jrot (nr,n,a,i,a(i,i),-a(i+1,i),r)
   60 continue
  return
end
function qsuba (f, a, b, epsil, mcount, relerr, ind)
!
!*******************************************************************************
!
!! QSUBA computes the integral of f(x) from a to b where the
!     relative error does not exceed epsil.
!
!     mcount is the maximum number of points at which f(x) may be
!     evaluated.
!
!     relerr is a variable. when qsuba terminates, if the value
!     of the integral is nonzero then relerr is a crude estimate
!     of the relative error of the value. otherwise, if qsuba = 0
!     then relerr is an estimate of the absolute error.
!
!     ind is a variable. when qsuba terminates, ind has one of the
!     following values ...
!
!     ind=0   qsuba is satisfied that the integral has been
!             computed to the desired accuracy.
!     ind=1   the integral has been computed, but qsuba is
!             not certain of the accuracy of the result.
!     ind=2   the integrand has been evaluated at mcount
!             points. if more evaluations are needed then
!             qsuba terminates.
!     ind=3   qsuba cannot compute the integral to the desired
!             accuracy. ind is set to 3 whenever the stack of
!             intervals becomes full (it currently can hold 50
!             intervals). a result is obtained by continuing
!             the integration ignoring convergence failures
!             which cannot be accommodated on the stack.
!
!     the reliability of the algorithm decreases for large values
!     of epsil. it is recommended that epsil be less than 0.001.
!
  real qsuba
  dimension result(8), stack(100)
  external f
  data ismax/100/
!

  eps = epsilon ( eps )
  qsuba = 0.0
  relerr = 0.0
  ind = 0
  if (a == b) return
!
!     apply quad to the entire interval
!
  sub1 = amin1(a,b)
  sub3 = max ( a,b)
  tol = max ( epsil, 10.0*eps)
  call quad (sub1, sub3, result, k, tol, npts, icheck, f)
  if (icheck == 0) go to 100
  is = 1
!
!     subdivide the interval (sub1,sub3) into the subintervals
!     (sub1,sub2) and (sub2,sub3). call quad for (sub1,sub2).
!
   10 if (npts >= mcount) go to 110
  sub2 = 0.5*(sub1 + sub3)
  call quad (sub1, sub2, result, k, tol, nf, icheck, f)
  npts = npts + nf
  err = abs(result(k) - result(k-1))
  sum = qsuba + result(k)
  if (icheck == 0 .or. err <= abs(tol*sum)) go to 30
!
!        stack the subinterval (sub1,sub2) for further
!        examination if there is sufficient storage.
!
     if (is >= ismax) go to 20
        stack(is) = sub1
        is = is + 1
        stack(is) = sub2
        is = is + 1
        go to 40
   20    ind = 3
!
!     update qsuba and check if any significant digits are lost
!
   30 x = qsuba
  qsuba = sum
  relerr = relerr + err
  if (ind /= 0 .or. x*result(k) >= 0.0) go to 40
  x = 0.1*amin1(abs(x),abs(result(k)))
  if (abs(qsuba) <= x) ind = 1
!
!     call quad for the interval (sub2,sub3)
!
   40 if (npts >= mcount) go to 110
  call quad (sub2, sub3, result, k, tol, nf, icheck, f)
  npts = npts + nf
  err = abs(result(k) - result(k-1))
  sum = qsuba + result(k)
  if (icheck == 0 .or. err <= abs(tol*sum)) go to 50
!
!        subdivide the interval (sub2,sub3)
!
     sub1 = sub2
     go to 10
!
!     update qsuba and check if any significant digits are lost
!
   50 x = qsuba
  qsuba = sum
  relerr = relerr + err
  if (ind /= 0 .or. x*result(k) >= 0.0) go to 60
  x = 0.1*amin1(abs(x),abs(result(k)))
  if (abs(qsuba) <= x) ind = 1
!
!     subdivide the interval last stacked
!
   60 if (is == 1) go to 120
  is = is - 1
  sub3 = stack(is)
  is = is - 1
  sub1 = stack(is)
  go to 10
!
!     termination when subdivision is not needed
!
  100 qsuba = result(k)
  if (a > b) qsuba = -qsuba
  relerr = abs(result(k) - result(k-1))
  if (qsuba /= 0.0) relerr = relerr/abs(qsuba)
  return
!
!     subdivision result
!
  110 ind = 2
  120 if (a > b) qsuba = -qsuba
  if (qsuba /= 0.0) relerr = relerr/abs(qsuba)
  return
end
subroutine qtcrt (a, z)
!
!*******************************************************************************
!
!! QTCRT computes the roots of the real polynomial
!               a(1) + a(2)*z + ... + a(5)*z**4
!         and stores the results in z. it is assumed that a(5)
!         is nonzero.
!
!
!     written by alfred h. morris
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!
  real a(5), temp(4)
  complex z(4), w
!
  if (a(1) == 0.0) go to 100
  b = a(4)/(4.0*a(5))
  c = a(3)/a(5)
  d = a(2)/a(5)
  e = a(1)/a(5)
  b2 = b*b
!
  p = 0.5*(c - 6.0*b2)
  q = d - 2.0*b*(c - 4.0*b2)
  r = b2*(c - 3.0*b2) - b*d + e
!
!          solve the resolvent cubic equation. the cubic has
!          at least one nonnegative real root. if w1, w2, w3
!          are the roots of the cubic then the roots of the
!          originial equation are
!
!             z = -b + csqrt(w1) + csqrt(w2) + csqrt(w3)
!
!          where the signs of the square roots are chosen so
!          that csqrt(w1) * csqrt(w2) * csqrt(w3) = -q/8.
!
  temp(1) = -q*q/64.0
  temp(2) = 0.25*(p*p - r)
  temp(3) =  p
  temp(4) = 1.0
  call cbcrt(temp,z)
  if (aimag(z(2)) /= 0.0) go to 60
!
!               the resolvent cubic has only real roots
!                reorder the roots in increasing order
!
  x1 = real(z(1))
  x2 = real(z(2))
  x3 = real(z(3))
  if (x1 <= x2) go to 10
     t = x1
     x1 = x2
     x2 = t
   10 if (x2 <= x3) go to 20
     t = x2
     x2 = x3
     x3 = t
  if (x1 <= x2) go to 20
     t = x1
     x1 = x2
     x2 = t
!
   20 u = 0.0
  if (x3 > 0.0) u = sqrt(x3)
  if (x2 <= 0.0) go to 41
  if (x1 >= 0.0) go to 30
  if (abs(x1) > x2) go to 40
  x1 = 0.0
!
   30 x1 = sqrt(x1)
  x2 = sqrt(x2)
  if (q > 0.0) x1 = -x1
  temp(1) = (( x1 + x2) + u) - b
  temp(2) = ((-x1 - x2) + u) - b
  temp(3) = (( x1 - x2) - u) - b
  temp(4) = ((-x1 + x2) - u) - b
  call aord (temp,4)
  if (abs(temp(1)) >= 0.1*abs(temp(4))) go to 31
     t = temp(2)*temp(3)*temp(4)
     if (t /= 0.0) temp(1) = e/t
   31 z(1) = cmplx(temp(1), 0.0)
  z(2) = cmplx(temp(2), 0.0)
  z(3) = cmplx(temp(3), 0.0)
  z(4) = cmplx(temp(4), 0.0)
  return
!
   40 v1 = sqrt(abs(x1))
  v2 = 0.0
  go to 50
   41 v1 = sqrt(abs(x1))
  v2 = sqrt(abs(x2))
  if (q < 0.0) u = -u
!
   50 x = -u - b
  y = v1 - v2
  z(1) = cmplx(x, y)
  z(2) = cmplx(x,-y)
  x =  u - b
  y = v1 + v2
  z(3) = cmplx(x, y)
  z(4) = cmplx(x,-y)
  return
!
!                the resolvent cubic has complex roots
!
   60 t = real(z(1))
  x = 0.0
  if (t) 61,70,62
   61 h = abs(real(z(2))) + abs(aimag(z(2)))
  if (abs(t) <= h) go to 70
  go to 80
   62 x = sqrt(t)
  if (q > 0.0) x = -x
!
   70 w = csqrt(z(2))
  u = 2.0*real(w)
  v = 2.0*abs(aimag(w))
  t =  x - b
  x1 = t + u
  x2 = t - u
  if (abs(x1) <= abs(x2)) go to 71
     t = x1
     x1 = x2
     x2 = t
   71 u = -x - b
  h = u*u + v*v
  if (x1*x1 < 0.01*amin1(x2*x2,h)) x1 = e/(x2*h)
  z(1) = cmplx(x1, 0.0)
  z(2) = cmplx(x2, 0.0)
  z(3) = cmplx(u, v)
  z(4) = cmplx(u,-v)
  return
!
   80 v = sqrt(abs(t))
  z(1) = cmplx(-b, v)
  z(2) = cmplx(-b,-v)
  z(3) = z(1)
  z(4) = z(2)
  return
!
!                         case when a(1) = 0
!
  100 z(1) = (0.0, 0.0)
  call cbcrt(a(2), z(2))
  return
end
subroutine quad ( a, b, result, k, epsil, npts, icheck, f )

!*******************************************************************************
!
!! QUAD attempts to calculate the integral of f(x)
! over the interval *a* to *b* with relative error not
! exceeding *epsil*.
! the result is obtained using a sequence of 1,3,7,15,31,63,
! 127, and 255 point interlacing formulae(no integrand
! evaluations are wasted) of respective degree 1,5,11,23,
! 47,95,191 and 383. the formulae are based on the optimal
! extension of the 3-point gauss formula.  details of
! the formulae are given in *the optimum addition of points
! to quadrature formulae* by t.n.l. patterson,maths.comp.
! vol 22,847-856,1968.
!                     *** input ***
! a       lower limit of integration.
! b       upper limit of integration.
! epsil   relative accuracy required. when the relative
!         difference of two successive formulae does not
!         exceed *epsil* the last formula computed is taken
!         as the result.
! f       f(x) is the integrand.
!                     *** output ***
! result  this array,which should be declared to have at
!         least 8 elements, holds the results obtained by
!         the 1,3,7, etc., point formulae. the number of
!         formulae computed depents on *epsil*.
! k       result(k) holds the value of the integral to the
!         specified relative accuracy.
! npts    number integrand evaluations.
! icheck  on exit normally icheck=0. however if convergence
!         to the accuracy requested is not achieved icheck=1
!         on exit.
! abscissae and weights of quadrature rules are stacked in
! array *p* in the order in which they are needed.
!
  dimension funct(127), p(381), result(*)
  external f
  data &
   p( 1),p( 2),p( 3),p( 4),p( 5),p( 6),p( 7), &
   p( 8),p( 9),p(10),p(11),p(12),p(13),p(14), &
   p(15),p(16),p(17),p(18),p(19),p(20),p(21), &
   p(22),p(23),p(24),p(25),p(26),p(27),p(28)/ &
    0.77459666924148337704e+00,0.55555555555555555556e+00, &
    0.88888888888888888889e+00,0.26848808986833344073e+00, &
    0.96049126870802028342e+00,0.10465622602646726519e+00, &
    0.43424374934680255800e+00,0.40139741477596222291e+00, &
    0.45091653865847414235e+00,0.13441525524378422036e+00, &
    0.51603282997079739697e-01,0.20062852937698902103e+00, &
    0.99383196321275502221e+00,0.17001719629940260339e-01, &
    0.88845923287225699889e+00,0.92927195315124537686e-01, &
    0.62110294673722640294e+00,0.17151190913639138079e+00, &
    0.22338668642896688163e+00,0.21915685840158749640e+00, &
    0.22551049979820668739e+00,0.67207754295990703540e-01, &
    0.25807598096176653565e-01,0.10031427861179557877e+00, &
    0.84345657393211062463e-02,0.46462893261757986541e-01, &
    0.85755920049990351154e-01,0.10957842105592463824e+00/
  data &
   p(29),p(30),p(31),p(32),p(33),p(34),p(35), &
   p(36),p(37),p(38),p(39),p(40),p(41),p(42), &
   p(43),p(44),p(45),p(46),p(47),p(48),p(49), &
   p(50),p(51),p(52),p(53),p(54),p(55),p(56)/ &
    0.99909812496766759766e+00,0.25447807915618744154e-02, &
    0.98153114955374010687e+00,0.16446049854387810934e-01, &
    0.92965485742974005667e+00,0.35957103307129322097e-01, &
    0.83672593816886873550e+00,0.56979509494123357412e-01, &
    0.70249620649152707861e+00,0.76879620499003531043e-01, &
    0.53131974364437562397e+00,0.93627109981264473617e-01, &
    0.33113539325797683309e+00,0.10566989358023480974e+00, &
    0.11248894313318662575e+00,0.11195687302095345688e+00, &
    0.11275525672076869161e+00,0.33603877148207730542e-01, &
    0.12903800100351265626e-01,0.50157139305899537414e-01, &
    0.42176304415588548391e-02,0.23231446639910269443e-01, &
    0.42877960025007734493e-01,0.54789210527962865032e-01, &
    0.12651565562300680114e-02,0.82230079572359296693e-02, &
    0.17978551568128270333e-01,0.28489754745833548613e-01/
  data &
   p(57),p(58),p(59),p(60),p(61),p(62),p(63), &
   p(64),p(65),p(66),p(67),p(68),p(69),p(70), &
   p(71),p(72),p(73),p(74),p(75),p(76),p(77), &
   p(78),p(79),p(80),p(81),p(82),p(83),p(84)/ &
    0.38439810249455532039e-01,0.46813554990628012403e-01, &
    0.52834946790116519862e-01,0.55978436510476319408e-01, &
    0.99987288812035761194e+00,0.36322148184553065969e-03, &
    0.99720625937222195908e+00,0.25790497946856882724e-02, &
    0.98868475754742947994e+00,0.61155068221172463397e-02, &
    0.97218287474858179658e+00,0.10498246909621321898e-01, &
    0.94634285837340290515e+00,0.15406750466559497802e-01, &
    0.91037115695700429250e+00,0.20594233915912711149e-01, &
    0.86390793819369047715e+00,0.25869679327214746911e-01, &
    0.80694053195021761186e+00,0.31073551111687964880e-01, &
    0.73975604435269475868e+00,0.36064432780782572640e-01, &
    0.66290966002478059546e+00,0.40715510116944318934e-01, &
    0.57719571005204581484e+00,0.44914531653632197414e-01, &
    0.48361802694584102756e+00,0.48564330406673198716e-01/
  data &
   p( 85),p( 86),p( 87),p( 88),p( 89),p( 90),p( 91), &
   p( 92),p( 93),p( 94),p( 95),p( 96),p( 97),p( 98), &
   p( 99),p(100),p(101),p(102),p(103),p(104),p(105), &
   p(106),p(107),p(108),p(109),p(110),p(111),p(112)/ &
    0.38335932419873034692e+00,0.51583253952048458777e-01, &
    0.27774982202182431507e+00,0.53905499335266063927e-01, &
    0.16823525155220746498e+00,0.55481404356559363988e-01, &
    0.56344313046592789972e-01,0.56277699831254301273e-01, &
    0.56377628360384717388e-01,0.16801938574103865271e-01, &
    0.64519000501757369228e-02,0.25078569652949768707e-01, &
    0.21088152457266328793e-02,0.11615723319955134727e-01, &
    0.21438980012503867246e-01,0.27394605263981432516e-01, &
    0.63260731936263354422e-03,0.41115039786546930472e-02, &
    0.89892757840641357233e-02,0.14244877372916774306e-01, &
    0.19219905124727766019e-01,0.23406777495314006201e-01, &
    0.26417473395058259931e-01,0.27989218255238159704e-01, &
    0.18073956444538835782e-03,0.12895240826104173921e-02, &
    0.30577534101755311361e-02,0.52491234548088591251e-02/
  data &
   p(113),p(114),p(115),p(116),p(117),p(118),p(119), &
   p(120),p(121),p(122),p(123),p(124),p(125),p(126), &
   p(127),p(128),p(129),p(130),p(131),p(132),p(133), &
   p(134),p(135),p(136),p(137),p(138),p(139),p(140)/ &
    0.77033752332797418482e-02,0.10297116957956355524e-01, &
    0.12934839663607373455e-01,0.15536775555843982440e-01, &
    0.18032216390391286320e-01,0.20357755058472159467e-01, &
    0.22457265826816098707e-01,0.24282165203336599358e-01, &
    0.25791626976024229388e-01,0.26952749667633031963e-01, &
    0.27740702178279681994e-01,0.28138849915627150636e-01, &
    0.99998243035489159858e+00,0.50536095207862517625e-04, &
    0.99959879967191068325e+00,0.37774664632698466027e-03, &
    0.99831663531840739253e+00,0.93836984854238150079e-03, &
    0.99572410469840718851e+00,0.16811428654214699063e-02, &
    0.99149572117810613240e+00,0.25687649437940203731e-02, &
    0.98537149959852037111e+00,0.35728927835172996494e-02, &
    0.97714151463970571416e+00,0.46710503721143217474e-02, &
    0.96663785155841656709e+00,0.58434498758356395076e-02/
  data &
   p(141),p(142),p(143),p(144),p(145),p(146),p(147), &
   p(148),p(149),p(150),p(151),p(152),p(153),p(154), &
   p(155),p(156),p(157),p(158),p(159),p(160),p(161), &
   p(162),p(163),p(164),p(165),p(166),p(167),p(168)/ &
    0.95373000642576113641e+00,0.70724899954335554680e-02, &
    0.93832039777959288365e+00,0.83428387539681577056e-02, &
    0.92034002547001242073e+00,0.96411777297025366953e-02, &
    0.89974489977694003664e+00,0.10955733387837901648e-01, &
    0.87651341448470526974e+00,0.12275830560082770087e-01, &
    0.85064449476835027976e+00,0.13591571009765546790e-01, &
    0.82215625436498040737e+00,0.14893641664815182035e-01, &
    0.79108493379984836143e+00,0.16173218729577719942e-01, &
    0.75748396638051363793e+00,0.17421930159464173747e-01, &
    0.72142308537009891548e+00,0.18631848256138790186e-01, &
    0.68298743109107922809e+00,0.19795495048097499488e-01, &
    0.64227664250975951377e+00,0.20905851445812023852e-01, &
    0.59940393024224289297e+00,0.21956366305317824939e-01, &
    0.55449513263193254887e+00,0.22940964229387748761e-01/
  data &
   p(169),p(170),p(171),p(172),p(173),p(174),p(175), &
   p(176),p(177),p(178),p(179),p(180),p(181),p(182), &
   p(183),p(184),p(185),p(186),p(187),p(188),p(189), &
   p(190),p(191),p(192),p(193),p(194),p(195),p(196)/ &
    0.50768775753371660215e+00,0.23854052106038540080e-01, &
    0.45913001198983233287e+00,0.24690524744487676909e-01, &
    0.40897982122988867241e+00,0.25445769965464765813e-01, &
    0.35740383783153215238e+00,0.26115673376706097680e-01, &
    0.30457644155671404334e+00,0.26696622927450359906e-01, &
    0.25067873030348317661e+00,0.27185513229624791819e-01, &
    0.19589750271110015392e+00,0.27579749566481873035e-01, &
    0.14042423315256017459e+00,0.27877251476613701609e-01, &
    0.84454040083710883710e-01,0.28076455793817246607e-01, &
    0.28184648949745694339e-01,0.28176319033016602131e-01, &
    0.28188814180192358694e-01,0.84009692870519326354e-02, &
    0.32259500250878684614e-02,0.12539284826474884353e-01, &
    0.10544076228633167722e-02,0.58078616599775673635e-02, &
    0.10719490006251933623e-01,0.13697302631990716258e-01/
  data &
   p(197),p(198),p(199),p(200),p(201),p(202),p(203), &
   p(204),p(205),p(206),p(207),p(208),p(209),p(210), &
   p(211),p(212),p(213),p(214),p(215),p(216),p(217), &
   p(218),p(219),p(220),p(221),p(222),p(223),p(224)/ &
    0.31630366082226447689e-03,0.20557519893273465236e-02, &
    0.44946378920320678616e-02,0.71224386864583871532e-02, &
    0.96099525623638830097e-02,0.11703388747657003101e-01, &
    0.13208736697529129966e-01,0.13994609127619079852e-01, &
    0.90372734658751149261e-04,0.64476204130572477933e-03, &
    0.15288767050877655684e-02,0.26245617274044295626e-02, &
    0.38516876166398709241e-02,0.51485584789781777618e-02, &
    0.64674198318036867274e-02,0.77683877779219912200e-02, &
    0.90161081951956431600e-02,0.10178877529236079733e-01, &
    0.11228632913408049354e-01,0.12141082601668299679e-01, &
    0.12895813488012114694e-01,0.13476374833816515982e-01, &
    0.13870351089139840997e-01,0.14069424957813575318e-01, &
    0.25157870384280661489e-04,0.18887326450650491366e-03, &
    0.46918492424785040975e-03,0.84057143271072246365e-03/
  data &
   p(225),p(226),p(227),p(228),p(229),p(230),p(231), &
   p(232),p(233),p(234),p(235),p(236),p(237),p(238), &
   p(239),p(240),p(241),p(242),p(243),p(244),p(245), &
   p(246),p(247),p(248),p(249),p(250),p(251),p(252)/ &
    0.12843824718970101768e-02,0.17864463917586498247e-02, &
    0.23355251860571608737e-02,0.29217249379178197538e-02, &
    0.35362449977167777340e-02,0.41714193769840788528e-02, &
    0.48205888648512683476e-02,0.54778666939189508240e-02, &
    0.61379152800413850435e-02,0.67957855048827733948e-02, &
    0.74468208324075910174e-02,0.80866093647888599710e-02, &
    0.87109650797320868736e-02,0.93159241280693950932e-02, &
    0.98977475240487497440e-02,0.10452925722906011926e-01, &
    0.10978183152658912470e-01,0.11470482114693874380e-01, &
    0.11927026053019270040e-01,0.12345262372243838455e-01, &
    0.12722884982732382906e-01,0.13057836688353048840e-01, &
    0.13348311463725179953e-01,0.13592756614812395910e-01, &
    0.13789874783240936517e-01,0.13938625738306850804e-01, &
    0.14038227896908623303e-01,0.14088159516508301065e-01/
  data &
   p(253),p(254),p(255),p(256),p(257),p(258),p(259), &
   p(260),p(261),p(262),p(263),p(264),p(265),p(266), &
   p(267),p(268),p(269),p(270),p(271),p(272),p(273), &
   p(274),p(275),p(276),p(277),p(278),p(279),p(280)/ &
    0.99999759637974846462e+00,0.69379364324108267170e-05, &
    0.99994399620705437576e+00,0.53275293669780613125e-04, &
    0.99976049092443204733e+00,0.13575491094922871973e-03, &
    0.99938033802502358193e+00,0.24921240048299729402e-03, &
    0.99874561446809511470e+00,0.38974528447328229322e-03, &
    0.99780535449595727456e+00,0.55429531493037471492e-03, &
    0.99651414591489027385e+00,0.74028280424450333046e-03, &
    0.99483150280062100052e+00,0.94536151685852538246e-03, &
    0.99272134428278861533e+00,0.11674841174299594077e-02, &
    0.99015137040077015918e+00,0.14049079956551446427e-02, &
    0.98709252795403406719e+00,0.16561127281544526052e-02, &
    0.98351865757863272876e+00,0.19197129710138724125e-02, &
    0.97940628167086268381e+00,0.21944069253638388388e-02, &
    0.97473445975240266776e+00,0.24789582266575679307e-02/
  data &
   p(281),p(282),p(283),p(284),p(285),p(286),p(287), &
   p(288),p(289),p(290),p(291),p(292),p(293),p(294), &
   p(295),p(296),p(297),p(298),p(299),p(300),p(301), &
   p(302),p(303),p(304),p(305),p(306),p(307),p(308)/ &
    0.96948465950245923177e+00,0.27721957645934509940e-02, &
    0.96364062156981213252e+00,0.30730184347025783234e-02, &
    0.95718821610986096274e+00,0.33803979910869203823e-02, &
    0.95011529752129487656e+00,0.36933779170256508183e-02, &
    0.94241156519108305981e+00,0.40110687240750233989e-02, &
    0.93406843615772578800e+00,0.43326409680929828545e-02, &
    0.92507893290707565236e+00,0.46573172997568547773e-02, &
    0.91543758715576504064e+00,0.49843645647655386012e-02, &
    0.90514035881326159519e+00,0.53130866051870565663e-02, &
    0.89418456833555902286e+00,0.56428181013844441585e-02, &
    0.88256884024734190684e+00,0.59729195655081658049e-02, &
    0.87029305554811390585e+00,0.63027734490857587172e-02, &
    0.85735831088623215653e+00,0.66317812429018878941e-02, &
    0.84376688267270860104e+00,0.69593614093904229394e-02/
  data &
   p(309),p(310),p(311),p(312),p(313),p(314),p(315), &
   p(316),p(317),p(318),p(319),p(320),p(321),p(322), &
   p(323),p(324),p(325),p(326),p(327),p(328),p(329), &
   p(330),p(331),p(332),p(333),p(334),p(335),p(336)/ &
    0.82952219463740140018e+00,0.72849479805538070639e-02, &
    0.81462878765513741344e+00,0.76079896657190565832e-02, &
    0.79909229096084140180e+00,0.79279493342948491103e-02, &
    0.78291939411828301639e+00,0.82443037630328680306e-02, &
    0.76611781930376009072e+00,0.85565435613076896192e-02, &
    0.74869629361693660282e+00,0.88641732094824942641e-02, &
    0.73066452124218126133e+00,0.91667111635607884067e-02, &
    0.71203315536225203459e+00,0.94636899938300652943e-02, &
    0.69281376977911470289e+00,0.97546565363174114611e-02, &
    0.67301883023041847920e+00,0.10039172044056840798e-01, &
    0.65266166541001749610e+00,0.10316812330947621682e-01, &
    0.63175643771119423041e+00,0.10587167904885197931e-01, &
    0.61031811371518640016e+00,0.10849844089337314099e-01, &
    0.58836243444766254143e+00,0.11104461134006926537e-01/
  data &
   p(337),p(338),p(339),p(340),p(341),p(342),p(343), &
   p(344),p(345),p(346),p(347),p(348),p(349),p(350), &
   p(351),p(352),p(353),p(354),p(355),p(356),p(357), &
   p(358),p(359),p(360),p(361),p(362),p(363),p(364)/ &
    0.56590588542365442262e+00,0.11350654315980596602e-01, &
    0.54296566649831149049e+00,0.11588074033043952568e-01, &
    0.51955966153745702199e+00,0.11816385890830235763e-01, &
    0.49570640791876146017e+00,0.12035270785279562630e-01, &
    0.47142506587165887693e+00,0.12244424981611985899e-01, &
    0.44673538766202847374e+00,0.12443560190714035263e-01, &
    0.42165768662616330006e+00,0.12632403643542078765e-01, &
    0.39621280605761593918e+00,0.12810698163877361967e-01, &
    0.37042208795007823014e+00,0.12978202239537399286e-01, &
    0.34430734159943802278e+00,0.13134690091960152836e-01, &
    0.31789081206847668318e+00,0.13279951743930530650e-01, &
    0.29119514851824668196e+00,0.13413793085110098513e-01, &
    0.26424337241092676194e+00,0.13536035934956213614e-01, &
    0.23705884558982972721e+00,0.13646518102571291428e-01/
  data &
   p(365),p(366),p(367),p(368),p(369),p(370),p(371), &
   p(372),p(373),p(374),p(375),p(376),p(377),p(378), &
   p(379),p(380),p(381)/ &
    0.20966523824318119477e+00,0.13745093443001896632e-01, &
    0.18208649675925219825e+00,0.13831631909506428676e-01, &
    0.15434681148137810869e+00,0.13906019601325461264e-01, &
    0.12647058437230196685e+00,0.13968158806516938516e-01, &
    0.98482396598119202090e-01,0.14017968039456608810e-01, &
    0.70406976042855179063e-01,0.14055382072649964277e-01, &
    0.42269164765363603212e-01,0.14080351962553661325e-01, &
    0.14093886410782462614e-01,0.14092845069160408355e-01, &
    0.14094407090096179347e-01/

  icheck = 0
!
!  Check for the trivial case.
!
  if ( a == b ) then
    k = 2
    result(1) = 0.0
    result(2) = 0.0
    npts = 0
    return
  end if
!
!  scale factors.
!
  sum = (b+a)/2.0
  diff = (b-a)/2.0
!
!  1-point gauss
!
  fzero = f(sum)
  result(1) = 2.0*fzero*diff
  i = 0
  iold = 0
  inew = 1
  k = 2
  acum = 0.0
  go to 30

10 continue

  if ( k == 8 ) then
    icheck = 1
    npts = inew + iold
    return
  end if

  k = k + 1
  acum = 0.0
!
!  Contribution from function values already computed.
!
  do j = 1, iold
    i = i + 1
    acum = acum + p(i) * funct(j)
  end do
!
!  Contribution from new function values.
!
30 continue

  iold = iold + inew

  do j = inew, iold
    i = i + 1
    x = p(i) * diff
    funct(j) = f(sum+x) + f(sum-x)
    i = i + 1
    acum = acum + p(i) * funct(j)
  end do

  inew = iold + 1
  i = i + 1
  result(k) = ( acum + p(i) * fzero ) * diff
!
!  Check for convergence.
!
  if ( epsil * abs ( result(k) ) .lt. abs ( result(k) - result(k-1) ) ) then
    go to 10
  end if
!
!  normal termination.
!
  npts = inew + iold

  return
end
subroutine quadit(uu, vv, nz, nn, p, qp, k, qk)
!
!*******************************************************************************
!
!! QUADIT: variable-shift k-polynomial iteration for a
!     quadratic factor converges only if the zeros are
!     equimodular or nearly so.
!
!     uu,vv - coefficients of starting quadratic
!     nz - number of zero found
!
  double precision uu, vv, p(nn), qp(nn), k(nn), qk(nn)
  double precision ui, vi
  real mp, omp, ee, relstp, t, zm
  integer nz, type, i, j
  logical tried
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
  n = nn - 1
  nz = 0
  tried = .false.
  u = uu
  v = vv
  j = 0
! main loop
   10 call quadpl(1.d0, u, v, szr, szi, lzr, lzi)
!
!     return if roots of the quadratic are real and not close
!     to multiple or nearly equal and of opposite sign
!
  if (dabs(dabs(szr) - dabs(lzr)) > 1.d-2*dabs(lzr)) &
              return
!
!     evaluate polynomial by quadratic synthetic division
!
  call quadsd(nn, u, v, p, qp, a, b)
  mp = dabs(a - szr*b) + dabs(szi*b)
!
!     compute a rigorous bound on the rounding error in
!     evaluting p
!
  zm = sqrt(abs(sngl(v)))
  ee = 2.0*abs(sngl(qp(1)))
  t = -szr*b
  do 20 i = 2,n
     ee = ee*zm + abs(sngl(qp(i)))
   20 continue
  ee = ee*zm + abs(sngl(a) + t)
  ee = (5.0*mre + 4.0*are)*ee - (5.0*mre + 2.0*are)* &
       (abs(sngl(a) + t) + abs(sngl(b))*zm) + &
       2.0*are*abs(t)
!
!     iteration has converged sufficiently if the
!     polynomial value is less than 20 times this bound
!
  if (mp > 20.0*ee) go to 30
  nz = 2
  return
   30 j = j + 1
!
!     stop iteration after 20 steps
!
  if (j > 20) return
  if (j < 2) go to 50
  if (relstp > 0.01 .or. mp < omp .or. tried) go to 50
!
!     a cluster appears to be stalling the convergence.
!     five fixed shift steps are taken with a u,v close
!     to the cluster
!
  if (relstp < eta) relstp = eta
  relstp = sqrt(relstp)
  u = u - u*relstp
  v = v + v*relstp
  call quadsd(nn, u, v, p, qp, a, b)
  do 40 i = 1,5
     call calcsc(type, n, k, qk)
     call nextk(type, n, qp, k, qk)
   40 continue
  tried = .true.
  j = 0
   50 omp = mp
!
!     calculate next k polynomial and new u and v
!
  call calcsc(type, n, k, qk)
  call nextk(type, n, qp, k, qk)
  call calcsc(type, n, k, qk)
  call newest(type, ui, vi, nn, p, k)
!
!     if vi is zero the iteration is not converging
!
  if (vi == 0.d0) return
  relstp = dabs((vi - v)/vi)
  u = ui
  v = vi
  go to 10
end
subroutine quadpl(a, b1, c, sr, si, lr, li)
!
!*******************************************************************************
!
!! QUADPL calculate the zeros of the quadratic a*z**2+b1*z+c.
!     the quadratic formula, modified to avoid overflow,
!     is used to find the larger zero if the zeros are
!     real, and both zeros if the zeros are complex.
!     the smaller real zero is found directly from the
!     product of the zeros c/a.
!
  double precision a, b1, c, sr, si, lr, li, b, d, e
!
  if (a /= 0.d0) go to 20
     sr = 0.d0
     if (b1 /= 0.d0) sr = -c/b1
     lr = 0.d0
   10    si = 0.d0
     li = 0.d0
     return
!
   20 if (c /= 0.d0) go to 30
     sr = 0.d0
     lr = -b1/a
     go to 10
!
!     compute discriminant avoiding overflow
!
   30 b = b1/2.d0
  if (dabs(b) < dabs(c)) go to 40
     e = 1.d0 - (a/b)*(c/b)
     d = dsqrt(dabs(e))*dabs(b)
     go to 50
   40 e = a
  if (c < 0.d0) e = -a
  e = b*(b/dabs(c)) - e
  d = dsqrt(dabs(e))*dsqrt(dabs(c))
   50 if (e < 0.d0) go to 60
!
!     real zeros
!
  if (b >= 0.d0) d = -d
  lr = (-b + d)/a
  sr = 0.d0
  if (lr /= 0.d0) sr = (c/lr)/a
  go to 10
!
!     complex conjugate zeros
!
   60 sr = -b/a
  lr = sr
  si = dabs(d/a)
  li = -si
  return
end
subroutine quadsd (nn, u, v, p, q, a, b)
!
!*******************************************************************************
!
!! QUADSD divides p by the quadratic  1,u,v  placing the
!     quotient in q and the remainder in a,b.
!
  double precision p(nn), q(nn), u, v, a, b, c
!
  b = p(1)
  q(1) = b
  a = p(2) - u*b
  q(2) = a
  do 10 i = 3,nn
     c = p(i) - u*a - v*b
     q(i) = c
     b = a
     a = c
   10 continue
  return
end
subroutine qurv1 (n,x,y,z,slp1x,slp1y,slp1z,slpnx, &
                    slpny,slpnz,islpsw,xp,yp,zp,temp, &
                    s,sigma,ierr)
!
!*******************************************************************************
!
!! QURV1 determines the parameters necessary to
! compute a spline under tension passing through a sequence
! of triples (x(1),y(1),z(1)),...,(x(n),y(n),z(n)). the
! slopes at the two ends of the curve may be specified or
! omitted. for actual computation of points on the curve
! it is necessary to call the subroutine qurv2.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   n is the number of points to be interpolated (n >= 2).
!
!   x is an array containing the n x-coordinates of the
!   points.
!
!   y is an array containing the n y-coordinates of the
!   points.
!
!   z is an array containing the n z-coordinates of the
!   points. (adjacent x-y-z triples must be distinct, i. e.
!   either x(i) /= x(i+1) or y(i) /= y(i+1) or z(i) /=
!   z(i+1), for i = 1,...,n-1 ).
!
!   slp1x, slp1y, slp1z and slpnx, slpny, slpnz contain the
!   desired values of the components of tangent vectors to
!   the curve at (x(1),y(1),z(1)) and(x(n),y(n),z(n)),
!   respectively. the positive sense of the curve is assumed
!   to be that moving from point 1 to point n. the user may
!   omit values for either or both of these triples and
!   signal this with islpsw.
!
!   islpsw contains a switch indicating which slope data
!   should be used and which should be estimated by this
!   subroutine,
!          = 0 if slp1x, slp1y, slp1z and slpnx, slpny,
!              slpnz are to be used,
!          = 1 if slp1x, slp1y, slp1z are to be used but
!              not slpnx, slpny, slpnz,
!          = 2 if slpnx, slpny, slpnz are to be used but
!              not slp1x, slp1y, slp1z,
!          = 3 if both end-tangents are to be estimated
!              internally.
!
!   xp, yp, and zp are arrays of length at least n.
!
!   temp is an array of length at least n which is used
!   for scratch storage.
!
!   s is an array of length at least n.
!
! and
!
!   sigma contains the tension factor. this value indicates
!   the curviness desired. if abs(sigma) is nearly zero
!   (e.g. .001) the resulting curve is approximately a cubic
!   spline. if abs(sigma) is large (e. g. 50.) the resulting
!   curve is nearly a polygonal line. if sigma equals zero a
!   cubic spline results. a standard value for sigma is
!   approximately 1. in absolute value.
!
! on output--
!
!   xp, yp, and zp contain information about the curvature
!   of the curve at the given nodes.
!
!   s contains the polygonal arclengths of the curve.
!
!   ierr contains an error flag,
!        = 0 for normal return,
!        = 1 if n is less than 2,
!        = 2 if adjacent triples coincide.
!
! and
!
!   n, x, y, z, slp1x, slp1y, slp1z, slpnx, slpny, slpnz,
!   islpsw, and sigma are unaltered,
!
! this subroutine references package modules ceez, terms,
! and snhcsh.
!
  integer n,islpsw,ierr
  real x(n),y(n),z(n),slp1x,slp1y,slp1z,slpnx,slpny, &
       slpnz,xp(n),yp(n),zp(n),temp(n),s(n),sigma
!
  nm1 = n-1
  np1 = n+1
  ierr = 0
  if (n <= 1) go to 9
!
! determine polygonal arclengths
!
  s(1) = 0.
  do 1 i = 2,n
    im1 = i-1
1   s(i) = s(im1)+sqrt((x(i)-x(im1))**2+(y(i)-y(im1))**2 &
         +(z(i)-z(im1))**2)
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/s(n)
!
! approximate end slopes
!
  if (islpsw >= 2) go to 2
  slpp1x = slp1x
  slpp1y = slp1y
  slpp1z = slp1z
  go to 3
2 dels1 = s(2)-s(1)
  dels2 = dels1+dels1
  if (n > 2) dels2 = s(3)-s(1)
  if (dels1 == 0. .or. dels2 == 0.) go to 9
  call ceez (dels1,dels2,sigmap,c1,c2,c3,n)
  slpp1x = c1*x(1)+c2*x(2)
  slpp1y = c1*y(1)+c2*y(2)
  slpp1z = c1*z(1)+c2*z(2)
  if (n == 2) go to 3
  slpp1x = slpp1x+c3*x(3)
  slpp1y = slpp1y+c3*y(3)
  slpp1z = slpp1z+c3*z(3)
3 delt = sqrt(slpp1x*slpp1x+slpp1y*slpp1y+slpp1z*slpp1z)
  slpp1x = slpp1x/delt
  slpp1y = slpp1y/delt
  slpp1z = slpp1z/delt
  if (islpsw == 1 .or. islpsw == 3) go to 4
  slppnx = slpnx
  slppny = slpny
  slppnz = slpnz
  go to 5
4 delsn = s(n)-s(nm1)
  delsnm = delsn+delsn
  if (n > 2) delsnm = s(n)-s(n-2)
  if (delsn == 0. .or. delsnm == 0.) go to 10
  call ceez (-delsn,-delsnm,sigmap,c1,c2,c3,n)
  slppnx = c1*x(n)+c2*x(nm1)
  slppny = c1*y(n)+c2*y(nm1)
  slppnz = c1*z(n)+c2*z(nm1)
  if (n == 2) go to 5
  slppnx = slppnx+c3*x(n-2)
  slppny = slppny+c3*y(n-2)
  slppnz = slppnz+c3*z(n-2)
5 delt = sqrt(slppnx*slppnx+slppny*slppny+slppnz*slppnz)
  slppnx = slppnx/delt
  slppny = slppny/delt
  slppnz = slppnz/delt
!
! set up right hand sides and tridiagonal system for xp, yp
! and zp and perform forward elimination
!
  dx1 = (x(2)-x(1))/s(2)
  dy1 = (y(2)-y(1))/s(2)
  dz1 = (z(2)-z(1))/s(2)
  call terms (diag1,sdiag1,sigmap,s(2))
  xp(1) = (dx1-slpp1x)/diag1
  yp(1) = (dy1-slpp1y)/diag1
  zp(1) = (dz1-slpp1z)/diag1
  temp(1) = sdiag1/diag1
  if (n == 2) go to 7
  do 6 i = 2,nm1
    dels2 = s(i+1)-s(i)
    if (dels2 == 0.) go to 10
    dx2 = (x(i+1)-x(i))/dels2
    dy2 = (y(i+1)-y(i))/dels2
    dz2 = (z(i+1)-z(i))/dels2
    call terms (diag2,sdiag2,sigmap,dels2)
    diag = diag1+diag2-sdiag1*temp(i-1)
    diagin = 1./diag
    xp(i) = (dx2-dx1-sdiag1*xp(i-1))*diagin
    yp(i) = (dy2-dy1-sdiag1*yp(i-1))*diagin
    zp(i) = (dz2-dz1-sdiag1*zp(i-1))*diagin
    temp(i) = sdiag2*diagin
    dx1 = dx2
    dy1 = dy2
    dz1 = dz2
    diag1 = diag2
6   sdiag1 = sdiag2
7 diag = diag1-sdiag1*temp(nm1)
  xp(n) = (slppnx-dx1-sdiag1*xp(nm1))/diag
  yp(n) = (slppny-dy1-sdiag1*yp(nm1))/diag
  zp(n) = (slppnz-dz1-sdiag1*zp(nm1))/diag
!
! perform back substitution
!
  do 8 i = 2,n
    ibak = np1-i
    t = temp(ibak)
    xp(ibak) = xp(ibak)-t*xp(ibak+1)
    yp(ibak) = yp(ibak)-t*yp(ibak+1)
8   zp(ibak) = zp(ibak)-t*zp(ibak+1)
  return
!
! too few points
!
9 ierr = 1
  return
!
! coincident adjacent points
!
   10 ierr = 2
  return
end
subroutine qurv2 (t,xs,ys,zs,n,x,y,z,xp,yp,zp,s,sigma)
!
!*******************************************************************************
!
!! QURV2 performs the mapping of points in the
! interval (0.,1.) onto a curve in space.  the subroutine
! qurv1 should be called earlier to determine certain
! necessary parameters. the resulting curve has a parametric
! representation all of whose components are splines under
! tension and functions of the polygonal arclength
! parameter.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   t contains a real value to be mapped to a point on the
!   curve. the interval (0.,1.) is mapped onto the entire
!   curve, with 0. mapping to (x(1),y(1,z(1)) and 1. mapping
!   to (x(n),y(n),z(n)). values outside this interval result
!   in extrapolation.
!
!   n contains the number of points which were specified
!   to determine the curve.
!
!   x, y, and z are arrays containing the x-, y- and z-
!   coordinates of the specified points.
!
!   xp, yp, and zp are the arrays output from qurv1
!   containing curvature information.
!
!   s is an array containing the polygonal arclengths of
!   the curve.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters n, x, y, z, xp, yp, zp, s, and sigma
! should be input unaltered from the output of qurv1.
!
! on output--
!
!   xs, ys and zs contain the x-, y- and z-coordinates of
!   the image point on the curve.
!
! none of the input parameters are altered.
!
! this subroutine references package modules intrvl and
! snhcsh.
!
  integer n
  real t,xs,ys,zs,x(n),y(n),z(n),xp(n),yp(n),zp(n),s(n)
  real sigma
!
! determine interval
!
  tn = s(n)*t
  im1 = intrvl(tn,s,n)
  i = im1+1
!
! denormalize tension factor
!
  sigmap = abs(sigma)*real(n-1)/s(n)
!
! set up and perform interpolation
!
  del1 = tn-s(im1)
  del2 = s(i)-tn
  dels = s(i)-s(im1)
  sumx = (x(i)*del1+x(im1)*del2)/dels
  sumy = (y(i)*del1+y(im1)*del2)/dels
  sumz = (z(i)*del1+z(im1)*del2)/dels
  if (sigmap /= 0.) go to 1
  d = del1*del2/(6.*dels)
  c1 = (del1+dels)*d
  c2 = (del2+dels)*d
  xs = sumx-xp(i)*c1-xp(im1)*c2
  ys = sumy-yp(i)*c1-yp(im1)*c2
  zs = sumz-zp(i)*c1-zp(im1)*c2
  return
1 delp1 = sigmap*(del1+dels)/2.
  delp2 = sigmap*(del2+dels)/2.
  call snhcsh(sinhm1,dummy,sigmap*del1,-1)
  call snhcsh(sinhm2,dummy,sigmap*del2,-1)
  call snhcsh(sinhms,dummy,sigmap*dels,-1)
  call snhcsh (sinhp1,dummy,sigmap*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmap*del2/2.,-1)
  call snhcsh (dummy,coshp1,delp1,1)
  call snhcsh (dummy,coshp2,delp2,1)
  d = sigmap*sigmap*dels*(sinhms+sigmap*dels)
  c1 = (sinhm1*del2-del1*(2.*(coshp1+1.)*sinhp2+sigmap* &
       coshp1*del2))/d
  c2 = (sinhm2*del1-del2*(2.*(coshp2+1.)*sinhp1+sigmap* &
       coshp2*del1))/d
  xs = sumx+xp(i)*c1+xp(im1)*c2
  ys = sumy+yp(i)*c1+yp(im1)*c2
  zs = sumz+zp(i)*c1+zp(im1)*c2
  return
end
subroutine r1mpyq(m,n,a,lda,v,w)
!
!*******************************************************************************
!
!! R1MPYQ multiplies a matrix by a sequence of givens rotations.
!
!
!     subroutine r1mpyq
!
!     given an m by n matrix a, this subroutine computes a*q where
!     q is the product of 2*(n - 1) transformations
!
!           gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
!
!     and gv(i), gw(i) are givens rotations in the (i,n) plane which
!     eliminate elements in the i-th and n-th planes, respectively.
!     q itself is not given, rather the information to recover the
!     gv, gw rotations is supplied.
!
!     the subroutine statement is
!
!       subroutine r1mpyq(m,n,a,lda,v,w)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of a.
!
!       n is a positive integer input variable set to the number
!         of columns of a.
!
!       a is an m by n array. on input a must contain the matrix
!         to be postmultiplied by the orthogonal matrix q
!         described above. on output a*q has replaced a.
!
!       lda is a positive integer input variable not less than m
!         which specifies the leading dimension of the array a.
!
!       v is an input array of length n. v(i) must contain the
!         information necessary to recover the givens rotation gv(i)
!         described above.
!
!       w is an input array of length n. w(i) must contain the
!         information necessary to recover the givens rotation gw(i)
!         described above.
!
!     subroutines called
!
!       fortran-supplied ... abs,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
  integer m,n,lda
  real a(lda,n),v(n),w(n)
  integer i,j,nmj,nm1
  real cos,one,sin,temp
  data one /1.0e0/
!
!     apply the first set of givens rotations to a.
!
  nm1 = n - 1
  if (nm1 < 1) go to 50
  do 20 nmj = 1, nm1
     j = n - nmj
     if (abs(v(j)) > one) cos = one/v(j)
     if (abs(v(j)) > one) sin = sqrt(one-cos**2)
     if (abs(v(j)) <= one) sin = v(j)
     if (abs(v(j)) <= one) cos = sqrt(one-sin**2)
     do 10 i = 1, m
        temp = cos*a(i,j) - sin*a(i,n)
        a(i,n) = sin*a(i,j) + cos*a(i,n)
        a(i,j) = temp
   10       continue
   20    continue
!
!     apply the second set of givens rotations to a.
!
  do 40 j = 1, nm1
     if (abs(w(j)) > one) cos = one/w(j)
     if (abs(w(j)) > one) sin = sqrt(one-cos**2)
     if (abs(w(j)) <= one) sin = w(j)
     if (abs(w(j)) <= one) cos = sqrt(one-sin**2)
     do 30 i = 1, m
        temp = cos*a(i,j) + sin*a(i,n)
        a(i,n) = -sin*a(i,j) + cos*a(i,n)
        a(i,j) = temp
   30       continue
   40    continue
   50 continue
  return
end
subroutine r1updt(m,n,s,ls,u,v,w,sing)
!
!*******************************************************************************
!
!! R1UPDT updates the r factor of a qr factorization, following a rank 1 update.
!
!
!     subroutine r1updt
!
!     given an m by n lower trapezoidal matrix s, an m-vector u,
!     and an n-vector v, the problem is to determine an
!     orthogonal matrix q such that
!
!                   t
!           (s + u*v )*q
!
!     is again lower trapezoidal.
!
!     this subroutine determines q as the product of 2*(n - 1)
!     transformations
!
!           gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
!
!     where gv(i), gw(i) are givens rotations in the (i,n) plane
!     which eliminate elements in the i-th and n-th planes,
!     respectively. q itself is not accumulated, rather the
!     information to recover the gv, gw rotations is returned.
!
!     the subroutine statement is
!
!       subroutine r1updt(m,n,s,ls,u,v,w,sing)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of s.
!
!       n is a positive integer input variable set to the number
!         of columns of s. n must not exceed m.
!
!       s is an array of length ls. on input s must contain the lower
!         trapezoidal matrix s stored by columns. on output s contains
!         the lower trapezoidal matrix produced as described above.
!
!       ls is a positive integer input variable not less than
!         (n*(2*m-n+1))/2.
!
!       u is an input array of length m which must contain the
!         vector u.
!
!       v is an array of length n. on input v must contain the vector
!         v. on output v(i) contains the information necessary to
!         recover the givens rotation gv(i) described above.
!
!       w is an output array of length m. w(i) contains information
!         necessary to recover the givens rotation gw(i) described
!         above.
!
!       sing is a logical output variable. sing is set true if any
!         of the diagonal elements of the output s are zero. otherwise
!         sing is set false.
!
!     subprograms called
!
!
!       fortran-supplied ... abs,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more,
!     john l. nazareth
!
  integer m,n,ls
  logical sing
  real s(ls),u(m),v(n),w(m)
!
  integer i,j,jj,l,nmj,nm1
  real cos,cotan,giant,one,p5,p25,sin,tan,tau,temp,zero
  data one,p5,p25,zero /1.0e0,5.0e-1,2.5e-1,0.0e0/
!
!     giant is the largest magnitude.
!
  giant = huge ( giant )
!
!     initialize the diagonal element pointer.
!
  jj = (n*(2*m - n + 1))/2 - (m - n)
!
!     move the nontrivial part of the last column of s into w.
!
  l = jj
  do 10 i = n, m
     w(i) = s(l)
     l = l + 1
   10    continue
!
!     rotate the vector v into a multiple of the n-th unit vector
!     in such a way that a spike is introduced into w.
!
  nm1 = n - 1
  if (nm1 < 1) go to 70
  do 60 nmj = 1, nm1
     j = n - nmj
     jj = jj - (m - j + 1)
     w(j) = zero
     if (v(j) == zero) go to 50
!
!        determine a givens rotation which eliminates the
!        j-th element of v.
!
     if (abs(v(n)) >= abs(v(j))) go to 20
        cotan = v(n)/v(j)
        sin = p5/sqrt(p25+p25*cotan**2)
        cos = sin*cotan
        tau = one
        if (abs(cos)*giant > one) tau = one/cos
        go to 30
   20    continue
        tan = v(j)/v(n)
        cos = p5/sqrt(p25+p25*tan**2)
        sin = cos*tan
        tau = sin
   30    continue
!
!        apply the transformation to v and store the information
!        necessary to recover the givens rotation.
!
     v(n) = sin*v(j) + cos*v(n)
     v(j) = tau
!
!        apply the transformation to s and extend the spike in w.
!
     l = jj
     do 40 i = j, m
        temp = cos*s(l) - sin*w(i)
        w(i) = sin*s(l) + cos*w(i)
        s(l) = temp
        l = l + 1
   40       continue
   50    continue
   60    continue
   70 continue
!
!     add the spike from the rank 1 update to w.
!
  do 80 i = 1, m
     w(i) = w(i) + v(n)*u(i)
   80    continue
!
!     eliminate the spike.
!
  sing = .false.
  if (nm1 < 1) go to 140
  do 130 j = 1, nm1
     if (w(j) == zero) go to 120
!
!        determine a givens rotation which eliminates the
!        j-th element of the spike.
!
     if (abs(s(jj)) >= abs(w(j))) go to 90
        cotan = s(jj)/w(j)
        sin = p5/sqrt(p25+p25*cotan**2)
        cos = sin*cotan
        tau = one
        if (abs(cos)*giant > one) tau = one/cos
        go to 100
   90    continue
        tan = w(j)/s(jj)
        cos = p5/sqrt(p25+p25*tan**2)
        sin = cos*tan
        tau = sin
  100    continue
!
!        apply the transformation to s and reduce the spike in w.
!
     l = jj
     do 110 i = j, m
        temp = cos*s(l) + sin*w(i)
        w(i) = -sin*s(l) + cos*w(i)
        s(l) = temp
        l = l + 1
  110       continue
!
!        store the information necessary to recover the
!        givens rotation.
!
     w(j) = tau
  120    continue
!
!        test for zero diagonal elements in the output s.
!
     if (s(jj) == zero) sing = .true.
     jj = jj + (m - j + 1)
  130    continue
  140 continue
!
!     move w back into the last column of the output s.
!
  l = jj
  do 150 i = n, m
     s(l) = w(i)
     l = l + 1
  150    continue
  if (s(jj) == zero) sing = .true.
  return
!
!     last card of subroutine r1updt.
!
end
subroutine radb2 ( ido, l1, cc, ch, wa1 )
!
!*******************************************************************************
!
!! RADB2 is a lower level routine used by RFFTB1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,2,l1)
  real ch(ido,l1,2)
  integer i
  integer ic
  integer k
  real ti2
  real tr2
  real wa1(ido)
!
  ch(1,1:l1,1) = cc(1,1,1:l1) + cc(ido,2,1:l1)
  ch(1,1:l1,2) = cc(1,1,1:l1) - cc(ido,2,1:l1)

  if ( ido < 2 ) then
    return
  end if

  if ( ido > 2 ) then

    do k = 1, l1
      do i = 3, ido, 2

        ic = ido + 2 - i

        ch(i-1,k,1) = cc(i-1,1,k) + cc(ic-1,2,k)
        tr2         = cc(i-1,1,k) - cc(ic-1,2,k)
        ch(i,k,1)   = cc(i,1,k)   - cc(ic,2,k)
        ti2         = cc(i,1,k)   + cc(ic,2,k)

        ch(i-1,k,2) = wa1(i-2) * tr2 - wa1(i-1) * ti2
        ch(i,k,2)   = wa1(i-2) * ti2 + wa1(i-1) * tr2

      end do
    end do

    if ( mod ( ido, 2 ) == 1 ) then
      return
    end if

  end if

  ch(ido,1:l1,1) =    cc(ido,1,1:l1) + cc(ido,1,1:l1)
  ch(ido,1:l1,2) = -( cc(1,2,1:l1)   + cc(1,2,1:l1) )

  return
end
subroutine radb3 ( ido, l1, cc, ch, wa1, wa2 )
!
!*******************************************************************************
!
!! RADB3 is a lower level routine used by RFFTB1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,3,l1)
  real ch(ido,l1,3)
  real ci2
  real ci3
  real cr2
  real cr3
  real di2
  real di3
  real dr2
  real dr3
  integer i
  integer ic
  integer k
  real, parameter :: taui =  0.866025403784439E+00
  real, parameter :: taur = -0.5E+00
  real ti2
  real tr2
  real wa1(ido)
  real wa2(ido)
!
  do k = 1, l1

    tr2 = cc(ido,2,k) + cc(ido,2,k)
    cr2 = cc(1,1,k) + taur * tr2
    ch(1,k,1) = cc(1,1,k) + tr2
    ci3 = taui * ( cc(1,3,k) + cc(1,3,k) )

    ch(1,k,2) = cr2 - ci3
    ch(1,k,3) = cr2 + ci3

  end do

  if ( ido == 1 ) then
    return
  end if

  do k = 1, l1
    do i = 3, ido, 2

      ic = ido + 2 - i

      tr2 = cc(i-1,3,k) + cc(ic-1,2,k)
      cr2 = cc(i-1,1,k) + taur * tr2
      ch(i-1,k,1) = cc(i-1,1,k) + tr2

      ti2 = cc(i,3,k) - cc(ic,2,k)
      ci2 = cc(i,1,k) + taur * ti2
      ch(i,k,1) = cc(i,1,k) + ti2

      cr3 = taui * ( cc(i-1,3,k) - cc(ic-1,2,k) )
      ci3 = taui * ( cc(i,3,k)   + cc(ic,2,k) )

      dr2 = cr2 - ci3
      dr3 = cr2 + ci3
      di2 = ci2 + cr3
      di3 = ci2 - cr3

      ch(i-1,k,2) = wa1(i-2) * dr2 - wa1(i-1) * di2
      ch(i,k,2)   = wa1(i-2) * di2 + wa1(i-1) * dr2
      ch(i-1,k,3) = wa2(i-2) * dr3 - wa2(i-1) * di3
      ch(i,k,3)   = wa2(i-2) * di3 + wa2(i-1) * dr3

    end do
  end do

  return
end
subroutine radb4 ( ido, l1, cc, ch, wa1, wa2, wa3 )
!
!*******************************************************************************
!
!! RADB4 is a lower level routine used by RFFTB1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,4,l1)
  real ch(ido,l1,4)
  real ci2
  real ci3
  real ci4
  real cr2
  real cr3
  real cr4
  integer i
  integer ic
  integer k
  real, parameter :: sqrt2 = 1.414213562373095E+00
  real ti1
  real ti2
  real ti3
  real ti4
  real tr1
  real tr2
  real tr3
  real tr4
  real wa1(ido)
  real wa2(ido)
  real wa3(ido)
!
  do k = 1, l1

    tr1 = cc(1,1,k) - cc(ido,4,k)
    tr2 = cc(1,1,k) + cc(ido,4,k)
    tr3 = cc(ido,2,k) + cc(ido,2,k)
    tr4 = cc(1,3,k) + cc(1,3,k)

    ch(1,k,1) = tr2 + tr3
    ch(1,k,2) = tr1 - tr4
    ch(1,k,3) = tr2 - tr3
    ch(1,k,4) = tr1 + tr4

  end do

  if ( ido < 2 ) then
    return
  end if

  if ( ido > 2 ) then

    do k = 1, l1
      do i = 3, ido, 2

        ic = ido + 2 - i

        ti1 = cc(i,1,k) + cc(ic,4,k)
        ti2 = cc(i,1,k) - cc(ic,4,k)
        ti3 = cc(i,3,k) - cc(ic,2,k)
        tr4 = cc(i,3,k) + cc(ic,2,k)

        tr1 = cc(i-1,1,k) - cc(ic-1,4,k)
        tr2 = cc(i-1,1,k) + cc(ic-1,4,k)
        ti4 = cc(i-1,3,k) - cc(ic-1,2,k)
        tr3 = cc(i-1,3,k) + cc(ic-1,2,k)

        ch(i-1,k,1) = tr2 + tr3
        cr3         = tr2 - tr3
        ch(i,k,1)   = ti2 + ti3
        ci3         = ti2 - ti3

        cr2 = tr1 - tr4
        cr4 = tr1 + tr4
        ci2 = ti1 + ti4
        ci4 = ti1 - ti4

        ch(i-1,k,2) = wa1(i-2) * cr2 - wa1(i-1) * ci2
        ch(i,k,2)   = wa1(i-2) * ci2 + wa1(i-1) * cr2
        ch(i-1,k,3) = wa2(i-2) * cr3 - wa2(i-1) * ci3
        ch(i,k,3)   = wa2(i-2) * ci3 + wa2(i-1) * cr3
        ch(i-1,k,4) = wa3(i-2) * cr4 - wa3(i-1) * ci4
        ch(i,k,4)   = wa3(i-2) * ci4 + wa3(i-1) * cr4

      end do
    end do

    if ( mod ( ido, 2 ) == 1 ) then
      return
    end if

  end if

  do k = 1, l1

    ti1 = cc(1,2,k)   + cc(1,4,k)
    ti2 = cc(1,4,k)   - cc(1,2,k)
    tr1 = cc(ido,1,k) - cc(ido,3,k)
    tr2 = cc(ido,1,k) + cc(ido,3,k)

    ch(ido,k,1) = tr2 + tr2
    ch(ido,k,2) = sqrt2 * ( tr1 - ti1 )
    ch(ido,k,3) = ti2 + ti2
    ch(ido,k,4) = -sqrt2 * ( tr1 + ti1 )

  end do

  return
end
subroutine radb5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 )
!
!*******************************************************************************
!
!! RADB5 is a lower level routine used by RFFTB1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,5,l1)
  real ch(ido,l1,5)
  real ci2
  real ci3
  real ci4
  real ci5
  real cr2
  real cr3
  real cr4
  real cr5
  real di2
  real di3
  real di4
  real di5
  real dr2
  real dr3
  real dr4
  real dr5
  integer i
  integer ic
  integer k
  real, parameter :: ti11 =  0.951056516295154E+00
  real, parameter :: ti12 =  0.587785252292473E+00
  real ti2
  real ti3
  real ti4
  real ti5
  real, parameter :: tr11 =  0.309016994374947E+00
  real, parameter :: tr12 = -0.809016994374947E+00
  real tr2
  real tr3
  real tr4
  real tr5
  real wa1(ido)
  real wa2(ido)
  real wa3(ido)
  real wa4(ido)
!
  do k = 1, l1

    ti5 = cc(1,3,k) + cc(1,3,k)
    ti4 = cc(1,5,k) + cc(1,5,k)
    tr2 = cc(ido,2,k) + cc(ido,2,k)
    tr3 = cc(ido,4,k) + cc(ido,4,k)

    ch(1,k,1) = cc(1,1,k) + tr2 + tr3
    cr2 = cc(1,1,k) + tr11 * tr2 + tr12 * tr3
    cr3 = cc(1,1,k) + tr12 * tr2 + tr11 * tr3
    ci5 = ti11 * ti5 + ti12 * ti4
    ci4 = ti12 * ti5 - ti11 * ti4

    ch(1,k,2) = cr2 - ci5
    ch(1,k,3) = cr3 - ci4
    ch(1,k,4) = cr3 + ci4
    ch(1,k,5) = cr2 + ci5

  end do

  if ( ido == 1 ) then
    return
  end if

  do k = 1, l1
    do i = 3, ido, 2

      ic = ido + 2 - i

      ti5 = cc(i,3,k) + cc(ic,2,k)
      ti2 = cc(i,3,k) - cc(ic,2,k)
      ti4 = cc(i,5,k) + cc(ic,4,k)
      ti3 = cc(i,5,k) - cc(ic,4,k)
      tr5 = cc(i-1,3,k) - cc(ic-1,2,k)
      tr2 = cc(i-1,3,k) + cc(ic-1,2,k)
      tr4 = cc(i-1,5,k) - cc(ic-1,4,k)
      tr3 = cc(i-1,5,k) + cc(ic-1,4,k)

      ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3
      ch(i,k,1)   = cc(i,1,k) + ti2 + ti3

      cr2 = cc(i-1,1,k) + tr11 * tr2 + tr12 * tr3
      ci2 = cc(i,1,k)   + tr11 * ti2 + tr12 * ti3
      cr3 = cc(i-1,1,k) + tr12 * tr2 + tr11 * tr3
      ci3 = cc(i,1,k)   + tr12 * ti2 + tr11 * ti3

      cr5 = ti11 * tr5 + ti12 * tr4
      ci5 = ti11 * ti5 + ti12 * ti4
      cr4 = ti12 * tr5 - ti11 * tr4
      ci4 = ti12 * ti5 - ti11 * ti4

      dr3 = cr3 - ci4
      dr4 = cr3 + ci4
      di3 = ci3 + cr4
      di4 = ci3 - cr4
      dr5 = cr2 + ci5
      dr2 = cr2 - ci5
      di5 = ci2 - cr5
      di2 = ci2 + cr5

      ch(i-1,k,2) = wa1(i-2) * dr2 - wa1(i-1) * di2
      ch(i,k,2)   = wa1(i-2) * di2 + wa1(i-1) * dr2
      ch(i-1,k,3) = wa2(i-2) * dr3 - wa2(i-1) * di3
      ch(i,k,3)   = wa2(i-2) * di3 + wa2(i-1) * dr3
      ch(i-1,k,4) = wa3(i-2) * dr4 - wa3(i-1) * di4
      ch(i,k,4)   = wa3(i-2) * di4 + wa3(i-1) * dr4
      ch(i-1,k,5) = wa4(i-2) * dr5 - wa4(i-1) * di5
      ch(i,k,5)   = wa4(i-2) * di5 + wa4(i-1) * dr5

    end do
  end do

  return
end
subroutine radbg ( ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa )
!
!*******************************************************************************
!
!! RADBG is a lower level routine used by RFFTB1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer idl1
  integer ido
  integer ip
  integer l1
!
  real ai1
  real ai2
  real ar1
  real ar1h
  real ar2
  real ar2h
  real arg
  real c1(ido,l1,ip)
  real c2(idl1,ip)
  real cc(ido,ip,l1)
  real ch(ido,l1,ip)
  real ch2(idl1,ip)
  real dc2
  real dcp
  real ds2
  real dsp
  integer i
  integer ic
  integer idij
  integer ik
  integer ipph
  integer is
  integer j
  integer j2
  integer jc
  integer k
  integer l
  integer lc
  integer nbd
  real r_pi
  real wa(*)
!
  arg = 2.0E+00 * r_pi() / real ( ip )
  dcp = cos ( arg )
  dsp = sin ( arg )
  nbd = ( ido - 1 ) / 2
  ipph = ( ip + 1 ) / 2
  ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1)

  do j = 2, ipph
    jc = ip + 2 - j
    j2 = j + j
    ch(1,1:l1,j) =  cc(ido,j2-2,1:l1) + cc(ido,j2-2,1:l1)
    ch(1,1:l1,jc) = cc(1,j2-1,1:l1)   + cc(1,j2-1,1:l1)
  end do

  if ( ido /= 1 ) then

    if ( nbd >= l1 ) then

      do j = 2, ipph
        jc = ip + 2 - j
        do k = 1, l1
          do i = 3, ido, 2
            ic = ido + 2 - i
            ch(i-1,k,j)  = cc(i-1,2*j-1,k) + cc(ic-1,2*j-2,k)
            ch(i-1,k,jc) = cc(i-1,2*j-1,k) - cc(ic-1,2*j-2,k)
            ch(i,k,j)    = cc(i,2*j-1,k)   - cc(ic,2*j-2,k)
            ch(i,k,jc)   = cc(i,2*j-1,k)   + cc(ic,2*j-2,k)
          end do
        end do
      end do

    else

      do j = 2, ipph
        jc = ip + 2 - j
        do i = 3, ido, 2
          ic = ido + 2 - i
          ch(i-1,1:l1,j)  = cc(i-1,2*j-1,1:l1) + cc(ic-1,2*j-2,1:l1)
          ch(i-1,1:l1,jc) = cc(i-1,2*j-1,1:l1) - cc(ic-1,2*j-2,1:l1)
          ch(i,1:l1,j)    = cc(i,2*j-1,1:l1)   - cc(ic,2*j-2,1:l1)
          ch(i,1:l1,jc)   = cc(i,2*j-1,1:l1)   + cc(ic,2*j-2,1:l1)
        end do
      end do

    end if

  end if

  ar1 = 1.0E+00
  ai1 = 0.0E+00

  do l = 2, ipph

    lc = ip + 2 - l
    ar1h = dcp * ar1 - dsp * ai1
    ai1 =  dcp * ai1 + dsp * ar1
    ar1 = ar1h

    do ik = 1, idl1
      c2(ik,l)  = ch2(ik,1) + ar1 * ch2(ik,2)
      c2(ik,lc) =             ai1 * ch2(ik,ip)
    end do

    dc2 = ar1
    ds2 = ai1
    ar2 = ar1
    ai2 = ai1

    do j = 3, ipph

      jc = ip + 2 - j
      ar2h = dc2 * ar2 - ds2 * ai2
      ai2  = dc2 * ai2 + ds2 * ar2
      ar2 = ar2h

      do ik = 1, idl1
        c2(ik,l)  = c2(ik,l)  + ar2 * ch2(ik,j)
        c2(ik,lc) = c2(ik,lc) + ai2 * ch2(ik,jc)
      end do

    end do

  end do

  do j = 2, ipph
    ch2(1:idl1,1) = ch2(1:idl1,1) + ch2(1:idl1,j)
  end do

  do j = 2, ipph
    jc = ip + 2 - j
    ch(1,1:l1,j)  = c1(1,1:l1,j) - c1(1,1:l1,jc)
    ch(1,1:l1,jc) = c1(1,1:l1,j) + c1(1,1:l1,jc)
  end do

  if ( ido /= 1 ) then

    if ( nbd >= l1 ) then

      do j = 2, ipph
        jc = ip + 2 - j
        do k = 1, l1
          do i = 3, ido, 2
            ch(i-1,k,j)  = c1(i-1,k,j) - c1(i,k,jc)
            ch(i-1,k,jc) = c1(i-1,k,j) + c1(i,k,jc)
            ch(i,k,j)    = c1(i,k,j)   + c1(i-1,k,jc)
            ch(i,k,jc)   = c1(i,k,j)   - c1(i-1,k,jc)
          end do
        end do
      end do

    else

      do j = 2, ipph
        jc = ip + 2 - j
        do i = 3, ido, 2
          ch(i-1,1:l1,j)  = c1(i-1,1:l1,j) - c1(i,1:l1,jc)
          ch(i-1,1:l1,jc) = c1(i-1,1:l1,j) + c1(i,1:l1,jc)
          ch(i,1:l1,j)    = c1(i,1:l1,j)   + c1(i-1,1:l1,jc)
          ch(i,1:l1,jc)   = c1(i,1:l1,j)   - c1(i-1,1:l1,jc)
        end do
      end do

    end if

  end if

  if ( ido == 1 ) then
    return
  end if

  c2(1:idl1,1) = ch2(1:idl1,1)
  c1(1,1:l1,2:ip) = ch(1,1:l1,2:ip)

  if ( nbd <= l1 ) then

    is = -ido

    do j = 2, ip
      is = is + ido
      idij = is
      do i = 3, ido, 2
        idij = idij + 2
        c1(i-1,1:l1,j) = wa(idij-1) * ch(i-1,1:l1,j) - wa(idij) * ch(i,1:l1,j)
        c1(i,1:l1,j)   = wa(idij-1) * ch(i,1:l1,j)   + wa(idij) * ch(i-1,1:l1,j)
      end do
    end do

  else

    is = -ido
    do j = 2, ip
      is = is + ido
      do k = 1, l1
        idij = is
        do i = 3, ido, 2
          idij = idij + 2
          c1(i-1,k,j) = wa(idij-1) * ch(i-1,k,j) - wa(idij) * ch(i,k,j)
          c1(i,k,j)   = wa(idij-1) * ch(i,k,j)   + wa(idij) * ch(i-1,k,j)
        end do
      end do
    end do

  end if

  return
end
function r_pi ( )
!
!*******************************************************************************
!
!! R_PI returns the value of pi.
!
!
!  Modified:
!
!    04 December 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, real R_PI, the value of pi.
!
  implicit none
!
  real r_pi
!
  r_pi = 3.14159265358979323846264338327950288419716939937510E+00

  return
end
subroutine radf2 ( ido, l1, cc, ch, wa1 )
!
!*******************************************************************************
!
!! RADF2 is a lower level routine used by RFFTF1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,l1,2)
  real ch(ido,2,l1)
  integer i
  integer ic
  integer k
  real ti2
  real tr2
  real wa1(ido)
!
  ch(1,1,1:l1)   = cc(1,1:l1,1) + cc(1,1:l1,2)
  ch(ido,2,1:l1) = cc(1,1:l1,1) - cc(1,1:l1,2)

  if ( ido < 2 ) then
    return
  end if

  if ( ido > 2 ) then

    do k = 1, l1
      do i = 3, ido, 2

        ic = ido + 2 - i

        tr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2)
        ti2 = wa1(i-2) * cc(i,k,2)   - wa1(i-1) * cc(i-1,k,2)

        ch(i,1,k) = cc(i,k,1) + ti2
        ch(ic,2,k) = ti2 - cc(i,k,1)
        ch(i-1,1,k) = cc(i-1,k,1) + tr2
        ch(ic-1,2,k) = cc(i-1,k,1) - tr2

      end do
    end do

    if ( mod ( ido, 2 ) == 1 ) then
      return
    end if

  end if

  ch(1,2,1:l1) = -cc(ido,1:l1,2)
  ch(ido,1,1:l1) = cc(ido,1:l1,1)

  return
end
subroutine radf3 ( ido, l1, cc, ch, wa1, wa2 )
!
!*******************************************************************************
!
!! RADF3 is a lower level routine used by RFFTF1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,l1,3)
  real ch(ido,3,l1)
  real ci2
  real cr2
  real di2
  real di3
  real dr2
  real dr3
  integer i
  integer ic
  integer k
  real, parameter :: taui = 0.866025403784439E+00
  real, parameter :: taur = -0.5E+00
  real ti2
  real ti3
  real tr2
  real tr3
  real wa1(ido)
  real wa2(ido)
!
  do k = 1, l1
    cr2 = cc(1,k,2) + cc(1,k,3)
    ch(1,1,k) = cc(1,k,1) + cr2
    ch(1,3,k) = taui * ( cc(1,k,3) - cc(1,k,2) )
    ch(ido,2,k) = cc(1,k,1) + taur * cr2
  end do

  if ( ido == 1 ) then
    return
  end if

  do k = 1, l1
    do i = 3, ido, 2

      ic = ido + 2 - i

      dr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2)
      di2 = wa1(i-2) * cc(i,k,2)   - wa1(i-1) * cc(i-1,k,2)
      dr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3)
      di3 = wa2(i-2) * cc(i,k,3)   - wa2(i-1) * cc(i-1,k,3)

      cr2 = dr2 + dr3
      ci2 = di2 + di3

      ch(i-1,1,k) = cc(i-1,k,1) + cr2
      ch(i,1,k)   = cc(i,k,1) + ci2

      tr2 = cc(i-1,k,1) + taur * cr2
      ti2 = cc(i,k,1) + taur * ci2
      tr3 = taui * ( di2 - di3 )
      ti3 = taui * ( dr3 - dr2 )

      ch(i-1,3,k) = tr2 + tr3
      ch(ic-1,2,k) = tr2 - tr3
      ch(i,3,k) = ti2 + ti3
      ch(ic,2,k) = ti3 - ti2

    end do
  end do

  return
end
subroutine radf4 ( ido, l1, cc, ch, wa1, wa2, wa3 )
!
!*******************************************************************************
!
!! RADF4 is a lower level routine used by RFFTF1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,l1,4)
  real ch(ido,4,l1)
  real ci2
  real ci3
  real ci4
  real cr2
  real cr3
  real cr4
  real, parameter :: hsqt2 = 0.7071067811865475E+00
  integer i
  integer ic
  integer k
  real ti1
  real ti2
  real ti3
  real ti4
  real tr1
  real tr2
  real tr3
  real tr4
  real wa1(ido)
  real wa2(ido)
  real wa3(ido)
!
  do k = 1, l1
    tr1 = cc(1,k,2) + cc(1,k,4)
    tr2 = cc(1,k,1) + cc(1,k,3)
    ch(1,1,k) = tr1 + tr2
    ch(ido,4,k) = tr2 - tr1
    ch(ido,2,k) = cc(1,k,1) - cc(1,k,3)
    ch(1,3,k) = cc(1,k,4) - cc(1,k,2)
  end do

  if ( ido < 2 ) then
    return
  end if

  if ( ido > 2 ) then

    do k = 1, l1
      do i = 3, ido, 2

        ic = ido + 2 - i

        cr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2)
        ci2 = wa1(i-2) * cc(i,k,2)   - wa1(i-1) * cc(i-1,k,2)
        cr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3)
        ci3 = wa2(i-2) * cc(i,k,3)   - wa2(i-1) * cc(i-1,k,3)
        cr4 = wa3(i-2) * cc(i-1,k,4) + wa3(i-1) * cc(i,k,4)
        ci4 = wa3(i-2) * cc(i,k,4)   - wa3(i-1) * cc(i-1,k,4)

        tr1 = cr2+cr4
        tr4 = cr4-cr2
        ti1 = ci2+ci4
        ti4 = ci2-ci4
        ti2 = cc(i,k,1) + ci3
        ti3 = cc(i,k,1) - ci3
        tr2 = cc(i-1,k,1) + cr3
        tr3 = cc(i-1,k,1) - cr3

        ch(i-1,1,k)  = tr1 + tr2
        ch(ic-1,4,k) = tr2 - tr1
        ch(i,1,k)    = ti1 + ti2
        ch(ic,4,k)   = ti1 - ti2
        ch(i-1,3,k)  = ti4 + tr3
        ch(ic-1,2,k) = tr3 - ti4
        ch(i,3,k)    = tr4 + ti3
        ch(ic,2,k)   = tr4 - ti3

      end do
    end do

    if ( mod ( ido, 2 ) == 1 ) then
      return
    end if

  end if

  do k = 1, l1

    ti1 = -hsqt2 * ( cc(ido,k,2) + cc(ido,k,4) )
    tr1 =  hsqt2 * ( cc(ido,k,2) - cc(ido,k,4) )

    ch(ido,1,k) = tr1 + cc(ido,k,1)
    ch(ido,3,k) = cc(ido,k,1) - tr1

    ch(1,2,k) = ti1 - cc(ido,k,3)
    ch(1,4,k) = ti1 + cc(ido,k,3)

  end do

  return
end
subroutine radf5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 )
!
!*******************************************************************************
!
!! RADF5 is a lower level routine used by RFFTF1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer ido
  integer l1
!
  real cc(ido,l1,5)
  real ch(ido,5,l1)
  real ci2
  real ci3
  real ci4
  real ci5
  real cr2
  real cr3
  real cr4
  real cr5
  real di2
  real di3
  real di4
  real di5
  real dr2
  real dr3
  real dr4
  real dr5
  integer i
  integer ic
  integer k
  real, parameter :: ti11 =  0.951056516295154E+00
  real, parameter :: ti12 =  0.587785252292473E+00
  real ti2
  real ti3
  real ti4
  real ti5
  real, parameter :: tr11 =  0.309016994374947E+00
  real, parameter :: tr12 = -0.809016994374947E+00
  real tr2
  real tr3
  real tr4
  real tr5
  real wa1(ido)
  real wa2(ido)
  real wa3(ido)
  real wa4(ido)
!
  do k = 1, l1

    cr2 = cc(1,k,5) + cc(1,k,2)
    ci5 = cc(1,k,5) - cc(1,k,2)
    cr3 = cc(1,k,4) + cc(1,k,3)
    ci4 = cc(1,k,4) - cc(1,k,3)

    ch(1,1,k)   = cc(1,k,1) + cr2 + cr3
    ch(ido,2,k) = cc(1,k,1) + tr11 * cr2 + tr12 * cr3
    ch(1,3,k)   = ti11 * ci5 + ti12 * ci4
    ch(ido,4,k) = cc(1,k,1) + tr12 * cr2 + tr11 * cr3
    ch(1,5,k)   = ti12 * ci5 - ti11 * ci4

  end do

  if ( ido == 1 ) then
    return
  end if

  do k = 1, l1
    do i = 3, ido, 2

      ic = ido + 2 - i

      dr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2)
      di2 = wa1(i-2) * cc(i,k,2)   - wa1(i-1) * cc(i-1,k,2)
      dr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3)
      di3 = wa2(i-2) * cc(i,k,3)   - wa2(i-1) * cc(i-1,k,3)
      dr4 = wa3(i-2) * cc(i-1,k,4) + wa3(i-1) * cc(i,k,4)
      di4 = wa3(i-2) * cc(i,k,4)   - wa3(i-1) * cc(i-1,k,4)
      dr5 = wa4(i-2) * cc(i-1,k,5) + wa4(i-1) * cc(i,k,5)
      di5 = wa4(i-2) * cc(i,k,5)   - wa4(i-1) * cc(i-1,k,5)

      cr2 = dr2 + dr5
      ci5 = dr5 - dr2
      cr5 = di2 - di5
      ci2 = di2 + di5
      cr3 = dr3 + dr4
      ci4 = dr4 - dr3
      cr4 = di3 - di4
      ci3 = di3 + di4

      ch(i-1,1,k) = cc(i-1,k,1) + cr2 + cr3
      ch(i,1,k)   = cc(i,k,1)   + ci2 + ci3

      tr2 = cc(i-1,k,1) + tr11 * cr2 + tr12 * cr3
      ti2 = cc(i,k,1)   + tr11 * ci2 + tr12 * ci3
      tr3 = cc(i-1,k,1) + tr12 * cr2 + tr11 * cr3
      ti3 = cc(i,k,1)   + tr12 * ci2 + tr11 * ci3

      tr5 = ti11 * cr5 + ti12 * cr4
      ti5 = ti11 * ci5 + ti12 * ci4
      tr4 = ti12 * cr5 - ti11 * cr4
      ti4 = ti12 * ci5 - ti11 * ci4

      ch(i-1,3,k)  = tr2 + tr5
      ch(ic-1,2,k) = tr2 - tr5
      ch(i,3,k)    = ti2 + ti5
      ch(ic,2,k)   = ti5 - ti2
      ch(i-1,5,k)  = tr3 + tr4
      ch(ic-1,4,k) = tr3 - tr4
      ch(i,5,k)    = ti3 + ti4
      ch(ic,4,k)   = ti4 - ti3

    end do
  end do

  return
end
subroutine radfg ( ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa )
!
!*******************************************************************************
!
!! RADFG is a lower level routine used by RFFTF1.
!
!
!  Modified:
!
!    09 March 2001
!
!  Author:
!
!    Paul Swarztrauber,
!    National Center for Atmospheric Research
!
!  Parameters:
!
  integer idl1
  integer ido
  integer ip
  integer l1
!
  real ai1
  real ai2
  real ar1
  real ar1h
  real ar2
  real ar2h
  real arg
  real c1(ido,l1,ip)
  real c2(idl1,ip)
  real cc(ido,ip,l1)
  real ch(ido,l1,ip)
  real ch2(idl1,ip)
  real dc2
  real dcp
  real ds2
  real dsp
  integer i
  integer ic
  integer idij
  integer ik
  integer ipph
  integer is
  integer j
  integer j2
  integer jc
  integer k
  integer l
  integer lc
  integer nbd
  real r_pi
  real wa(*)
!
  arg = 2.0E+00 * r_pi() / real ( ip )
  dcp = cos ( arg )
  dsp = sin ( arg )
  ipph = ( ip + 1 ) / 2
  nbd = ( ido - 1 ) / 2

  if ( ido == 1 ) then

    c2(1:idl1,1) = ch2(1:idl1,1)

  else

    ch2(1:idl1,1) = c2(1:idl1,1)
    ch(1,1:l1,2:ip) = c1(1,1:l1,2:ip)

    if ( nbd <= l1 ) then

      is = -ido
      do j = 2, ip
        is = is + ido
        idij = is
        do i = 3, ido, 2
          idij = idij + 2
          do k = 1, l1
            ch(i-1,k,j) = wa(idij-1) * c1(i-1,k,j) + wa(idij) * c1(i,k,j)
            ch(i,k,j)   = wa(idij-1) * c1(i,k,j)   - wa(idij) * c1(i-1,k,j)
          end do
        end do
      end do

    else

      is = -ido

      do j = 2, ip
        is = is + ido
        do k = 1, l1
          idij = is
          do i = 3, ido, 2
            idij = idij + 2
            ch(i-1,k,j) = wa(idij-1) * c1(i-1,k,j) + wa(idij) * c1(i,k,j)
            ch(i,k,j)   = wa(idij-1) * c1(i,k,j)   - wa(idij) * c1(i-1,k,j)
          end do
        end do
      end do

    end if

    if ( nbd >= l1 ) then

      do j = 2, ipph
        jc = ip + 2 - j
        do k = 1, l1
          do i = 3, ido, 2
            c1(i-1,k,j)  = ch(i-1,k,j)  + ch(i-1,k,jc)
            c1(i-1,k,jc) = ch(i,k,j)    - ch(i,k,jc)
            c1(i,k,j)    = ch(i,k,j)    + ch(i,k,jc)
            c1(i,k,jc)   = ch(i-1,k,jc) - ch(i-1,k,j)
          end do
        end do
      end do

    else

      do j = 2, ipph
        jc = ip + 2 - j
        do i = 3, ido, 2
          c1(i-1,1:l1,j)  = ch(i-1,1:l1,j)  + ch(i-1,1:l1,jc)
          c1(i-1,1:l1,jc) = ch(i,1:l1,j)    - ch(i,1:l1,jc)
          c1(i,1:l1,j)    = ch(i,1:l1,j)    + ch(i,1:l1,jc)
          c1(i,1:l1,jc)   = ch(i-1,1:l1,jc) - ch(i-1,1:l1,j)
        end do
      end do

    end if

  end if

  do j = 2, ipph
    jc = ip + 2 - j
    c1(1,1:l1,j)  = ch(1,1:l1,j)  + ch(1,1:l1,jc)
    c1(1,1:l1,jc) = ch(1,1:l1,jc) - ch(1,1:l1,j)
  end do

  ar1 = 1.0E+00
  ai1 = 0.0E+00

  do l = 2, ipph

    lc = ip + 2 - l
    ar1h = dcp * ar1 - dsp * ai1
    ai1 =  dcp * ai1 + dsp * ar1
    ar1 = ar1h

    do ik = 1, idl1
      ch2(ik,l) = c2(ik,1) + ar1 * c2(ik,2)
      ch2(ik,lc) =           ai1 * c2(ik,ip)
    end do

    dc2 = ar1
    ds2 = ai1
    ar2 = ar1
    ai2 = ai1

    do j = 3, ipph

      jc = ip + 2 - j
      ar2h = dc2 * ar2 - ds2 * ai2
      ai2 =  dc2 * ai2 + ds2 * ar2
      ar2 = ar2h

      do ik = 1, idl1
        ch2(ik,l) =  ch2(ik,l)  + ar2 * c2(ik,j)
        ch2(ik,lc) = ch2(ik,lc) + ai2 * c2(ik,jc)
      end do

    end do

  end do

  do j = 2, ipph
    ch2(1:idl1,1) = ch2(1:idl1,1) + c2(1:idl1,j)
  end do

  cc(1:ido,1,1:l1) = ch(1:ido,1:l1,1)

  do j = 2, ipph
    jc = ip + 2 - j
    j2 = j + j
    cc(ido,j2-2,1:l1) = ch(1,1:l1,j)
    cc(1,j2-1,1:l1)   = ch(1,1:l1,jc)
  end do

  if ( ido == 1 ) then
    return
  end if

  if ( nbd >= l1 ) then

    do j = 2, ipph
      jc = ip + 2 - j
      j2 = j + j
      do k = 1, l1
        do i = 3, ido, 2
          ic = ido + 2 - i
          cc(i-1,j2-1,k)  = ch(i-1,k,j) + ch(i-1,k,jc)
          cc(ic-1,j2-2,k) = ch(i-1,k,j) - ch(i-1,k,jc)
          cc(i,j2-1,k)    = ch(i,k,j)   + ch(i,k,jc)
          cc(ic,j2-2,k)   = ch(i,k,jc)  - ch(i,k,j)
        end do
      end do
    end do

  else

    do j = 2, ipph
      jc = ip + 2 - j
      j2 = j + j
      do i = 3, ido, 2
        ic = ido + 2 - i
        cc(i-1,j2-1,1:l1)  = ch(i-1,1:l1,j) + ch(i-1,1:l1,jc)
        cc(ic-1,j2-2,1:l1) = ch(i-1,1:l1,j) - ch(i-1,1:l1,jc)
        cc(i,j2-1,1:l1)    = ch(i,1:l1,j)   + ch(i,1:l1,jc)
        cc(ic,j2-2,1:l1)   = ch(i,1:l1,jc)  - ch(i,1:l1,j)
      end do
    end do

  end if

  return
end
subroutine radix (ibeta)
!
!*******************************************************************************
!
!! RADIX sets ibeta = the radix of the floating point arithmetic
!
  common /spdata/ d1, d2
!
  one  = real(1)
!
  a = one
   10 a = a + a
  call store2 (a + one, a)
  y = d1 - d2
  if (y == one) go to 10
!
  b = one
   31 b = b + b
  call store2 (a + b, a)
  if (d1 == d2) go to 31
!
  ibeta = int(d1 - d2)
  return
end
subroutine rarc(ia, ib, ar, ac, pr, pc, vr, vc, k1, jj, ll, n, m, &
   np1)
!
!*******************************************************************************
!
!! RARC removes the arc (ia,ib) from a graph.
!
!
! meaning of the output parameters  jj  and  ll ...
!
! jj =  location of the element of  ar  corresponding to the
!       removed arc.
!    =  0  if arc  (ia,ib)  is not in the graph.
!    = -1  if, after the removal of arc  (ia,ib) , the graph
!          would admit no hamiltonian circuit.
! ll =  location of the element of  ac  corresponding to the
!       removed arc (defined only if  jj > 0 ).
!
  integer ar(m), ac(m), pr(np1), pc(np1), vr(n), vc(n)
!
  j1 = pr(ia) + 1
  j2 = pr(ia+1)
  do 20 jj=j1,j2
    if (ar(jj) < 0) go to 20
    if (ar(jj)/=ib) go to 20
    l1 = pc(ib) + 1
    l2 = pc(ib+1)
    do 10 ll=l1,l2
      if (ac(ll)==ia) go to 30
   10   continue
   20 continue
! arc  (ia,ib)  is not in the graph.
  jj = 0
  return
   30 if (vr(ia)==1) go to 40
  if (vc(ib)==1) go to 40
  ar(jj) = k1 - ib
  vr(ia) = vr(ia) - 1
  ac(ll) = k1 - ia
  vc(ib) = vc(ib) - 1
  return
! arc  (ia,ib)  cannot be removed from the graph.
   40 jj = -1
  return
end
subroutine rbnd (n,coef,w,abserr,relerr,klust,ker)
!
!*******************************************************************************
!
!! RBND computes error bounds and cluster counts
!         for approximate zeros of a polynomial with real coefficients.
!         the zeros may have been computed by any appropriate routine.
!         the method used is based on the fact that the value of a
!         polynomial at any point is equal to the leading coefficient
!         times the product of the distances from that point to each
!         of the zeroes.  given the value of the polynomial at an
!         approximate zero, rbnd computes for each approximate zero
!         the radius of a circle about that approximate zero which
!         contains a true zero of the polynomial.  using the known
!         distribution of approximate zeroes, an iterative procedure
!         is used to shrink the radii of the circles.
!
!     description of arguments
!
!         input---
!         n      - degree of the polynomial (number of zeros).
!         coef   - real array of n+1 coefficients of the polynomial
!                  coef(1) + coef(2)*z + ... + coef(n+1)*z**n
!         w      - complex array of n approximate zeros.
!
!         output--
!         abserr - real array of n absolute error bounds.  abserr(i) is
!                  the absolute error bound in the zero (wr(i),wi(i)).
!         relerr - real array of n relative error bounds.  relerr(i) is
!                  the relative error bound in the zero (wr(i),wi(i)).
!         klust  - integer array of cluster counts for zeros.  the true
!                  zero corresponding to i-th approximate zero lies in
!                  a circle of radius abserr(i). klust(i) is the number
!                  of circles including the i-th circle which overlap
!                  the i-th circle.  the cluster count often indicates
!                  the multiplicity of a zero.
!         ker    - an error flag
!                 -normal code
!                  0  means the bounds and counts were computed.
!                 -abnormal codes
!                  1  n (degree) must be >= 1
!                  2  leading coefficient is zero
!
!
!     written by carl b. bailey and modified by william r. gavin
!        sandia laboratories
!        albuquerque, new mexico
!        january 1976
!     modified by a.h. morris (nswc)
!
  complex w(n),z
  integer klust(n)
  real coef(*),abserr(n),relerr(n)
  double precision xr,xi,vr,vi,vt
  logical shrunk
!
  eps = epsilon ( eps )
  if (n < 1) go to 200
  np1 = n + 1
  power = 1.0/real(n)
  p = abs(coef(np1))
  if (p == 0.0) go to 210
  rat = (4.0*eps)*abs(coef(1))/p
!
  do 20 l = 1,n
  xr = dble(real(w(l)))
  xi = dble(aimag(w(l)))
  vr = dble(coef(np1))
  vi = 0.0d+00
     do 10 j = 1,n
     m = np1 - j
     vt = xr*vr - xi*vi + dble(coef(m))
     vi = xr*vi + xi*vr
   10    vr = vt
  b = max ( rat,cpabs(sngl(vr),sngl(vi))/p)
!     save product of distances temporarily
  relerr(l) = b
   20 abserr(l) = b ** power
!
   30 shrunk = .false.
  do 50 j = 1,n
  if (abserr(j) == 0.0) go to 50
  p = 1.0
  m = n
     do 40 k = 1,n
     if (k == j) go to 40
     z = w(j) - w(k)
     dist = cpabs(real(z),aimag(z))
     cert = dist - abserr(k)
     if (cert < abserr(j)) go to 40
        p = p*cert
        m = m - 1
   40    continue
  olderr = abserr(j)
  abserr(j) = relerr(j)/p
  if (m > 1) abserr(j) = abserr(j)**(1.0/real(m))
  if (abserr(j) < olderr*0.99) shrunk = .true.
   50 continue
  if (shrunk) go to 30
!
  do 80 j = 1,n
  klust(j) = 1
  wrad = abserr(j)
  wnrm = cpabs(real(w(j)),aimag(w(j)))
  if (wrad /= 0.0) go to 60
     r = 0.0
     go to 80
   60 if (wnrm /= 0.0) go to 70
     r = -1.0
     go to 80
   70 r = wrad/wnrm
   80 relerr(j) = r
!
  nm1 = n - 1
  do 100 j = 1,nm1
  jp1 = j + 1
     do 90 k = jp1,n
     z = w(j) - w(k)
     dist = cpabs(real(z),aimag(z))
     if (dist > (abserr(j) + abserr(k))) go to 90
        klust(j) = klust(j) + 1
        klust(k) = klust(k) + 1
   90    continue
  100 continue
  ker = 0
  return
!
!             error return
!
  200 ker = 1
  return
  210 ker = 2
  return
end
function rcomp ( a, x )
!
!*******************************************************************************
!
!! RCOMP evaluates exp(-x)*x**a/gamma(a)
!
!     rt2pin = 1/sqrt(2*pi)
!
  real rcomp
  data rt2pin/.398942280401433/
!
  rcomp = 0.0
  if (a >= 20.0) go to 20
  t = a*alog(x) - x
  if (a >= 1.0) go to 10
     rcomp = (a*exp(t))*(1.0 + gam1(a))
     return
   10 rcomp = exp(t)/gamma(a)
  return
!
   20 u = x/a
  if (u == 0.0) return
  t = (1.0/a)**2
  t1 = (((0.75*t - 1.0)*t + 3.5)*t - 105.0)/(a*1260.0)
  t1 = t1 - a*rlog(u)
  rcomp = rt2pin*sqrt(a)*exp(t1)
  return
end
subroutine rcval1 (x, y, errtol, rc, ierr)
!
!*******************************************************************************
!
!! RCVAL1 computes the integral
!
!          rc(x,y) = integral from zero to infinity of
!
!                              -1/2     -1
!                    (1/2)(t+x)    (t+y)  dt,
!
!          where x is nonnegative and y is positive.  the duplication
!          theorem is iterated until the variables are nearly equal,
!          and the function is then expanded in taylor series to fifth
!          order.  logarithmic, inverse circular, and inverse hyper-
!          bolic functions can be expressed in terms of rc.  reference.
!          b. c. carlson, computing elliptic integrals by duplication,
!          numer. math. 33 (1979), 1-16.  coded by b. c. carlson and
!          elaine m. notis, ames laboratory-doe, iowa state university,
!          ames, iowa 50011.  march 1, 1980. modified by a.h. morris
!          (nswc).
!
!
  integer ierr
  real rc,c1,c2,errtol,lamda,lolim
  real mu,s,sn,uplim,x,xn,y,yn
!
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the machine minimum multiplied by 5.
!          uplim is not greater than the machine maximum divided by 5.
!
                  lolim = 5.0 * tiny ( lolim )
                  uplim = 0.2 * huge ( uplim )
!
!          input ...
!
!          x and y are the variables in the integral rc(x,y).
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          16 * errtol ** 6 / (1 - 2 * errtol).
!
!          sample choices   errtol   relative truncation
!                                    error less than
!                           1.e-3    2.e-17
!                           3.e-3    2.e-14
!                           1.e-2    2.e-11
!                           3.e-2    2.e-8
!                           1.e-1    2.e-5
!
!          output ...
!
!          rc is the value of the integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x or y is negative, or y = 0.
!               ierr = 2  x+y is too small.
!               ierr = 3  x or y is too large.
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
  if (x < 0.0 .or. y <= 0.0) go to 100
  if ((x + y) < lolim) go to 110
  if (max ( x,y) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
!
   10 mu = (xn + yn + yn) / 3.0
  sn = (yn + mu) / mu - 2.0
  if (abs(sn) < errtol) go to 20
  lamda = 2.0 * sqrt(xn) * sqrt(yn) + yn
  xn = (xn + lamda) * 0.25
  yn = (yn + lamda) * 0.25
  go to 10
!
   20 c1 = 1.0 / 7.0
  c2 = 9.0 / 22.0
  s = sn * sn * (0.3 + sn * (c1 + sn * (0.375 + sn * c2)))
  rc = (1.0 + s) / sqrt(mu)
  return
!
!                      error return
!
  100 rc = 0.0
  ierr = 1
  return
  110 rc = 0.0
  ierr = 2
  return
  120 rc = 0.0
  ierr = 3
  return
end
subroutine rdval (x, y, z, rd, ierr)
!
!*******************************************************************************
!
!! RDVAL computes the incomplete elliptic integral of the second kind
!
!          rd(x,y,z) = integral from zero to infinity of
!
!                                -1/2     -1/2     -3/2
!                      (3/2)(t+x)    (t+y)    (t+z)    dt,
!
!          where x and y are nonnegative, x + y is positive, and z is
!          positive.  if x or y is zero, the integral is complete.
!          the duplication theorem is iterated until the variables are
!          nearly equal, and the function is then expanded in taylor
!          series to fifth order.  reference. b. c. carlson, computing
!          elliptic integrals by duplication, numer. math. 33 (1979),
!          1-16.  coded by b. c. carlson and elaine m. notis, ames
!          laboratory-doe, iowa state university, ames, iowa 50011.
!          march 1, 1980. modified by a.h. morris (nswc).
!
  integer ierr
  real rd,c1,c2,c3,c4,ea,eb,ec,ed,ef,epslon,errtol,lamda
  real lolim,mu,power4,sigma,s1,s2,uplim,x,xn,xndev
  real xnroot,y,yn,yndev,ynroot,z,zn,zndev,znroot
!
!
!          input ...
!
!          x, y, and z are the variables in the integral rd(x,y,z).
!
!          output ...
!
!          rd is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, or z is negative.
!               ierr = 2  x+y or z is too small.
!               ierr = 3  x, y, or z is too large.
!
!
!          machine dependent parameters ...
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          3 * errtol ** 6 / (1 - errtol) ** 3/2.
!
          errtol = (.28 * epsilon ( errtol ) ) ** (1.0/6.0)
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than 2 / (machine maximum) ** (2/3).
!          uplim is not greater than (0.1 * errtol / machine
!          minimum) ** (2/3).
!
          mu = -2.0/3.0
          lolim = 2.0001 * huge ( lolim ) ** mu
          uplim = (10.0 * tiny ( uplim ) / errtol) ** mu
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (amin1(x,y,z) < 0.0) go to 100
  if (amin1(x+y,z) < lolim) go to 110
  if (max ( x,y,z) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
  sigma = 0.0
  power4 = 1.0
!
   10 mu = (xn + yn + 3.0 * zn) * 0.2
  xndev = (mu - xn) / mu
  yndev = (mu - yn) / mu
  zndev = (mu - zn) / mu
  epslon = max ( abs(xndev),abs(yndev),abs(zndev))
  if (epslon < errtol) go to 20
  xnroot = sqrt(xn)
  ynroot = sqrt(yn)
  znroot = sqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  sigma = sigma + power4 / (znroot * (zn + lamda))
  power4 = power4 * 0.25
  xn = (xn + lamda) * 0.25
  yn = (yn + lamda) * 0.25
  zn = (zn + lamda) * 0.25
  go to 10
!
   20 c1 = 3.0 / 14.0
  c2 = 1.0 / 6.0
  c3 = 9.0 / 22.0
  c4 = 3.0 / 26.0
  ea = xndev * yndev
  eb = zndev * zndev
  ec = ea - eb
  ed = ea - 6.0 * eb
  ef = ed + ec + ec
  s1 = ed * (- c1 + 0.25 * c3 * ed - 1.5 * c4 * zndev * ef)
  s2 = zndev * (c2 * ef + zndev * (- c3 * ec + zndev * c4 * ea))
  rd = 3.0 * sigma + power4 * (1.0 + s1 + s2) / (mu * sqrt(mu))
  return
!
!                        error return
!
  100 rd = 0.0
  ierr = 1
  return
  110 rd = 0.0
  ierr = 2
  return
  120 rd = 0.0
  ierr = 3
  return
end
subroutine realit ( sss, nz, iflag, nn, p, qp, k, qk )
!
!*******************************************************************************
!
!! REALIT: variable-shift h polynomial iteration for a real zero.
!
!     sss   - starting iterate
!     nz    - number of zero found
!     iflag - flag to indicate a pair of zeros near the real
!             axis.
!
  double precision sss, p(nn), qp(nn), k(nn), qk(nn)
  double precision pv, kv, t, s
  real ms, mp, omp, ee
!
  real eta, are, mre
  double precision sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi
  common /global/  sr, si, u, v, a, b, c, d, a1, a2, a3, a6, a7, &
                   e, f, g, h, szr, szi, lzr, lzi, eta, are, mre
!
  n = nn - 1
  nz = 0
  s = sss
  iflag = 0
  j = 0
!
!     evaluate p at s
!
   10 pv = p(1)
  qp(1) = pv
  do 20 i = 2,nn
     pv = pv*s + p(i)
     qp(i) = pv
   20 continue
  mp = dabs(pv)
!
!     compute a rigorous bound on the error in evaluating p
!
  ms = dabs(s)
  ee = (mre/(are+mre))*abs(sngl(qp(1)))
  do 30 i = 2,nn
     ee = ee*ms + abs(sngl(qp(i)))
   30 continue
!
!     iteration has converged sufficiently if the
!     polynomial value is less than 20 times this bound
!
  if (mp > 20.0*((are + mre)*ee - mre*mp)) go to 40
  nz = 1
  szr = s
  szi = 0.d0
  return
   40 j = j + 1
!
!     stop iteration after 10 steps
!
  if (j > 10) return
  if (j < 2) go to 50
  if (dabs(t) > 1.d-3*dabs(s-t) .or. mp <= omp) &
        go to 50
!
!     a cluster of zeros near the real axis has been
!     encountered return with iflag set to initiate a
!     quadratic iteration
!
  iflag = 1
  sss = s
  return
!
!     return if the polynomial value has increased
!     significantly
!
   50 omp = mp
!
!     compute t, the next polynomial, and the new iterate
!
  kv = k(1)
  qk(1) = kv
  do 60 i = 2,n
     kv = kv*s + k(i)
     qk(i) = kv
   60 continue
  if (dabs(kv) <= dabs(k(n))*10.*eta) go to 80
!
!     use the scaled form of the recurrence if the value
!     of k at s is nonzero
!
  t = -pv/kv
  k(1) = qp(1)
  do 70 i = 2,n
     k(i) = t*qk(i-1) + qp(i)
   70 continue
  go to 100
!
!     use unscaled form
!
   80 k(1) = 0.0d0
  do 90 i = 2,n
     k(i) = qk(i-1)
   90 continue
  100 kv = k(1)
  do 110 i = 2,n
     kv = kv*s + k(i)
  110 continue
  t = 0.d0
  if (dabs(kv) > dabs(k(n))*10.*eta) t = -pv/kv
  s = s + t
  go to 10
end
function rexp ( x )
!
!*******************************************************************************
!
!! REXP evaluates exp(x) - 1
!
  real rexp

  data p1/ .914041914819518e-09/, p2/ .238082361044469e-01/, &
       q1/-.499999999085958e+00/, q2/ .107141568980644e+00/, &
       q3/-.119041179760821e-01/, q4/ .595130811860248e-03/
!
  if (abs(x) > 0.15) go to 10
  rexp = x*(((p2*x + p1)*x + 1.0)/((((q4*x + q3)*x + q2)*x &
                   + q1)*x + 1.0))
  return
!
   10 w = exp(x)
  if (x > 0.0) go to 20
     rexp = (w - 0.5) - 0.5
     return
   20 rexp = w*(0.5 + (0.5 - 1.0/w))
  return
end
subroutine rfftb (n,r,wsave)
!
!*******************************************************************************
!
!! RFFTB ???
!
  dimension       r(*)       ,wsave(*)
  if (n == 1) return
  call rfftb1 (n,r,wsave,wsave(n+1),wsave(2*n+1))
  return
end
subroutine rfftb1 (n,c,ch,wa,ifac)
!
!*******************************************************************************
!
!! RFFTB1 ???
!
  real c(*), ch(*), wa(*), ifac(*)
  nf = ifac(2)
  na = 0
  l1 = 1
  iw = 1
  do 116 k1=1,nf
     ip = ifac(k1+2)
     l2 = ip*l1
     ido = n/l2
     idl1 = ido*l1
     if (ip /= 4) go to 103
     ix2 = iw+ido
     ix3 = ix2+ido
     if (na /= 0) go to 101
     call radb4 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
     go to 102
  101    call radb4 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
  102    na = 1-na
     go to 115
  103    if (ip /= 2) go to 106
     if (na /= 0) go to 104
     call radb2 (ido,l1,c,ch,wa(iw))
     go to 105
  104    call radb2 (ido,l1,ch,c,wa(iw))
  105    na = 1-na
     go to 115
  106    if (ip /= 3) go to 109
     ix2 = iw+ido
     if (na /= 0) go to 107
     call radb3 (ido,l1,c,ch,wa(iw),wa(ix2))
     go to 108
  107    call radb3 (ido,l1,ch,c,wa(iw),wa(ix2))
  108    na = 1-na
     go to 115
  109    if (ip /= 5) go to 112
     ix2 = iw+ido
     ix3 = ix2+ido
     ix4 = ix3+ido
     if (na /= 0) go to 110
     call radb5 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
     go to 111
  110    call radb5 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
  111    na = 1-na
     go to 115
  112    if (na /= 0) go to 113
     call radbg (ido,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
     go to 114
  113    call radbg (ido,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
  114    if (ido == 1) na = 1-na
  115    l1 = l2
     iw = iw+(ip-1)*ido
  116 continue
  if (na == 0) return
  do 117 i=1,n
     c(i) = ch(i)
  117 continue
  return
end
subroutine rfftf (n,r,wsave)
!
!*******************************************************************************
!
!! RFFTF ???
!
  dimension       r(*)       ,wsave(*)
  if (n == 1) return
  call rfftf1 (n,r,wsave,wsave(n+1),wsave(2*n+1))
  return
end
subroutine rfftf1 (n,c,ch,wa,ifac)
!
!*******************************************************************************
!
!! RFFTF1 ???
!
  real c(*), ch(*), wa(*), ifac(*)
  nf = ifac(2)
  na = 1
  l2 = n
  iw = n
  do 111 k1=1,nf
     kh = nf-k1
     ip = ifac(kh+3)
     l1 = l2/ip
     ido = n/l2
     idl1 = ido*l1
     iw = iw-(ip-1)*ido
     na = 1-na
     if (ip /= 4) go to 102
     ix2 = iw+ido
     ix3 = ix2+ido
     if (na /= 0) go to 101
     call radf4 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
     go to 110
  101    call radf4 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
     go to 110
  102    if (ip /= 2) go to 104
     if (na /= 0) go to 103
     call radf2 (ido,l1,c,ch,wa(iw))
     go to 110
  103    call radf2 (ido,l1,ch,c,wa(iw))
     go to 110
  104    if (ip /= 3) go to 106
     ix2 = iw+ido
     if (na /= 0) go to 105
     call radf3 (ido,l1,c,ch,wa(iw),wa(ix2))
     go to 110
  105    call radf3 (ido,l1,ch,c,wa(iw),wa(ix2))
     go to 110
  106    if (ip /= 5) go to 108
     ix2 = iw+ido
     ix3 = ix2+ido
     ix4 = ix3+ido
     if (na /= 0) go to 107
     call radf5 (ido,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
     go to 110
  107    call radf5 (ido,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
     go to 110
  108    if (ido == 1) na = 1-na
     if (na /= 0) go to 109
     call radfg (ido,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
     na = 1
     go to 110
  109    call radfg (ido,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
     na = 0
  110    l2 = l1
  111 continue
  if (na == 1) return
  do 112 i=1,n
     c(i) = ch(i)
  112 continue
  return
end
subroutine rffti (n,wsave)
!
!*******************************************************************************
!
!! RFFTI ???
!
  dimension       wsave(*)
  if (n == 1) return
  call rffti1 (n,wsave(n+1),wsave(2*n+1))
  return
end
subroutine rffti1 (n,wa,ifac)
!
!*******************************************************************************
!
!! RFFTI1 ???
!
  real wa(*), ifac(*)
  integer ntryh(4)
  data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/4,2,3,5/
  nl = n
  nf = 0
  j = 0
  101 j = j+1
  if (j-4) 102,102,103
  102 ntry = ntryh(j)
  go to 104
  103 ntry = ntry+2
  104 nq = nl/ntry
  nr = nl-ntry*nq
  if (nr) 101,105,101
  105 nf = nf+1
  ifac(nf+2) = ntry
  nl = nq
  if (ntry /= 2) go to 107
  if (nf == 1) go to 107
  do 106 i=2,nf
     ib = nf-i+2
     ifac(ib+2) = ifac(ib+1)
  106 continue
  ifac(3) = 2
  107 if (nl /= 1) go to 104
  ifac(1) = n
  ifac(2) = nf
  tpi = 6.28318530717959
  argh = tpi/real(n)
  is = 0
  nfm1 = nf-1
  l1 = 1
  if (nfm1 == 0) return
  do 110 k1=1,nfm1
     ip = ifac(k1+2)
     ld = 0
     l2 = l1*ip
     ido = n/l2
     ipm = ip-1
     do 109 j=1,ipm
        ld = ld+l1
        i = is
        argld = real(ld)*argh
        fi = 0.
        do 108 ii=3,ido,2
           i = i+2
           fi = fi+1.
           arg = fi*argld
           wa(i-1) = cos(arg)
           wa(i) = sin(arg)
  108       continue
        is = is+ido
  109    continue
     l1 = l2
  110 continue
  return
end
subroutine rfval (x, y, z, rf, ierr)
!
!*******************************************************************************
!
!! RFVAL computes the incomplete elliptic integral of the first kind
!
!          rf(x,y,z) = integral from zero to infinity of
!
!                                -1/2     -1/2     -1/2
!                      (1/2)(t+x)    (t+y)    (t+z)    dt,
!
!          where x, y, and z are nonnegative and at most one of them
!          is zero.  if one of them is zero, the integral is complete.
!          the duplication theorem is iterated until the variables are
!          nearly equal, and the function is then expanded in taylor
!          series to fifth order.  reference. b. c. carlson, computing
!          elliptic integrals by duplication, numer. math. 33 (1979),
!          1-16.  coded by b. c. carlson and elaine m. notis, ames
!          laboratory-doe, iowa state university, ames, iowa 50011.
!          march 1, 1980. modified by a.h. morris (nswc).
!
!
  integer ierr
  real rf,c1,c2,c3,e2,e3,epslon,errtol,lamda
  real lolim,mu,s,uplim,x,xn,xndev,xnroot
  real y,yn,yndev,ynroot,z,zn,zndev,znroot
!
!
!          input ...
!
!          x, y, and z are the variables in the integral rf(x,y,z).
!
!          output ...
!
!          rf is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, or z is negative.
!               ierr = 2  x+y, x+z, or y+z is too small.
!               ierr = 3  x, y, or z is too large.
!
!
!
!          machine dependent parameters ...
!
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the machine minimum multiplied by 5.
!          uplim is not greater than the machine maximum divided by 5.
!
                  lolim = 5.0 * tiny ( lolim )
                  uplim = 0.2 * huge ( uplim )
!
!          errtol is set to the desired error tolerance.
!          relative error due to truncation is less than
!          errtol ** 6 / (4 * (1 - errtol)).
!
           errtol = (3.6 * epsilon ( errtol ) )**(1.0/6.0)
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (amin1(x,y,z) < 0.0) go to 100
  if (amin1(x+y,x+z,y+z) < lolim) go to 110
  if (max ( x,y,z) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
!
   10 mu = (xn + yn + zn) / 3.0
  xndev = 2.0 - (mu + xn) / mu
  yndev = 2.0 - (mu + yn) / mu
  zndev = 2.0 - (mu + zn) / mu
  epslon = max ( abs(xndev),abs(yndev),abs(zndev))
  if (epslon < errtol) go to 20
  xnroot = sqrt(xn)
  ynroot = sqrt(yn)
  znroot = sqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  xn = (xn + lamda) * 0.25
  yn = (yn + lamda) * 0.25
  zn = (zn + lamda) * 0.25
  go to 10
!
   20 c1 = 1.0 / 24.0
  c2 = 3.0 / 44.0
  c3 = 1.0 / 14.0
  e2 = xndev * yndev - zndev * zndev
  e3 = xndev * yndev * zndev
  s = 1.0 + (c1 * e2 - 0.1 - c2 * e3) * e2 + c3 * e3
  rf = s / sqrt(mu)
  return
!
!                      error return
!
  100 rf = 0.0
  ierr = 1
  return
  110 rf = 0.0
  ierr = 2
  return
  120 rf = 0.0
  ierr = 3
  return
end
subroutine risort ( a, m, n )
!
!*******************************************************************************
!
!! RISORT uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. the same permutations are
!     performed on m that are performed on a. it is assumed that n >= 1.
!
  real a(n)
  integer m(n), t
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 32 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
        t = m(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           m(ll) = m(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31       a(ll) = s
        m(ll) = t
   32    continue
!
   40 i = i - 1
  return
end
subroutine rjval (x, y, z, p, rj, ierr)
!
!*******************************************************************************
!
!! RJVAL computes the incomplete elliptic integral of the third kind
!
!          rj(x,y,z,p) = integral from zero to infinity of
!
!                                  -1/2     -1/2     -1/2     -1
!                        (3/2)(t+x)    (t+y)    (t+z)    (t+p)  dt,
!
!          where x, y, and z are nonnegative, at most one of them is
!          zero, and p is positive.  if x or y or z is zero, the
!          integral is complete.  the duplication theorem is iterated
!          until the variables are nearly equal, and the function is
!          then expanded in taylor series to fifth order.  reference.
!          b. c. carlson, computing elliptic integrals by duplication,
!          numer. math. 33 (1979), 1-16.  coded by b. c. carlson and
!          elaine m. notis, ames laboratory-doe, iowa state university,
!          ames, iowa 50011.  march 1, 1980. modified by a.h. morris
!          (nswc).
!
!
  integer ierr
  real rj,rc,alfa,beta,c1,c2,c3,c4,ea,eb,ec,e2,e3
  real epslon,errtol,etolrc,lamda,lolim,mu,p,pn,pndev
  real power4,sigma,s1,s2,s3,uplim,x,xn,xndev
  real xnroot,y,yn,yndev,ynroot,z,zn,zndev,znroot
!
!
!          input ...
!
!          x, y, z, and p are the variables in the integral rj(x,y,z,p).
!
!          output ...
!
!          rj is the value of the incomplete elliptic integral.
!
!          ierr is the return error code.
!               ierr = 0  for normal completion of the subroutine.
!               ierr = 1  x, y, z, or p is negative.
!               ierr = 2  x+y, x+z, y+z, or p is too small.
!               ierr = 3  x, y, z, or p is too large.
!
!
!          machine dependent parameters ...
!
!          rc is a function computed by the subroutine rcval1.
!          lolim and uplim determine the range of valid arguments.
!          lolim is not less than the cube root of the value
!          of lolim used in the code for rc, and
!          uplim is not greater than 0.3 times the cube root of
!          the value of uplim used in the code for rc.
!
           mu = 1.0/3.0
           lolim = 1.0001 * (5.0 * tiny ( lolim ) )**mu
           uplim = .29999 * (0.2 * huge ( uplim ) )**mu
!
!          errtol is set to the desired error tolerance. the
!          relative error due to truncation of the series for rj
!          is less than 3 * errtol ** 6 / (1 - errtol) ** 3/2.
!          an error tolerance (etolrc) will be passed to the code for
!          rc to make the truncation error for rc less than for rj.
!
           errtol = (.28 * epsilon ( errtol ) )**(1.0/6.0)
!
!
!          warning. changes in the program may improve speed at the
!          expense of robustness.
!
!
  if (amin1(x,y,z,p) < 0.0) go to 100
  if (amin1(x+y,x+z,y+z,p) < lolim) go to 110
  if (max ( x,y,z,p) > uplim) go to 120
!
  ierr = 0
  xn = x
  yn = y
  zn = z
  pn = p
  sigma = 0.0
  power4 = 1.0
  etolrc = 0.5 * errtol
!
   10 mu = (xn + yn + zn + pn + pn) * 0.2
  xndev = (mu - xn) / mu
  yndev = (mu - yn) / mu
  zndev = (mu - zn) / mu
  pndev = (mu - pn) / mu
  epslon = max ( abs(xndev),abs(yndev),abs(zndev),abs(pndev))
  if (epslon < errtol) go to 20
  xnroot = sqrt(xn)
  ynroot = sqrt(yn)
  znroot = sqrt(zn)
  lamda = xnroot * (ynroot + znroot) + ynroot * znroot
  alfa = pn * (xnroot + ynroot + znroot) + xnroot * ynroot * znroot
  alfa = alfa * alfa
  beta = pn * (pn + lamda) * (pn + lamda)
  call rcval1 (alfa, beta, etolrc, rc, ierr)
  if (ierr /= 0) return
  sigma = sigma + power4 * rc
  power4 = power4 * 0.25
  xn = (xn + lamda) * 0.25
  yn = (yn + lamda) * 0.25
  zn = (zn + lamda) * 0.25
  pn = (pn + lamda) * 0.25
  go to 10
!
   20 c1 = 3.0 / 14.0
  c2 = 1.0 / 3.0
  c3 = 3.0 / 22.0
  c4 = 3.0 / 26.0
  ea = xndev * (yndev + zndev) + yndev * zndev
  eb = xndev * yndev * zndev
  ec = pndev * pndev
  e2 = ea - 3.0 * ec
  e3 = eb + 2.0 * pndev * (ea - ec)
  s1 = 1.0 + e2 * (-c1 + 0.75 * c3 * e2 - 1.5 * c4 * e3)
  s2 = eb * (0.5 * c2 + pndev * (- c3 - c3 + pndev * c4))
  s3 = pndev * ea * (c2 - pndev * c3) - c2 * pndev * ec
  rj = 3.0 * sigma + power4 * (s1 + s2 + s3) / (mu * sqrt(mu))
  return
!
!                        error return
!
  100 rj = 0.0
  ierr = 1
  return
  110 rj = 0.0
  ierr = 2
  return
  120 rj = 0.0
  ierr = 3
  return
end
subroutine rk ( n, t, h, a, f ) 
!
!*******************************************************************************
!
!! RK: fourth order runge-kutta procedure for solving dy=f(t,y)
!
  dimension a(*)
  external f
  np1=n+1
  if (h==0.0) go to 50
!
  ha=.5*h
  ta=t+ha
  m=n+n
  m1=m+1
!
  do 10 k=1,n
  nk=n+k
  mk=m+k
  a(nk)=ha*a(nk)
   10 a(mk)=a(k)+a(nk)
  call f(ta,a(m1))
!
  do 20 k=1,n
  nk=n+k
  mk=m+k
  a(nk)=a(nk)+h*a(mk)
   20 a(mk)=a(k)+ha*a(mk)
  call f(ta,a(m1))
!
  t=t+h
  do 30 k=1,n
  nk=n+k
  mk=m+k
  a(mk)=h*a(mk)
  a(nk)=a(nk)+a(mk)
   30 a(mk)=a(k)+a(mk)
  call f(t,a(m1))
!
  do 40 k=1,n
  nk=n+k
  mk=m+k
  a(k)=a(k)+(a(nk)+ha*a(mk))/3.0
   40 a(nk)=a(k)
  call f(t,a(np1))
  return
!
   50 do 51 k=1,n
  nk=n+k
   51 a(nk)=a(k)
  call f(t,a(np1))
  return
end
subroutine rk8 ( n, t, h, y, dy, w, f )
!
!*******************************************************************************
!
!! RK8: eighth order runge-kutta procedure for solving dy=f(t,y)
!
  real y(n),dy(n),w(*)
  real a(7),b(8,7),c(7),d(9)
  external f
!
  data a(1)/.3333333333333333/,  a(2)/.5/,  a(3)/.6666666666666666/, &
       a(4)/.1666666666666666/,  a(5)/1./,  a(6)/.8333333333333333/, &
       a(7)/1./
  data b(1,1)/1./,  b(2,1)/3./
  data b(1,2)/1./,  b(2,2)/0./,  b(3,2)/3./
  data b(1,3)/13./,  b(2,3)/-27./,  b(3,3)/42./,  b(4,3)/8./
  data b(1,4)/389./,  b(2,4)/-54./,  b(3,4)/966./,  b(4,4)/-824./, &
       b(5,4)/243./
  data b(1,5)/-231./,  b(2,5)/81./,  b(3,5)/-1164./,  b(4,5)/656./, &
       b(5,5)/-122./,  b(6,5)/800./
  data b(1,6)/-127./,  b(2,6)/18./,  b(3,6)/-678./,  b(4,6)/456./, &
       b(5,6)/-9./,  b(6,6)/576./,  b(7,6)/4./
  data b(1,7)/1481./,  b(2,7)/-81./,  b(3,7)/7104./, &
       b(4,7)/-3376./,  b(5,7)/72./,  b(6,7)/-5040./, &
       b(7,7)/-60./,  b(8,7)/720./
  data c(1)/12./,  c(2)/8./,  c(3)/54./,  c(4)/4320./,  c(5)/20./, &
       c(6)/288./,  c(7)/820./
  data d(1)/41./,  d(2)/0./,  d(3)/27./,  d(4)/272./,  d(5)/27./, &
       d(6)/216./,  d(7)/0./,  d(8)/216./,  d(9)/41./
!
  if (h==0.) go to 40
  ha=h*4./27.
  do 10 k=1,n
   10 w(k)=y(k)+ha*dy(k)
  call f(t+ha,w(1))
  do 11 k=1,n
   11 w(k)=y(k)+h*(dy(k)/18.+w(k)/6.)
  call f(t+h*2./9.,w(1))
!
  i=1
  do 22 m=2,8
  i=i+n
  m1=m-1
  do 21 k=1,n
  sum=b(1,m1)*dy(k)
  l=k
  do 20 j=2,m
  sum=sum+b(j,m1)*w(l)
   20 l=l+n
   21 w(l)=y(k)+sum*h/c(m1)
   22 call f(t+a(m1)*h,w(i))
!
  do 31 k=1,n
  sum=d(1)*dy(k)
  l=k
  do 30 m=2,9
  sum=sum+d(m)*w(l)
   30 l=l+n
  y(k)=y(k)+h*sum/840.
   31 dy(k)=y(k)
  t=t+h
  call f(t,dy)
  return
!
   40 do 41 k=1,n
   41 dy(k)=y(k)
  call f(t,dy)
  return
end
subroutine rkf45 ( f, neqn, y, t, tout, relerr, abserr, iflag, work, iwork )
!
!*******************************************************************************
!
!! RKF45: fehlberg fourth-fifth order runge-kutta method
!
!
!  Author:
!
!    h.a.watts and l.f.shampine
!    sandia laboratories
!    albuquerque,new mexico
!
!    rkf45 is primarily designed to solve non-stiff and mildly stiff
!    differential equations when derivative evaluations are inexpensive.
!    rkf45 should generally not be used when the user is demanding
!    high accuracy.
!
! abstract
!
!    subroutine  rkf45  integrates a system of neqn first order
!    ordinary differential equations of the form
!             dy(i)/dt = f(t,y(1),y(2),...,y(neqn))
!              where the y(i) are given at t .
!    typically the subroutine is used to integrate from t to tout but it
!    can be used as a one-step integrator to advance the solution a
!    single step in the direction of tout.  on return the parameters in
!    the call list are set for continuing the integration. the user has
!    only to call rkf45 again (and perhaps define a new value for tout).
!    actually, rkf45 is an interfacing routine which calls subroutine
!    rkfs for the solution.  rkfs in turn calls subroutine  fehl which
!    computes an approximate solution over one step.
!
!    rkf45  uses the runge-kutta-fehlberg (4,5)  method described
!    in the reference
!    e.fehlberg , low-order classical runge-kutta formulas with stepsize
!                 control , nasa tr r-315
!
!    the performance of rkf45 is illustrated in the reference
!    l.f.shampine,h.a.watts,s.davenport, solving non-stiff ordinary
!                 differential equations-the state of the art ,
!                 sandia laboratories report sand75-0182 ,
!                 to appear in siam review.
!
!
!    the parameters represent-
!      f -- subroutine f(t,y,yp) to evaluate derivatives yp(i)=dy(i)/dt
!      neqn -- number of equations to be integrated
!      y(*) -- solution vector at t
!      t -- independent variable
!      tout -- output point at which solution is desired
!      relerr,abserr -- relative and absolute error tolerances for local
!            error test. at each step the code requires that
!                 abs(local error) <= relerr*abs(y) + abserr
!            for each component of the local error and solution vectors
!      iflag -- indicator for status of integration
!      work(*) -- array to hold information internal to rkf45 which is
!            necessary for subsequent calls. must be dimensioned
!            at least  3+6*neqn
!      iwork(*) -- integer array used to hold information internal to
!            rkf45 which is necessary for subsequent calls. must be
!            dimensioned at least  5
!
!
!  first call to rkf45
!
!    the user must provide storage in his calling program for the arrays
!    in the call list  -      y(neqn) , work(3+6*neqn) , iwork(5)  ,
!    declare f in an external statement, supply subroutine f(t,y,yp) and
!    initialize the following parameters-
!
!      neqn -- number of equations to be integrated.  (neqn >= 1)
!      y(*) -- vector of initial conditions
!      t -- starting point of integration , must be a variable
!      tout -- output point at which solution is desired.
!            t=tout is allowed on the first call only, in which case
!            rkf45 returns with iflag=2 if continuation is possible.
!      relerr,abserr -- relative and absolute local error tolerances
!            which must be non-negative. relerr must be a variable while
!            abserr may be a constant. the code should normally not be
!            used with relative error control smaller than about 1.e-8 .
!            to avoid limiting precision difficulties the code requires
!            relerr to be larger than an internally computed relative
!            error parameter which is machine dependent. in particular,
!            pure absolute error is not permitted. if a smaller than
!            allowable value of relerr is attempted, rkf45 increases
!            relerr appropriately and returns control to the user before
!            continuing the integration.
!      iflag -- +1,-1  indicator to initialize the code for each new
!            problem. normal input is +1. the user should set iflag=-1
!            only when one-step integrator control is essential. in this
!            case, rkf45 attempts to advance the solution a single step
!            in the direction of tout each time it is called. since this
!            mode of operation results in extra computing overhead, it
!            should be avoided unless needed.
!
!
!  output from rkf45
!
!      y(*) -- solution at t
!      t -- last point reached in integration.
!      iflag = 2 -- integration reached tout. indicates successful retur
!                   and is the normal mode for continuing integration.
!            =-2 -- a single successful step in the direction of tout
!                   has been taken. normal mode for continuing
!                   integration one step at a time.
!            = 3 -- integration was not completed because relative error
!                   tolerance was too small. relerr has been increased
!                   appropriately for continuing.
!            = 4 -- integration was not completed because more than
!                   3000 derivative evaluations were needed. this
!                   is approximately 500 steps.
!            = 5 -- integration was not completed because solution
!                   vanished making a pure relative error test
!                   impossible. must use non-zero abserr to continue.
!                   using the one-step integration mode for one step
!                   is a good way to proceed.
!            = 6 -- integration was not completed because requested
!                   accuracy could not be achieved using smallest
!                   allowable stepsize. user must increase the error
!                   tolerance before continued integration can be
!                   attempted.
!            = 7 -- it is likely that rkf45 is inefficient for solving
!                   this problem. too much output is restricting the
!                   natural stepsize choice. use the one-step integrator
!                   mode.
!            = 8 -- invalid input parameters
!                   this indicator occurs if any of the following is
!                   satisfied -   neqn <= 0
!                                 t=tout  and  iflag /= +1 or -1
!                                 relerr or abserr < 0.
!                                 iflag == 0  or  < -2  or  > 8
!      work(*),iwork(*) -- information which is usually of no interest
!                   to the user but necessary for subsequent calls.
!                   work(1),...,work(neqn) contain the first derivatives
!                   of the solution vector y at t. work(neqn+1) contains
!                   the stepsize h to be attempted on the next step.
!                   iwork(1) contains the derivative evaluation counter.
!
!
!  subsequent calls to rkf45
!
!    subroutine rkf45 returns with all information needed to continue
!    the integration. if the integration reached tout, the user need onl
!    define a new tout and call rkf45 again. in the one-step integrator
!    mode (iflag=-2) the user must keep in mind that each step taken is
!    in the direction of the current tout. upon reaching tout (indicated
!    by changing iflag to 2),the user must then define a new tout and
!    reset iflag to -2 to continue in the one-step integrator mode.
!
!    if the integration was not completed but the user still wants to
!    continue (iflag=3,4 cases), he just calls rkf45 again. with iflag=3
!    the relerr parameter has been adjusted appropriately for continuing
!    the integration. in the case of iflag=4 the function counter will
!    be reset to 0 and another 3000 function evaluations are allowed.
!
!    however,in the case iflag=5, the user must first alter the error
!    criterion to use a positive value of abserr before integration can
!    proceed. if he does not,execution is terminated.
!
!    also,in the case iflag=6, it is necessary for the user to reset
!    iflag to 2 (or -2 when the one-step integration mode is being used)
!    as well as increasing either abserr,relerr or both before the
!    integration can be continued. if this is not done, execution will
!    be terminated. the occurrence of iflag=6 indicates a trouble spot
!    (solution is changing rapidly,singularity may be present) and it
!    often is inadvisable to continue.
!
!    if iflag=7 is encountered, the user should use the one-step
!    integration mode with the stepsize determined by the code or
!    consider switching to the adams codes de/step,intrp. if the user
!    insists upon continuing the integration with rkf45, he must reset
!    iflag to 2 before calling rkf45 again. otherwise,execution will be
!    terminated.
!
!    if iflag=8 is obtained, integration can not be continued unless
!    the invalid input parameters are corrected.
!
!    it should be noted that the arrays work,iwork contain information
!    required for subsequent integration. accordingly, work and iwork
!    should not be altered.
!
!
  integer neqn,iflag,iwork(5)
  real y(neqn),t,tout,relerr,abserr,work(*)
!
  external f
!
  integer k1,k2,k3,k4,k5,k6,k1m
!
!
!     compute indices for the splitting of the work array
!
  k1m=neqn+1
  k1=k1m+1
  k2=k1+neqn
  k3=k2+neqn
  k4=k3+neqn
  k5=k4+neqn
  k6=k5+neqn
!
!     this interfacing routine merely relieves the user of a long
!     calling list via the splitting apart of two working storage
!     arrays. if this is not compatible with the users compiler,
!     he must use rkfs directly.
!
  call rkfs(f,neqn,y,t,tout,relerr,abserr,iflag,work(1),work(k1m), &
            work(k1),work(k2),work(k3),work(k4),work(k5),work(k6), &
            work(k6+1),iwork(1),iwork(2),iwork(3),iwork(4),iwork(5))
!
  return
end
subroutine rkfs(f,neqn,y,t,tout,relerr,abserr,iflag,yp,h,f1,f2,f3, &
                  f4,f5,savre,savae,nfe,kop,init,jflag,kflag)
!
!*******************************************************************************
!
!! RKFS: fehlberg fourth-fifth order runge-kutta method
!
!
!     rkfs integrates a system of first order ordinary differential
!     equations as described in the comments for rkf45 .
!     the arrays yp,f1,f2,f3,f4,and f5 (of dimension at least neqn) and
!     the variables h,savre,savae,nfe,kop,init,jflag,and kflag are used
!     internally by the code and appear in the call list to eliminate
!     local retention of variables between calls. accordingly, they
!     should not be altered. items of possible interest are
!         yp - derivative of solution vector at t
!         h  - an appropriate stepsize to be used for the next step
!         nfe- counter on the number of derivative function evaluations
!
!
  logical hfaild,output
!
  integer  neqn,iflag,nfe,kop,init,jflag,kflag
  real  y(neqn),t,tout,relerr,abserr,h,yp(neqn), &
    f1(neqn),f2(neqn),f3(neqn),f4(neqn),f5(neqn),savre, &
    savae
!
  external f
!
  real  a,ae,dt,ee,eeoet,esttol,et,hmin,remin,rer,s, &
    scale,tol,toln,u26,eps,ypk
!
  integer  k,maxnfe,mflag
!
!
!     remin is the minimum acceptable value of relerr.  attempts
!     to obtain higher accuracy with this subroutine are usually
!     very expensive and often unsuccessful.
!
  data remin/1.e-12/
!
!
!     the expense is controlled by restricting the number
!     of function evaluations to be approximately maxnfe.
!     as set, this corresponds to about 500 steps.
!
  data maxnfe/3000/
!
!
!     check input parameters
!
!
  if (neqn < 1) go to 10
  if ((relerr < 0.0)  .or.  (abserr  <  0.0)) go to 10
  mflag=iabs(iflag)
  if (mflag == 0) go to 10
  if (mflag > 8) go to 10
!
!     compute the relative machine precision
!
  eps = epsilon ( eps )
  u26 = 26.0*eps
  if (mflag /= 1) go to 20
  go to 50
!
!     invalid input
   10 iflag=8
  return
!
!     check continuation possibilities
!
   20 if ((t == tout) .and. (kflag /= 3)) go to 10
  if (mflag /= 2) go to 25
!
!     iflag = +2 or -2
  if (kflag == 3) go to 45
  if (init == 0) go to 45
  if (kflag == 4) go to 40
  if ((kflag == 5)  .and.  (abserr == 0.0)) go to 30
  if ((kflag == 6)  .and.  (relerr <= savre)  .and. &
      (abserr <= savae)) go to 30
  go to 50
!
!     iflag = 3,4,5,6,7 or 8
   25 if (iflag == 3) go to 45
  if (iflag == 4) go to 40
  if ((iflag == 5) .and. (abserr > 0.0)) go to 45
!
!     integration cannot be continued since user did not respond to
!     the instructions pertaining to iflag=5,6,7 or 8
   30 stop
!
!     reset function evaluation counter
   40 nfe=0
  if (mflag == 2) go to 50
!
!     reset flag value from previous call
   45 iflag=jflag
  if (kflag == 3) mflag=iabs(iflag)
!
!     save input iflag and set continuation flag value for subsequent
!     input checking
   50 jflag=iflag
  kflag=0
!
!     save relerr and abserr for checking input on subsequent calls
  savre=relerr
  savae=abserr
!
!     restrict relative error tolerance to be at least as large as
!     2*eps+remin to avoid limiting precision difficulties arising
!     from impossible accuracy requests
!
  rer=2.0*eps+remin
  if (relerr >= rer) go to 55
!
!     relative error tolerance too small
  relerr=rer
  iflag=3
  kflag=3
  return
!
   55 dt=tout-t
!
  if (mflag == 1) go to 60
  if (init == 0) go to 65
  go to 80
!
!     initialization --
!                       set initialization completion indicator,init
!                       set indicator for too many output points,kop
!                       evaluate initial derivatives
!                       set counter for function evaluations,nfe
!                       estimate starting stepsize
!
   60 init=0
  kop=0
!
  a=t
  call f(a,y,yp)
  nfe=1
  if (t /= tout) go to 65
  iflag=2
  return
!
!
   65 init=1
  h=abs(dt)
  toln=0.
  do 70 k=1,neqn
    tol=relerr*abs(y(k))+abserr
    if (tol <= 0.) go to 70
    toln=tol
    ypk=abs(yp(k))
    if (ypk*h**5 > tol) h=(tol/ypk)**0.2
   70 continue
  if (toln <= 0.0) h=0.0
  h=max ( h,u26*amax1(abs(t),abs(dt)))
  jflag=isign(2,iflag)
!
!
!     set stepsize for integration in the direction from t to tout
!
   80 h=sign(h,dt)
!
!     test to see if rkf45 is being severely impacted by too many
!     output points
!
  if (abs(h) >= 2.0*abs(dt)) kop=kop+1
  if (kop /= 100) go to 85
!
!     unnecessary frequency of output
  kop=0
  iflag=7
  return
!
   85 if (abs(dt) > u26*abs(t)) go to 95
!
!     if too close to output point,extrapolate and return
!
  do 90 k=1,neqn
   90   y(k)=y(k)+dt*yp(k)
  a=tout
  call f(a,y,yp)
  nfe=nfe+1
  go to 300
!
!
!     initialize output point indicator
!
   95 output= .false.
!
!     to avoid premature underflow in the error tolerance function,
!     scale the error tolerances
!
  scale=2.0/relerr
  ae=scale*abserr
!
!
!     step by step integration
!
  100 hfaild= .false.
!
!     set smallest allowable stepsize
!
  hmin=u26*abs(t)
!
!     adjust stepsize if necessary to hit the output point.
!     look ahead two steps to avoid drastic changes in the stepsize and
!     thus lessen the impact of output points on the code.
!
  dt=tout-t
  if (abs(dt) >= 2.0*abs(h)) go to 200
  if (abs(dt) > abs(h)) go to 150
!
!     the next successful step will complete the integration to the
!     output point
!
  output= .true.
  h=dt
  go to 200
!
  150 h=0.5*dt
!
!
!
!     core integrator for taking a single step
!
!     the tolerances have been scaled to avoid premature underflow in
!     computing the error tolerance function et.
!     to avoid problems with zero crossings,relative error is measured
!     using the average of the magnitudes of the solution at the
!     beginning and end of a step.
!     the error estimate formula has been grouped to control loss of
!     significance.
!     to distinguish the various arguments, h is not permitted
!     to become smaller than 26 units of roundoff in t.
!     practical limits on the change in the stepsize are enforced to
!     smooth the stepsize selection process and to avoid excessive
!     chattering on problems having discontinuities.
!     to prevent unnecessary failures, the code uses 9/10 the stepsize
!     it estimates will succeed.
!     after a step failure, the stepsize is not allowed to increase for
!     the next attempted step. this makes the code more efficient on
!     problems having discontinuities and more effective in general
!     since local extrapolation is being used and extra caution seems
!     warranted.
!
!
!     test number of derivative function evaluations.
!     if okay,try to advance the integration from t to t+h
!
  200 if (nfe <= maxnfe) go to 220
!
!     too much work
  iflag=4
  kflag=4
  return
!
!     advance an approximate solution over one step of length h
!
  220 call fehl(f,neqn,y,t,h,yp,f1,f2,f3,f4,f5,f1)
  nfe=nfe+5
!
!     compute and test allowable tolerances versus local error estimates
!     and remove scaling of tolerances. note that relative error is
!     measured with respect to the average of the magnitudes of the
!     solution at the beginning and end of the step.
!
  eeoet=0.0
  do 250 k=1,neqn
    et=abs(y(k))+abs(f1(k))+ae
    if (et > 0.0) go to 240
!
!       inappropriate error tolerance
    iflag=5
    return
!
  240   ee=abs((-2090.0*yp(k)+(21970.0*f3(k)-15048.0*f4(k)))+ &
                          (22528.0*f2(k)-27360.0*f5(k)))
  250   eeoet=max ( eeoet,ee/et)
!
  esttol=abs(h)*eeoet*scale/752400.0
!
  if (esttol <= 1.0) go to 260
!
!
!     unsuccessful step
!                       reduce the stepsize , try again
!                       the decrease is limited to a factor of 1/10
!
  hfaild= .true.
  output= .false.
  s=0.1
  if (esttol < 59049.0) s=0.9/esttol**0.2
  h=s*h
  if (abs(h) > hmin) go to 200
!
!     requested error unattainable at smallest allowable stepsize
  iflag=6
  kflag=6
  return
!
!
!     successful step
!                        store solution at t+h
!                        and evaluate derivatives there
!
  260 t=t+h
  do 270 k=1,neqn
  270   y(k)=f1(k)
  a=t
  call f(a,y,yp)
  nfe=nfe+1
!
!
!                       choose next stepsize
!                       the increase is limited to a factor of 5
!                       if step failure has just occurred, next
!                          stepsize is not allowed to increase
!
  s=5.0
  if (esttol > 1.889568e-4) s=0.9/esttol**0.2
  if (hfaild) s=amin1(s,1.0)
  h=sign(max ( s*abs(h),hmin),h)
!
!     end of core integrator
!
!
!     should we take another step
!
  if (output) go to 300
  if (iflag > 0) go to 100
!
!
!     integration successfully completed
!
!     one-step mode
  iflag=-2
  return
!
!     interval mode
  300 t=tout
  iflag=2
  return
!
end
  logical function rloc (x, y)
!
!*******************************************************************************
!
!! RLOC determines if two real arrays begin at the same location.
!
!
!     x and y are arrays. it is assumed that x(1) and y(1) contain data.
!
!     rloc(x,y) = .true.   if x and y begin in the same location
!     rloc(x,y) = .false.  if x and y begin in different locations
!
!     it is recommended that this coding not be optimized by eliminating
!     the subroutine ychg. if it is optimized then rloc may not compile
!     properly.
!
  real x(*), y(*)
!
  xold = x(1)
  yold = y(1)
  call ychg(x,y,yold)
  if (x(1) == xold) go to 10
!
!     x and y begin in the same location
!
  y(1) = yold
  rloc = .true.
  return
!
!     x and y begin in different locations
!
   10 y(1) = yold
  rloc = .false.
  return
end
function rlog(x)
!
!*******************************************************************************
!
!! RLOG: evaluation of the function x - 1 - ln(x)
!
  real rlog
!
  data a/.566749439387324e-01/
  data b/.456512608815524e-01/
!
  data p0/ .333333333333333e+00/, p1/-.224696413112536e+00/, &
       p2/ .620886815375787e-02/
  data q1/-.127408923933623e+01/, q2/ .354508718369557e+00/
!
  if (x < 0.61 .or. x > 1.57) go to 100
  if (x < 0.82) go to 10
  if (x > 1.18) go to 20
!
!              argument reduction
!
  u = (x - 0.5) - 0.5
  w1 = 0.0
  go to 30
!
   10 u = dble(x) - 0.7d0
  u = u/0.7
  w1 = a - u*0.3
  go to 30
!
   20 u = 0.75d0*dble(x) - 1.d0
  w1 = b + u/3.0
!
!               series expansion
!
   30 r = u/(u + 2.0)
  t = r*r
  w = ((p2*t + p1)*t + p0)/((q2*t + q1)*t + 1.0)
  rlog = 2.0*t*(1.0/(1.0 - r) - r*w) + w1
  return
!
!
  100 r = (x - 0.5) - 0.5
  rlog = r - alog(x)
  return
end
function rlog1(x)
!
!*******************************************************************************
!
!! RLOG1: evaluation of the function x - ln(1 + x)
!
  real rlog1
  data a/.566749439387324e-01/
  data b/.456512608815524e-01/
!
  data p0/ .333333333333333e+00/, p1/-.224696413112536e+00/, &
       p2/ .620886815375787e-02/
  data q1/-.127408923933623e+01/, q2/ .354508718369557e+00/
!
  if (x < -0.39 .or. x > 0.57) go to 100
  if (x < -0.18) go to 10
  if (x >  0.18) go to 20
!
!              argument reduction
!
  h = x
  w1 = 0.0
  go to 30
!
   10 h = dble(x) + 0.3d0
  h = h/0.7
  w1 = a - h*0.3
  go to 30
!
   20 h = 0.75d0*dble(x) - 0.25d0
  w1 = b + h/3.0
!
!               series expansion
!
   30 r = h/(h + 2.0)
  t = r*r
  w = ((p2*t + p1)*t + p0)/((q2*t + q1)*t + 1.0)
  rlog1 = 2.0*t*(1.0/(1.0 - r) - r*w) + w1
  return
!
!
  100 w = (x + 0.5) + 0.5
  rlog1 = x - alog(w)
  return
end
subroutine rmat_print ( lda, m, n, a, title )
!
!*******************************************************************************
!
!! RMAT_PRINT prints a real matrix.
!
!
!  Modified:
!
!    24 March 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer LDA, the leading dimension of A.
!
!    Input, integer M, the number of rows in A.
!
!    Input, integer N, the number of columns in A.
!
!    Input, real A(LDA,N), the matrix to be printed.
!
!    Input, character ( len = * ) TITLE, a title to be printed first.
!    TITLE may be blank.
!
  integer lda
  integer n
!
  real a(lda,n)
  integer i
  integer j
  integer jhi
  integer jlo
  integer m
  character ( len = * ) title
!
  if ( title /= ' ' ) then
    write ( *, * ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  do jlo = 1, n, 5
    jhi = min ( jlo + 4, n )
    write ( *, * ) ' '
    write ( *, '(6x,5(i7,7x))' ) ( j, j = jlo, jhi )
    write ( *, * ) ' '
    do i = 1, m
      write ( *, '(i6,5g14.6)' ) i, a(i,jlo:jhi)
    end do
  end do

  return
end
function rmin ( n, m, cond, unitrd, averr )
!
!*******************************************************************************
!
!! RMIN computes the minimum relative error for an integral equation.
!
!
!   for a linear system   (i-kmm)*xm=rhfcn   of order m, this is the
!   value of relmin used in iegs. the variable unitrd is defined in
!   iegaus, and the variables cond and averr are defined in iegs
!   using conew.
!   it is unlikely that a solution x can be found for the original
!   integral equation with a smaller relative error than rmin.
!
  float1=m
  float2=real(m)/float(n)
  rmin=max ( (float1**1.5)*cond*unitrd, &
     (float2**1.5)*averr)
  return
end
function rnderr(x, a, y, b)
!
!*******************************************************************************
!
!! RNDERR computes the rounding error committed when the sum x+a is formed.
!
!
!  in the calling program, y must be the same
!       as x and b must be the same as a.  they are declared as
!       distinct variables in this function, and the intermediate
!       variables s and t are put into common, in order to defend
!       against the well-meaning actions of some officious optimizing
!       fortran compilers.
  common /cubatb/ s, t
  s = x + a
  t = s - y
  rnderr = t - b
  return
end
function rnrm(x,y,n,iflag)
!
!*******************************************************************************
!
!! RNRM computes the maximum norm of x or x-y.
!
!
!   iflag=0    calculate the maximum norm of x.
!   iflag=1    calculate the maximum norm of x-y.
!
  real rnrm
  dimension x(n),y(n)
  if(iflag == 1) go to 2
!   find the norm of x.
  rnrm=0.0
  do 1 i=1,n
1     rnrm=max ( rnrm,abs(x(i)))
  return
!   find the norm of x-y.
2     rnrm=0.0
  do 3 i=1,n
3     rnrm=max ( rnrm,abs(x(i)-y(i)))
  return
end
subroutine rot3 (a, theta)
!
!*******************************************************************************
!
!! ROT3 ???
!
  real a(3,3)
  real theta(3)
!
  data pihalf/1.5707963267949/
!
  if (abs(a(1,1)) > abs(a(2,1))) go to 10
  if (a(2,1) /= 0.0) go to 11
!
!     case when a(1,1) = a(2,1) = 0
!
  theta(3) = 0.0
  theta(2) = sign(pihalf,a(3,1))
  u = a(2,2)
  v = a(1,2)
  if (a(3,1) > 0.0) v = -v
  theta(1) = atan2(v,u)
  return
!
!     computation of r = sqrt(a(1,1)**2 + a(2,1)**2)
!
   10 t = a(2,1)/a(1,1)
  r = abs(a(1,1))*sqrt(1.0 + t*t)
  go to 20
   11 t = a(1,1)/a(2,1)
  r = abs(a(2,1))*sqrt(1.0 + t*t)
!
!     evaluation of the angles
!
   20 theta(3) = atan2(a(2,1),a(1,1))
  theta(2) = atan2(a(3,1),r)
  u = dble(a(1,1))*dble(a(2,2)) - dble(a(1,2))*dble(a(2,1))
  if (abs(theta(2)) > 0.8) go to 21
  u = u/r
  v = a(3,2)/cos(theta(2))
  go to 22
   21 v = dble(a(1,1))*dble(a(1,2)) + dble(a(2,1))*dble(a(2,2))
  v = -v/sin(theta(2))
   22 theta(1) = atan2(v,u)
  return
end
subroutine rota(x1,y1,a,x2,y2)
!
!*******************************************************************************
!
!! ROTA ???
!
  sina=sin(a)
  cosa=cos(a)
  x2= x1*cosa+y1*sina
  y2=-x1*sina+y1*cosa
  return
end
subroutine rpose (a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! RPOSE transposes a sparse real matrix
!
  real a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ipmin = ia(i)
     ipmax = ia(i+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1
  do 41 j = 1,np1
     ib(j) = 1
   41 continue
  return
end
subroutine rpose1 (p, a, ia, ja, b, ib, jb, m, n)
!
!*******************************************************************************
!
!! RPOSE1 transposes a sparse real matrix where the rows are interchanged
!
  integer p(m)
  real a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
!           compute the number of elements in each column
!                 of a and store the results in ib
!
  ipmin = ia(1)
  ipmax = ia(m+1) - 1
  if (ipmin > ipmax) go to 40
  do 10 j = 1,n
     ib(j) = 0
   10 continue
  do 11 ip = ipmin,ipmax
     j = ja(ip)
     ib(j) = ib(j) + 1
   11 continue
!
!          compute the row pointers of the transpose matrix
!                and store them in ib(2),...,ib(n+1)
!
  num = ia(m+1) - ia(1) + 1
  j = n
  do 20 jj = 1,n
     num = num - ib(j)
     ib(j+1) = num
     j = j - 1
   20 continue
!
!                store the i-th row of a in b and jb
!                  and update the pointers in ib
!
  do 31 i = 1,m
     ii = p(i)
     ipmin = ia(ii)
     ipmax = ia(ii+1) - 1
     if (ipmin > ipmax) go to 31
     do 30 ip = ipmin,ipmax
        j = ja(ip)
        jp = ib(j+1)
        jb(jp) = i
        b(jp) = a(ip)
        ib(j+1) = jp + 1
   30    continue
   31 continue
  ib(1) = 1
  return
!
!                    transpose a zero matrix a
!
   40 np1 = n + 1
  do 41 j = 1,np1
     ib(j) = 1
   41 continue
  return
end
subroutine rrsort ( a, b, n )
!
!*******************************************************************************
!
!! RRSORT uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. the same permutations are
!     performed on b that are performed on a. it is assumed that n >= 1.
!
  real a(n), b(n)
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 32 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
        t = b(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           b(ll) = b(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31       a(ll) = s
        b(ll) = t
   32    continue
!
   40 i = i - 1
  return
end
subroutine rsco (rsav, isav)
!
!*******************************************************************************
!
!! RSCO restores from rsav and isav the contents of common block debdf1,
!  which is used internally in the sfode package.
!
  integer isav, i, ils, lenils, lenrls
  real rsav, rls
  dimension rsav(*), isav(*)
  common /debdf1/ rls(218), ils(33)
  data lenrls/218/, lenils/33/
!
  do 10 i = 1,lenrls
 10     rls(i) = rsav(i)
  do 20 i = 1,lenils
 20     ils(i) = isav(i)
  return
end
subroutine rscopy (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! RSCOPY: copying a sparse real matrix
!
  real a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        if (a(ip) == 0.0) go to 10
        b(l) = a(ip)
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
subroutine rslv (m0,n,a,ia,ja,b,r,c,max2,x,iwk,wk,ierr)
!
!*******************************************************************************
!
!! RSLV factors and solves a set of real sparse linear equations.
!
!
!     rslv employs gaussian elimination with column interchanges to
!     solve the nxn linear system ax = b. the argument m0 specifies
!     if rslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to rslv.
!
!
!     input arguments when m0=0 ---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the matrix a stored in sparse form.
!
!     b        array of n entries containing the right hand side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2     integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0 ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        real array of n entries containing the solution.
!              b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas ---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       real array of dimension 2*n + max2.
!
!
!     after an initial call to rslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to rslv
!     and solves the new equations ax = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  real a(*), b(n), x(n), wk(*)
  integer ia(*), ja(*), iwk(*)
  integer r(n), c(n), y, t, p
!
!     set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if (m0 /= 0) go to 20
!
!     compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return
  do 10 k = 1,n
     l = c(k)
     iwk(l) = k
   10 continue
!
!     obtain the lu decomposition of a
!
  call splu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
               iwk(iu),wk(y),iwk(p),ierr)
  if (ierr < 0) return
  ierr = max (1,ierr)
!
!     solve the system of equations
!
   20 call rslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                    b,x,wk(y))
  return
end
subroutine rslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! RSLV1 solves a factored system of sparse linear equations.
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  real b(n), d(n), t(*), x(n), y(n), sum
!
!            solve ly = b by forward substitution
!
  do 11 k = 1,n
     lk = r(k)
     sum = b(lk)
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 11
     do 10 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   10    continue
   11 y(k) = sum/d(k)
!
!            solve ux = b by backward substitution
!             and reorder x to correspond with a
!
  k = n
  do 22 i = 1,n
     sum = y(k)
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        sum = sum - t(jj)*y(j)
   20    continue
   21    y(k) = sum
     lk = c(k)
     x(lk) = y(k)
     k = k - 1
   22 continue
  return
end
subroutine rsort ( a, n )
!
!*******************************************************************************
!
!! RSORT uses the shell sorting procedure to reorder the elements of A.
!
!     so that a(i) <= a(i+1) for i=1,...,n-1. it is assumed that n >= 1.
!
  real a(n)
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31    a(ll) = s
!
   40 i = i - 1
  return
end
subroutine r_swap ( x, y )
!
!*******************************************************************************
!
!! R_SWAP swaps two real values.
!
!
!  Modified:
!
!    01 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  real x
  real y
  real z
!
  z = x
  x = y
  y = z

  return
end
subroutine sadd (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! SADD: addition of sparse real matrices
!
  real a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 j = 1,n
     wk(j) = 0.0
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) + b(l)
        wk(j) = 0.0
        if (t == 0.0) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == 0.0) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = 0.0
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
function samax ( n, x, incx )
!
!*******************************************************************************
!
!! SAMAX returns the maximum absolute value of the entries in a vector.
!
!
!  Modified:
!
!    08 April 1999
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be examined.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Output, real SAMAX, the maximum absolute value of an element of X.
!
  implicit none
!
  integer i
  integer incx
  integer ix
  integer n
  real samax
  real x(*)
!
  if ( n <= 0 ) then

    samax = 0.0E+00

  else if ( n == 1 ) then

    samax = abs ( x(1) )

  else if ( incx == 1 ) then

    samax = abs ( x(1) )

    do i = 2, n
      if ( abs ( x(i) ) > samax ) then
        samax = abs ( x(i) )
      end if
    end do

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    samax = abs ( x(ix) )
    ix = ix + incx

    do i = 2, n
      if ( abs ( x(ix) ) > samax ) then
        samax = abs ( x(ix) )
      end if
      ix = ix + incx
    end do

  end if

  return
end
function sasum ( n, x, incx )
!
!*******************************************************************************
!
!! SASUM sums the absolute values of the entries of a vector.
!
!
!  Modified:
!
!    15 February 2001
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be examined.
!
!    Input, integer INCX, the increment between successive entries of X.
!    INCX must not be negative.
!
!    Output, real SASUM, the sum of the absolute values of X.
!
  integer incx
  integer n
  real sasum
  real x(*)
!
  sasum = sum ( abs ( x(1:1+(n-1)*incx:incx) ) )

  return
end
subroutine saxpy ( n, sa, x, incx, y, incy )
!
!*******************************************************************************
!
!! SAXPY adds a constant times one vector to another.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real SA, the multiplier.
!
!    Input, real X(*), the vector to be scaled and added to Y.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), the vector to which a multiple of X is to
!    be added.
!
!    Input, integer INCY, the increment between successive entries of Y.
!
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real sa
  real x(*)
  real y(*)
!
  if ( n <= 0 ) then

  else if ( sa == 0.0E+00 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    y(1:n) = y(1:n) + sa * x(1:n)

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( incy >= 0 ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      y(iy) = y(iy) + sa * x(ix)
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
function scalcp(nn,pt,eta,infin,smalno,base)
!
!*******************************************************************************
!
!! SCALCP returns a scale factor to multiply the coefficients of the polynomial.
!  the scaling is done to avoid overflow and to avoid
!     undetected underflow interfering with the convergence criterion.
!     the factor is a power of the base.
!
!     pt - modulus of the coefficients of p
!     eta,infin,smalno,base - constants describing the
!            floating point arithmetic.
!
  double precision scalcp
  double precision pt(nn),eta,infin,smalno,base,hi,lo, &
                   max,min,x,sc
!
!     find the largest and smallest moduli of coefficients.
!
  hi = dsqrt(infin)
  lo = smalno/eta
  max = 0.d0
  min = infin
  do 10 i = 1,nn
     x = pt(i)
     if (x > max) max = x
     if (x /= 0.d0 .and. x < min) min = x
   10 continue
!
!     scale only if there are very large or very small coefficients.
!
  scalcp = 1.d0
  sc = lo/min
  if (sc > 1.d0) go to 20
  if (max <= hi) return
  sc = 1.d0/(dsqrt(max)*dsqrt(min))
  go to 30
   20 if (infin/sc < max) return
   30 l = dlog(sc)/dlog(base) + 0.5d0
  scalcp = base**l
  return
end
subroutine scaldn(coord,npts,maxabs)
!
!*******************************************************************************
!
!! SCALDN carries out the data-scaling defined by scalpm.
!
!     this subroutine is called by  gnrtp .  it is not called  by  the
!     user.
!
!     the scaling which this routine carries out  must  be  consistent
!     with the scaling in the subroutines mfit and meval1.
!
  integer npts,p
  real    maxabs
  real    coord(npts)
!
  if ( maxabs == 0.0e+00 ) return
     do 10 p = 1,npts
   10       coord(p) = coord(p) / maxabs
     return
end
subroutine scalex (mo, x, typsiz, n, ierr)
!
!*******************************************************************************
!
!! SCALEX rescales the variables
!
  real x(n), typsiz(n)
!
  xmin = 1.e-5 * huge ( xmin )
  do 10 i = 1,n
     t = max ( abs(x(i)), 1.e-20)
     xmin = amin1(t, xmin)
   10 continue
!
  c = 1.e3
  if (mo /= 0) c = 1.e2
  big = c*xmin
  do 20 i = 1,n
     if (abs(x(i)) >= big) go to 30
   20 continue
  ierr = 0
  return
!
   30 do 31 i = 1,n
     t = abs(x(i))/c
     typsiz(i) = max ( t, xmin)
   31 continue
  ierr = -10
  return
end
subroutine scalpm(coord,npts,maxabs)
!
!*******************************************************************************
!
!! SCALPM finds scaling parameter(s) for the problem.
!
!
!  if the scaling scheme
!     is changed, all four of the following would have to be changed
!
!     1)  scalpm  - find the scaling parameters
!     2)  scaldn  - scale the problem data
!     3)  the scaling of the residuals in  mfit
!     4)  the scaling performed in  meval1
!
!     this subroutine is called by  gnrtp .  it is not called  by  the
!     user.
!
!     the scaling which  it  defines  must  be  coordinated  with  the
!     scaling  of residuals which is carried out toward the end of the
!     subroutine  mfit.  the scaling must also be coordinated with the
!     scaling performed in the 10 loop  and  at statements 40 and 50
!     (with the scale factor maxabs(dimp1)) in  meval1.
!
  integer npts,p
  real    maxabs,a
  real    coord(npts)
!
  maxabs = 0.0
  do 10 p = 1,npts
     a = abs(coord(p))
   10    if ( a > maxabs ) maxabs = a
  return
end
function scasum(n,cx,incx)
!
!*******************************************************************************
!
!! SCASUM takes the sum of the absolute values of a complex vector
!  and returns a single precision result.
!     jack dongarra, linpack, 3/11/78.
!
  real scasum
  complex cx(*)
  real stemp
  integer i,incx,n,nincx
!
  scasum = 0.0e0
  stemp = 0.0e0
  if(n <= 0)return
  if(incx==1)go to 20
!
!        code for increment not equal to 1
!
  nincx = n*incx
  do 10 i = 1,nincx,incx
    stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
   10 continue
  scasum = stemp
  return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
    stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i)))
   30 continue
  scasum = stemp
  return
end
subroutine scd(u,k,l,f,s,c,d)
!
!*******************************************************************************
!
!! SCD computes the elliptic functions sn(u,k), cn(u,k), and dn(u,k)
!  for real u and real modulus k such that
!     0.0 <= u <= f and 0.0 <= k < 1.0, where
!     f = f(k) is the complete elliptic integral of the
!     first kind, and f1 = f(l) is the complementary integral.
!     It is assumed that k**2 + l**2 = 1.
!
  real k
  real l
  data pihalf /1.5707963267949/
!
  if (k == 0.0) go to 40
  v = f - u
!
!     uses maclaurin expansion when u or v <= 0.01
!
  if (u > 0.01) go to 10
     call scdm (u,k,s,c,d)
     return
   10 if (v > 0.01) go to 20
  call scdm (v,k,s1,c1,d1)
  s = c1/d1
  c = l*s1/d1
  d = l/d1
  return
!
!     uses fourier expansion when k <= l
!
   20 call ellpi(pihalf,0.0,l,k,f1,e1,ierr)
!
  if (k > l) go to 30
  call scdf (u,k,l,f,f1,s,c,d)
  return
!
!     uses imaginary transformation of jacobi and fourier
!     expansion when k > l
!
   30 call scdj (u,k,l,f,f1,s,c,d)
  return
!
!     computation for k = 0.0
!
   40 s = sin(u)
  c = cos(u)
  d = 1.0
  return
end
subroutine scdf(u,k,l,f,f1,s,c,d)
!
!*******************************************************************************
!
!! SCDF computes sn(u,k), cn(u,k), and dn(u,k) for real u and k
!  by use of the fourier expansion for sn(u,k).  it is
!     assumed that 0.0 <= k < 1.0 and 0.0 <= u <= f,
!     where f = f(k) is the complete elliptic integral of the
!     first kind and f1 = f(l) is the complementary integral, with
!     l /= 0. and k**2 + l**2 = 1.
!
  real i, k, l
  data pihalf /1.5707963267949/
!
  eps = epsilon ( eps )
  tol = eps/10.0
  v = f - u
  qh = exp(-pihalf*f1/f)
  q1 = qh*qh
  q2 = q1*q1
  coef = 4.*pihalf*qh/(k*f)
  qn = 1.0
  qd = q1
  w = amin1(u,v)
  x = pihalf*w/f
!
!     calculation of series for w = amin1(u,v)
!
  i = 1.0
  sum = 0.0
   10 ai = qn/(1.0 - qd)
  a = ai*sin(i*x)
  sum = sum + a
  if (abs(ai) < tol*abs(sum)) go to 20
  qn = qn*q1
  qd = qd*q2
  i = i + 2.0
  go to 10
!
!     assembly for u <= v
!
   20 s = coef*sum
  c = sqrt(1.0 - s*s)
  d = sqrt(1.0 - (k*s)**2)
  if (u == w) return
!
!     assembly for u > v
!
  temp = s
  s = c/d
  c = l*temp/d
  d = l/d
  return
end
subroutine scdj(u,k,l,f,f1,s,c,d)
!
!*******************************************************************************
!
!! SCDJ computes sn(u,k), cn(u,k), and dn(u,k) for real u and k
!  using the imaginary transformation of jacobi and a
!     fourier expansion.  it is assumed that 0.0 <= k < 1.0
!     and 0.0 <= u <= f, where f = f(k) is the complete elliptic
!     integral of the first kind and f1 = f(l) is the complementary
!     integral, and that l /= 0. and k**2 + l**2 = 1.
!
  real k, l, n
  data pihalf /1.5707963267949/
  data pi /3.1415926535898/
!
  eps = epsilon ( eps )
  tol = eps/10.0
  v = f - u
  q1 = -exp(-pi*f/f1)
  q2 = q1*q1
!
  w = amin1(u,v)
  e1 = pi*max ( u,v)/f1
  e2 = pi*(f + w)/f1
  e1 = exp(-e1)
  e2 = exp(-e2)
!
  coef = pihalf/(k*f1)
  x = pihalf*w/f1
  x2 = 2.0*x
!
!     calculation of series for w = amin1(u,v)
!
  n = 1.0
  q1n = q1
  q2n = q2
  e1n = e1
  e2n = e2
  sum = 0.0
!
   20 xn = n*x2
  if (xn > 1.0) go to 30
     call snhcsh(sh,ch,xn,-1)
     sh = sh + xn
     a = 2.0*q1n*abs(q1n)*sh/(1.0 + q2n)
     go to 40
   30 a = q1n*(e1n - e2n)/(1.0 + q2n)
   40 sum = sum + a
  if (abs(a) < tol*abs(sum)) go to 50
  q1n = q1n*q1
  q2n = q2n*q2
  e1n = e1n*e1
  e2n = e2n*e2
  n = n + 1.0
  go to 20
!
!     assembly for u <= v
!
   50 s = coef*(tanh(x) + 2.0*sum)
  c = sqrt(1.0 - s*s)
  d = sqrt(1.0 - (k*s)**2)
  if (u == w) return
!
!     assembly for u > v
!
  temp = s
  s = c/d
  c = l*temp/d
  d = l/d
  return
end
subroutine scdm(u,k,s,c,d)
!
!*******************************************************************************
!
!! SCDM calculates sn(u,k), cn(u,k), and dn(u,k) for "small" u and 0<= k <= 1.
!
!     0.0 <= u <= 0.01 and for 0.0 <= k <= 1.0
!     by use of the maclaurin expansion for sn(u,k)
!
  real k, k2
!
  k2 = k*k
  u2 = u*u
  c1 = -(1.0 + k2)/6.0
  c2 = (1.0 + k2*(14.0 + k2))/120.0
  c3 = -(1.0 + k2*(135.0 + k2*(135.0 + k2)))/5040.0
  c4 = (1.0 + k2*(1228.0 + k2*(5478.0 + k2*(1228.0 + k2))))/ &
       362880.0
  s = u*(1.0 + u2*(c1 + u2*(c2 + u2*(c3 + c4*u2))))
  c = sqrt(1.0 - s*s)
  d = sqrt(1.0 - (k*s)**2)
  return
end
subroutine schur (n, low, igh, h, nh, z, nz, wr, wi, ierr)
!
!*******************************************************************************
!
!! SCHUR factors an upper hessenberg matrix into schur form.
!
!
!  schur obtains an orthogonal matrix q for which transpose(q)*h*q
!     is in schur form. the eigenvalues of h are also computed.
!
!     on input-
!
!        n is the order of the matrix,
!
!        low and igh are integers determined by the balancing
!          subroutine  balanc.  if  balanc  has not been used,
!          set low=1, igh=n, (balanc is an eispack subroutine).
!
!        h contains the upper hessenberg matrix,
!
!        nh is the first dimension of h,
!
!        z contains a matrix of order n,
!
!        nz is the first dimension of z.
!
!     on output-
!
!        h contains the transformed matrix in upper schur form,
!
!        z contains the matrix z*q where q is the orthogonal
!          matrix which reduces h to upper schur form,
!
!        wr and wi contain the real and imaginary parts,
!          respectively, of the eigenvalues.  the eigenvalues
!          are unordered except that complex conjugate pairs
!          of values appear consecutively with the eigenvalue
!          having the positive imaginary part first.  if an
!          error exit is made, the eigenvalues should be correct
!          for indices ierr+1,...,n.
!
!        ierr is set to
!          0          for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!
!     written by jack dongarra
!          argonne national laboratory
!          may 1961
!     modified by a.h. morris (nswc)
!
!     this subroutine is a modification of the eispack subroutine
!     hqr2,  which is based on the algol procedure hqr by peters
!     and wilkinson, num. math. 16 (1970), pp.181-204.
!
  integer i, j, k, l, m, n, en, ll, mm, na, nh, nz, igh, its, low, &
          mp2, enm2, ierr
  real h(nh,n), wr(n), wi(n), z(nz,n)
  real p, q, r, s, t, w, x, y, zz, norm, s1, s2
  logical notlas
!     real sqrt, abs
!     integer min0
!
  ierr = 0
  norm = 0.0
  k = 1
!  store roots isolated by balanc
!                and compute matrix norm.
  do 20 i = 1,n
!
    do 10 j = k,n
      norm = norm + abs(h(i,j))
   10   continue
!
    k = i
    if (i >= low .and. i <= igh) go to 20
    wr(i) = h(i,i)
    wi(i) = 0.0
   20 continue
!
  en = igh
  t = 0.0
!     ********** search for next eigenvalues.
   30 if (en < low) go to 300
  its = 0
  na = en - 1
  enm2 = na - 1
!     ********** look for single small sub-diagonal element
!                for l=en step -1 until low do -- **********
   40 do 50 ll = low,en
    l = en + low - ll
    if (l == low) go to 60
    s = abs(h(l-1,l-1)) + abs(h(l,l))
    if (s == 0.0) s = norm
    s1 = s
    s2 = s1 + abs(h(l,l-1))
    if (s1 == s2) go to 60
   50 continue
!     ********** form shift **********
   60 x = h(en,en)
  if (l == en) go to 220
  y = h(na,na)
  w = h(en,na)*h(na,en)
  if (l  == na) go to 230
  if (its == 30) go to 290
  if (its /= 10 .and. its /= 20) go to 80
!     ********** form exceptional shift **********
  t = t + x
!
  do 70 i = low,en
    h(i,i) = h(i,i) - x
   70 continue
!
  s = abs(h(en,na)) + abs(h(na,enm2))
  x = 0.75*s
  y = x
  w = -0.4375*s*s
   80 its = its + 1
!     ********** look for two consecutive small
!                sub-diagonal elements.
!                for m=en-2 step -1 until l do -- **********
  do 90 mm = l,enm2
    m = enm2 + l - mm
    zz = h(m,m)
    r = x - zz
    s = y - zz
    p = (r*s-w)/h(m+1,m) + h(m,m+1)
    q = h(m+1,m+1) - zz - r - s
    r = h(m+2,m+1)
    s = abs(p) + abs(q) + abs(r)
    p = p/s
    q = q/s
    r = r/s
    if (m == l) go to 100
    s1 = abs(p)*(abs(h(m-1,m-1))+abs(zz)+abs(h(m+1,m+1)))
    s2 = s1 + abs(h(m,m-1))*(abs(q) + abs(r))
    if (s1 == s2) go to 100
   90 continue
!
  100 mp2 = m + 2
!
  do 110 i = mp2,en
    h(i,i-2) = 0.0
    if (i == mp2) go to 110
    h(i,i-3) = 0.0
  110 continue
!     ********** double qr step involving rows l to en and
!                columns m to en **********
  do 210 k = m,na
    notlas = k/=na
    if (k == m) go to 120
    p = h(k,k-1)
    q = h(k+1,k-1)
    r = 0.0
    if (notlas) r = h(k+2,k-1)
    x = abs(p) + abs(q) + abs(r)
    if (x == 0.0) go to 210
    p = p/x
    q = q/x
    r = r/x
  120   s = sqrt(p*p + q*q + r*r)
    if (p < 0.0) s = -s
    if (k == m) go to 130
    h(k,k-1) = -s*x
    go to 140
  130   if (l /= m) h(k,k-1) = -h(k,k-1)
  140   p = p + s
    x = p/s
    y = q/s
    zz = r/s
    q = q/p
    r = r/p
!     ********** row modification **********
    do 160 j = k,n
      p = h(k,j) + q*h(k+1,j)
      if (.not.notlas) go to 150
      p = p + r*h(k+2,j)
      h(k+2,j) = h(k+2,j) - p*zz
  150     h(k+1,j) = h(k+1,j) - p*y
      h(k,j) = h(k,j) - p*x
  160   continue
!
    j = min (en,k+3)
!     ********** column modification **********
    do 180 i = 1,j
      p = x*h(i,k) + y*h(i,k+1)
      if (.not.notlas) go to 170
      p = p + zz*h(i,k+2)
      h(i,k+2) = h(i,k+2) - p*r
  170     h(i,k+1) = h(i,k+1) - p*q
      h(i,k) = h(i,k) - p
  180   continue
!     ********** accumulate transformations **********
    do 200 i = low,igh
      p = x*z(i,k) + y*z(i,k+1)
      if (.not.notlas) go to 190
      p = p + zz*z(i,k+2)
      z(i,k+2) = z(i,k+2) - p*r
  190     z(i,k+1) = z(i,k+1) - p*q
      z(i,k) = z(i,k) - p
  200   continue
!
  210 continue
!
  go to 40
!     ********** one root found **********
  220 h(en,en) = x + t
  wr(en) = h(en,en)
  wi(en) = 0.0
  en = na
  go to 30
!     ********** two roots found **********
  230 p = (y - x)/2.0
  q = p*p + w
  zz = sqrt(abs(q))
  h(en,en) = x + t
  x = h(en,en)
  h(na,na) = y + t
  if (q < 0.0) go to 270
!     ********** real pair **********
  if (p < 0.0) zz = -zz
  zz = p + zz
  wr(na) = x + zz
  wr(en) = wr(na)
  if (zz /= 0.0) wr(en) = x - w/zz
  wi(na) = 0.0
  wi(en) = 0.0
  x = h(en,na)
  s = abs(x) + abs(zz)
  p = x/s
  q = zz/s
  r = sqrt(p*p + q*q)
  p = p/r
  q = q/r
!     ********** row modification **********
  do 240 j = na,n
    zz = h(na,j)
    h(na,j) = q*zz + p*h(en,j)
    h(en,j) = q*h(en,j) - p*zz
  240 continue
!     ********** column modification **********
  do 250 i = 1,en
    zz = h(i,na)
    h(i,na) = q*zz + p*h(i,en)
    h(i,en) = q*h(i,en) - p*zz
  250 continue
!     ********** accumulate transformations **********
  do 260 i = low,igh
    zz = z(i,na)
    z(i,na) = q*zz + p*z(i,en)
    z(i,en) = q*z(i,en) - p*zz
  260 continue
!
  go to 280
!     ********** complex pair **********
  270 wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz
  280 en = enm2
  go to 30
!     ********** set error -- no convergence to an
!                eigenvalue after 30 iterations **********
  290 ierr = en
  return
  300 do 320 i = 1,n
    ip1 = i + 1
    if (abs(wi(i)) /= 0.0) ip1 = ip1 + 1
    if (ip1 > n) go to 320
    do 310 j = ip1,n
      h(j,i) = 0.0
  310   continue
  320 continue
  return
end
function scnrm2( n, cx, incx)
!
!*******************************************************************************
!
!! SCNRM2: unitary norm of a complex n-vector
!  stored in cx() with storage increment incx .
!     if    n <= 0 return with result = 0.
!     if n >= 1 then incx must be >= 1
!
!           c.l.lawson , 1978 jan 08
!
!     four phase method     using two built-in constants that are
!     hopefully applicable to all machines.
!         cutlo = maximum of  sqrt(u/eps)  over all known machines.
!         cuthi = minimum of  sqrt(v)      over all known machines.
!     where
!         eps = smallest no. such that eps + 1. > 1.
!         u   = smallest positive no.   (underflow limit)
!         v   = largest  no.            (overflow  limit)
!
!     brief outline of algorithm..
!
!     phase 1    scans zero components.
!     move to phase 2 when a component is nonzero and <= cutlo
!     move to phase 3 when a component is > cutlo
!     move to phase 4 when a component is >= cuthi/m
!     where m = n for x() real and m = 2*n for complex.
!
  real scnrm2
  logical imag, scale
  integer          next
  real         cutlo, cuthi, hitest, sum, xmax, absx, zero, one
  complex      cx(*)
  data         zero, one /0.0e0, 1.0e0/
!
!     values for cutlo and cuthi..
!     from the environmental parameters listed in the imsl converter
!     document the limiting values are as follows..
!     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
!                   univac and dec at 2**(-103)
!                   thus cutlo = 2**(-51) = 4.44089e-16
!     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
!                   thus cuthi = 2**(63.5) = 1.30438e19
!     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
!                   thus cutlo = 2**(-33.5) = 8.23181d-11
!     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
!     data cutlo, cuthi / 8.232d-11,  1.304d19 /
!     data cutlo, cuthi / 4.441e-16,  1.304e19 /
  data cutlo, cuthi / 4.441e-16,  1.304e19 /
!
  if(n > 0) go to 10
     scnrm2  = zero
     go to 300
!
   10 assign 30 to next
  sum = zero
  nn = n * incx
!                                                 begin main loop
  do 210 i=1,nn,incx
     absx = abs(real(cx(i)))
     imag = .false.
     go to next,(30, 50, 70, 90, 110)
   30 if( absx > cutlo) go to 85
  assign 50 to next
  scale = .false.
!
!                        phase 1.  sum is zero
!
   50 if( absx == zero) go to 200
  if( absx > cutlo) go to 85
!
!                                prepare for phase 2.
  assign 70 to next
  go to 105
!
!                                prepare for phase 4.
!
  100 assign 110 to next
  sum = (sum / absx) / absx
  105 scale = .true.
  xmax = absx
  go to 115
!
!                   phase 2.  sum is small.
!                             scale to avoid destructive underflow.
!
   70 if( absx > cutlo ) go to 75
!
!                     common code for phases 2 and 4.
!                     in phase 4 sum is large.  scale to avoid overflow.
!
  110 if( absx <= xmax ) go to 115
     sum = one + sum * (xmax / absx)**2
     xmax = absx
     go to 200
!
  115 sum = sum + (absx/xmax)**2
  go to 200
!
!
!                  prepare for phase 3.
!
   75 sum = (sum * xmax) * xmax
!
   85 assign 90 to next
  scale = .false.
!
!     for real or d.p. set hitest = cuthi/n
!     for complex      set hitest = cuthi/(2*n)
!
  hitest = cuthi/real( n )
  hitest = hitest * 0.5
!
!                   phase 3.  sum is mid-range.  no scaling.
!
   90 if(absx >= hitest) go to 100
     sum = sum + absx**2
  200 continue
!                  control selection of real and imaginary parts.
!
  if(imag) go to 210
     absx = abs(aimag(cx(i)))
     imag = .true.
  go to next,(  50, 70, 90, 110 )
!
  210 continue
!
!              end of main loop.
!              compute square root and adjust for scaling.
!
  scnrm2 = sqrt(sum)
  if(scale) scnrm2 = scnrm2 * xmax
  300 continue
  return
end
subroutine scomp (x,y,a,b,c,n,xi,yi,ni,ierr)
!
!*******************************************************************************
!
!! SCOMP evaluates a cubic spline at the abscissas in xi.
!
!
!         it is assumed that the coefficients of the polynomials
!         which form the spline are provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of the first n abscissas (in increasing order)
!               that define the spline.
!         y   - array of the first n ordinates that define the spline.
!         a,b,c arrays that contain the coefficients of the polynomials
!               which form the spline. if i = 1,...,n  then the spline
!               has the value
!                    y(i) + a(i)*dx + b(i)*dx**2 + c(i)*dx**3
!               for x(i) <= xx <= x(i+1).  here dx = xx-x(i).
!         n   - the number of polynomials that define the spline.
!               the arrays x, y, a, b, c  must be dimensioned at
!               least n.  n must be greater than or equal to 1.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1 then xi and yi
!               must be arrays of dimension ni or larger.
!               it is assumed that ni is greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n), y(n), a(n), b(n), c(n), xi(ni), yi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  il = 1
  ir = n
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = n
  go to 100
   90 i = 1
!
!     evaluation
!
  100 dx = xx - x(i)
  yi(k) = y(i) + dx*(a(i) + dx*(b(i) + dx*c(i)))
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,n)
  go to 10
end
subroutine scomp1 (x,y,yp,n,xi,yi,ni,ierr)
!
!*******************************************************************************
!
!! SCOMP1 evaluates a cubic spline at the abscissas in xi.
!
!
!         it is assumed that the first derivatives at the nodes
!         have been provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of abscissas (in increasing order) that define the
!               spline.
!         y   - array of ordinates that define the spline.
!         yp  - array of first derivatives that define the spline.
!         n   - the number of data points that define the spline.
!               the arrays x, y, and yp must be dimensioned at least n.
!               n must be greater than or equal to 2.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1 then xi and yi
!               must be arrays of dimension ni or larger.
!               it is assumed that ni is greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n), y(n), yp(n), xi(ni), yi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
  nm1 = n - 1
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  il = 1
  ir = nm1
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = nm1
  go to 100
   90 i = 1
!
!     evaluation
!
  100 h = x(i+1) - x(i)
  d = (y(i+1) - y(i))/h
  a = yp(i) + yp(i+1)
  b = (-a - yp(i) + 3.0*d)/h
  c = (a - d - d)/(h*h)
  dx = xx - x(i)
  yi(k) = y(i) + dx*(yp(i) + dx*(b + dx*c))
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,nm1)
  go to 10
end
subroutine scomp2 (x,y,ypp,n,xi,yi,ni,ierr)
!
!*******************************************************************************
!
!! SCOMP2 evaluates a cubic spline at the abscissas in xi.
!         it is assumed that the second derivatives at the nodes
!         have been provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of abscissas (in increasing order) that define the
!               spline.
!         y   - array of ordinates that define the spline.
!         ypp - array of second derivatives that define the spline.
!         n   - the number of data points that define the spline.
!               the arrays x, y, and ypp must be dimensioned at least n.
!               n must be greater than or equal to 2.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1 then xi and yi
!               must be arrays of dimension ni or larger.
!               it is assumed that ni is greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n), y(n), ypp(n), xi(ni), yi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
  nm1 = n - 1
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  il = 1
  ir = nm1
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = nm1
  go to 100
   90 i = 1
!
!     evaluation
!
  100 h  = x(i+1) - x(i)
  h2 = h*h
  xr = (x(i+1) - xx)/h
  xr2 = xr*xr
  xr3 = xr*xr2
  xl = (xx - x(i))/h
  xl2 = xl*xl
  xl3 = xl*xl2
  yi(k) = y(i)*xr + y(i+1)*xl &
         - h2*(ypp(i)*(xr-xr3) + ypp(i+1)*(xl-xl3))/6.0
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,nm1)
  go to 10
end
subroutine sconj (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! SCONJ computates the conjugate of a sparse complex matrix.
!
  complex a(*), b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  mp1 = m + 1
  l = ia(1) - 1
  do 10 i = 1,mp1
     ib(i) = ia(i) - l
   10 continue
!
  ibeg = ia(1)
  iend = ia(mp1) - 1
  if (ibeg > iend) return
  l = 1
  do 20 ip = ibeg,iend
     b(l) = conjg(a(ip))
     jb(l) = ja(ip)
     l = l + 1
   20 continue
  return
end
subroutine scopy ( n, x, incx, y, incy )
!
!*******************************************************************************
!
!! SCOPY copies one real vector into another.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector to be copied into Y.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Output, real Y(*), the copy of X.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real x(*)
  real y(*)
!
  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    y(1:n) = x(1:n)

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( incy >= 0 ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      y(iy) = x(ix)
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine scvdr (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! SCVDR ???
!
  double precision a(*)
  real b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        if (a(ip) == 0.d0) go to 10
        b(l) = a(ip)
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
subroutine scvrc (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! SCVRC computes a + bi for the sparse real matrices a and b
!
  real a(*), b(*), wk(n)
  complex c(*), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 j = 1,n
     wk(j) = 0.0
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        if (b(l) == 0.0) go to 31
        j = jb(l)
        t = cmplx (wk(j), b(l))
        wk(j) = 0.0
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == 0.0) go to 41
        if (ip > num) go to 50
        c(ip) = cmplx (wk(j), 0.0)
        wk(j) = 0.0
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine scvrd (a, ia, ja, b, ib, jb, m)
!
!*******************************************************************************
!
!! SCVRD ???
!
  real a(*)
  double precision b(*)
  integer ia(*), ja(*), ib(*), jb(*)
!
  l = 1
  do 20 i = 1,m
     ib(i) = l
     ibeg = ia(i)
     iend = ia(i+1) - 1
     if (ibeg > iend) go to 20
     do 10 ip = ibeg,iend
        if (a(ip) == 0.0) go to 10
        b(l) = a(ip)
        jb(l) = ja(ip)
        l = l + 1
   10    continue
   20 continue
  ib(m + 1) = l
  return
end
function sdot ( n, x, incx, y, incy )
!
!*******************************************************************************
!
!! SDOT forms the dot product of two vectors.
!
!
!  Modified:
!
!    02 June 2000
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input, real X(*), one of the vectors to be multiplied.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input, real Y(*), one of the vectors to be multiplied.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
!    Output, real SDOT, the dot product of X and Y.
!
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real sdot
  real stemp
  real x(*)
  real y(*)
!
  if ( n <= 0 ) then

    sdot = 0.0E+00

  else if ( incx == 1 .and. incy == 1 ) then

    sdot = dot_product ( x(1:n), y(1:n) )

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( incy >= 0 ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    stemp = 0.0E+00
    do i = 1, n
      stemp = stemp + x(ix) * y(iy)
      ix = ix + incx
      iy = iy + incy
    end do

    sdot = stemp

  end if

  return
end
subroutine secfac (nr,n,x,g,a,xpls,gpls,itncnt,tol, &
                        noupdt,s,y,w)
!
!*******************************************************************************
!
!! SECFAC updates the hessian by the bfgs factored method.
!
!
!     input ...
!
!       nr        row dimension of matrix
!       n         order of the matrix
!       x(n)      old iterate x(k-1)
!       g(n)      gradient at the old iterate
!       xpls(n)   new iterate x(k)
!       gpls(n)   gradient at the new iterate
!       itncnt    iteration count
!       tol       relative tolerance to be used for noise
!
!     input/output ...
!
!       a(n,n)    on entry, cholesky decomposition of hessian in
!                    the lower part and diagonal.
!                 on exit,  updated cholesky decomposition of hessian
!                    in the lower triangular part and diagonal.
!       noupdt    boolean. no update yet.
!
!     work spaces ...  s(n), y(n), w(n)
!
!
  real x(n), xpls(n), g(n), gpls(n)
  real a(nr,n)
  real s(n), y(n), w(n)
  logical noupdt
!
  if (itncnt == 1) noupdt = .true.
  do 10 i = 1,n
     s(i) = xpls(i) - x(i)
     y(i) = gpls(i) - g(i)
   10 continue
  den1 = sdot(n,s,1,y,1)
  snorm2 = snrm2(n,s,1)
  ynrm2 = snrm2(n,y,1)
  if (den1 < tol*snorm2*ynrm2) return
!
!     set s = transpose(l)*s
!
  do 21 i = 1,n
     sum = 0.0
     do 20 j = i,n
        sum = sum + a(j,i)*s(j)
   20    continue
     s(i) = sum
   21 continue
  den2 = sdot(n,s,1,s,1)
!
!     set alp = sqrt(den1/den2)
!
  alp = sqrt(den1/den2)
  if (.not.noupdt) go to 40
!
!        on the initial update set l = alp*l. then s must be
!        reset to alp*s. after this is done then den2 = den1
!        and alp has the value 1.
!
     do 31 j = 1,n
        s(j) = alp*s(j)
        do 30 i = j,n
           a(i,j) = alp*a(i,j)
   30       continue
   31    continue
     noupdt = .false.
     alp = 1.0
!
!     set w = l*s
!
   40 do 51 i = 1,n
     sum = 0.0
     do 50 j = 1,i
        sum = sum + a(i,j)*s(j)
   50    continue
     w(i) = sum
   51 continue
!
!     if abs(y(i) - w(i)) is less than the estimated noise in y(i)
!     for each i, then the update is skipped.
!
  do 60 i = 1,n
  if (abs(y(i) - w(i)) >= tol*max ( abs(g(i)),abs(gpls(i)))) &
           go to 70
   60 continue
  return
!
!     w = y - alp*l*s
!
   70 do 71 i = 1,n
     w(i) = y(i) - alp*w(i)
   71 continue
!
!     s = s/sqrt(den1*den2)
!
  alp = alp/den1
  do 80 i = 1,n
     s(i) = alp*s(i)
   80 continue
!
!     copy l into upper triangular part.  zero l.
!
  do 100 i = 2,n
     im1 = i - 1
     do 90 j = 1,im1
        a(j,i) = a(i,j)
        a(i,j) = 0.0
   90    continue
  100 continue
!
!     find q and r such that  q*r = (l+) + s*(w+)
!
  call qrupdt (nr, n, a, s, w)
!
!     upper triangular part and diagonal of a now contain updated
!     cholesky decomposition of hessian.  copy back to lower
!     triangular part.
!
  do 120 i = 2,n
     im1 = i - 1
     do 110 j = 1,im1
        a(i,j) = a(j,i)
  110    continue
  120 continue
  return
end
subroutine seig (a, ka, n, w, t, ierr)
!
!*******************************************************************************
!
!! SEIG: eigenvalues of a symmetric real matrix.
!
  real a(*), w(n), t(*)
!
  if (ka == 0) go to 10
     call tred1 (ka, n, a, w, t(n+1), t(1))
     call tqlrat (n, w, t, ierr)
     return
10    l = n*(n + 1)
  l = l/2
  call tred3 (n, l, a, w, t(n+1), t(1))
  call tqlrat (n, w, t, ierr)
  return
end
subroutine seig1 (a, ka, n, w, t, ierr)
!
!*******************************************************************************
!
!! SEIG1: eigenvalues of symmetric real matrices
!
  real a(*), w(n), t(n)
!
  if (ka == 0) go to 10
     call tred1 (ka, n, a, w, t, t)
     call imtql1 (n, w, t, ierr)
     return
10    l = n*(n + 1)
  l = l/2
  call tred3 (n, l, a, w, t, t)
  call imtql1 (n, w, t, ierr)
  return
end
subroutine seigv (a, ka, n, w, z, t, ierr)
!
!*******************************************************************************
!
!! SEIGV: eigenvalues and eigenvectors of symmetric real matrices
!
  real a(ka,n), w(n), z(ka,n), t(n)
!
  call tred2 (ka, n, a, w, t, z)
  call tql2 (ka, n, w, t, z, ierr)
  return
end
subroutine seigv1 (a, ka, n, w, z, t, ierr)
!
!*******************************************************************************
!
!! SEIGV1: eigenvalues and eigenvectors of symmetric real matrices
!
  real a(ka,n), w(n), z(ka,n), t(n)
!
  call tred2 (ka, n, a, w, t, z)
  call imtql2 (ka, n, w, t, z, ierr)
  return
end
subroutine sepde (cofx, cofy, g, edge, bval, iord, a, b, mp1, &
                           c, d, np1, u, ku, w, nw, ierr)
!
!*******************************************************************************
!
!! SEPDE: solution of separable elliptic partial differential equations
!                     on rectangular domains
!
  real u(ku,np1), w(nw), dum(1)
  integer edge(4)
  external cofx, cofy
!
  data alpha/0.0/, beta/0.0/, gam/0.0/, del/0.0/
!
  call pdedge (edge, indx, indy, ierr)
  if (ierr /= 0) return
!
  if (a >= b .or. c >= d) go to 300
  if (mp1 < 7) go to 320
  if (np1 < 6) go to 330
  m = mp1 - 1
  n = np1 - 1
  hx = (b - a)/real(m)
  hy = (d - c)/real(n)
!
!     define the maximum and minimum row and column
!     that is needed for the right-hand side matrix
!
  xmin = a
  ymin = c
  imin = 1
  imax = mp1
  jmin = 1
  jmax = np1
  jcol = 0
  if (edge(1) /= 0) go to 10
  jmin = 2
  ymin = c + hy
  jcol = mp1
   10 if (edge(2) /= 0) go to 20
  imin = 2
  xmin = a + hx
   20 if (edge(3) == 0) jmax = n
  if (edge(4) == 0) imax = m
!
!     define the right-hand side matrix for iord = 2
!
  if (ku < mp1) go to 310
  if (iord /= 2) go to 40
  mn = 0
!
  yj = ymin
  do 31 j = jmin,jmax
  xi = xmin
     do 30 i = imin,imax
     u(i,j) = g(xi, yj)
   30    xi = xi + hx
   31 yj = yj + hy
  go to 60
!
!     define the right-hand side matrix for iord = 4
!
   40 if (iord /= 4) go to 340
  mn = mp1*np1
  if (mn >= nw) go to 100
!
  yj = ymin
  do 51 j = jmin,jmax
  xi = xmin
     do 50 i = imin,imax
     ij = i + jcol
     w(ij) = g(xi, yj)
   50    xi = xi + hx
  yj = yj + hy
   51 jcol = jcol + mp1
!
!     store the boundary values of u
!
   60 if (edge(1) /= 0) go to 70
  xi = a
  do 61 i = 1,mp1
     u(i,1) = bval(1,xi,c)
   61 xi = xi + hx
!
   70 if (edge(2) /= 0) go to 80
  yj = c
  do 71 j = 1,np1
     u(1,j) = bval(2,a,yj)
   71 yj = yj + hy
!
   80 if (edge(3) /= 0) go to 90
  xi = a
  do 81 i = 1,mp1
     u(i,np1) = bval(3,xi,d)
   81 xi = xi + hx
!
   90 if (edge(4) /= 0) go to 100
  yj = c
  do 91 j = 1,np1
     u(mp1,j) = bval(4,b,yj)
   91 yj = yj + hy
!
!     store the mixed boundary conditions
!
  100 ic = mn + 1
  if (edge(1) /= 1) go to 120
  mn = mn + mp1
  if (mn >= nw) go to 120
!
  xi = a
  l = ic
  do 110 i = 1,mp1
     w(l) = bval(1,xi,c)
     xi = xi + hx
     l = l + 1
  110 continue
!
  120 ia = mn + 1
  if (edge(2) /= 1) go to 140
  mn = mn + np1
  if (mn >= nw) go to 140
!
  yj = c
  l = ia
  do 130 j = 1,np1
     w(l) = bval(2,a,yj)
     yj = yj + hy
     l = l + 1
  130 continue
!
  140 id = mn + 1
  if (edge(3) /= 1) go to 160
  mn = mn + mp1
  if (mn >= nw) go to 160
!
  xi = a
  l = id
  do 150 i = 1,mp1
     w(l) = bval(3,xi,d)
     xi = xi + hx
     l = l + 1
  150 continue
!
  160 ib = mn + 1
  if (edge(4) /= 1) go to 200
  mn = mn + np1
  if (mn >= nw) go to 200
!
  yj = c
  l = ib
  do 170 j = 1,np1
     w(l) = bval(4,b,yj)
     yj = yj + hy
     l = l + 1
  170 continue
!
!     call the differential equation solver
!
  200 if (mn >= nw) go to 350
  iw = mn + 1
  w(iw) = nw - mn
  if (iord == 4) go to 210
!
  call sepell (0, iord, a, b, m, indx, w(ia), alpha, w(ib), beta, &
               c, d, n, indy, w(ic), gam, w(id), del, cofx, cofy, &
               u, ku, u, ku, w(iw), p, ierr)
  go to 220
!
  210 call sepell (0, iord, a, b, m, indx, w(ia), alpha, w(ib), beta, &
               c, d, n, indy, w(ic), gam, w(id), del, cofx, cofy, &
               w(1),mp1, u, ku, w(iw), p, ierr)
!
  220 nw = w(iw) + mn
  if (ierr /= 0) return
  if (p == 0.0) return
  ierr = -1
  w(1) = p
  return
!
!     error return
!
  300 ierr = 1
  return
!
  310 ierr = 5
  return
!
  320 ierr = 6
  return
!
  330 ierr = 7
  return
!
  340 ierr = 8
  return
!
  350 dum(1) = 1.0
  call sepell (0, iord, a, b, m, indx, dum, alpha, dum, beta, &
               c, d, n, indy, dum, gam, dum, del, cofx, cofy, &
               u, ku, u, ku, dum, p, ierr)
  nw = dum(1) + mn
  return
end
subroutine sepel1 (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c, &
                     d,n,nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,an,bn, &
                     cn,dn,un,zn,am,bm,cm,dm,um,zm,grhs,mn,usol, &
                     idmn,w,pertrb,ierror)
!
!*******************************************************************************
!
!! SEPEL1 sets up vectors and arrays for input to blktri
!     and computes a second order solution in usol.  a return jump to
!     sepell occurrs if iorder=2.  if iorder=4 a fourth order
!     solution is generated in usol.
!
  dimension       bda(*)     ,bdb(*)     ,bdc(*)     ,bdd(*)     , &
                  w(*)
  dimension       grhs(mn,*)             ,usol(idmn,*)
  dimension       an(*)      ,bn(*)      ,cn(*)      ,dn(*)      , &
                  un(*)      ,zn(*)
  dimension       am(*)      ,bm(*)      ,cm(*)      ,dm(*)      , &
                  um(*)      ,zm(*)
  logical         singlr
  external        cofx, cofy
  common /splp/   kswx       ,kswy       ,k          ,l          , &
                  ait        ,bit        ,cit        ,dit        , &
                  mit        ,nit        ,is         ,ms         , &
                  js         ,ns         ,dlx        ,dly        , &
                  tdlx3      ,tdly3      ,dlx4       ,dly4
!
!
!     set parameters internally
!
  kswx = mbdcnd+1
  kswy = nbdcnd+1
  k = m+1
  l = n+1
  ait = a
  bit = b
  cit = c
  dit = d
!
!     set right hand side values from grhs in usol on the interior
!     and non-specified boundaries.
!
  do  20 i=2,m
     do  10 j=2,n
        usol(i,j) = grhs(i,j)
   10    continue
   20 continue
  if (kswx==2 .or. kswx==3) go to  40
  do  30 j=2,n
     usol(1,j) = grhs(1,j)
   30 continue
   40 continue
  if (kswx==2 .or. kswx==5) go to  60
  do  50 j=2,n
     usol(k,j) = grhs(k,j)
   50 continue
   60 continue
  if (kswy==2 .or. kswy==3) go to  80
  do  70 i=2,m
     usol(i,1) = grhs(i,1)
   70 continue
   80 continue
  if (kswy==2 .or. kswy==5) go to 100
  do  90 i=2,m
     usol(i,l) = grhs(i,l)
   90 continue
  100 continue
  if (kswx/=2 .and. kswx/=3 .and. kswy/=2 .and. kswy/=3) &
      usol(1,1) = grhs(1,1)
  if (kswx/=2 .and. kswx/=5 .and. kswy/=2 .and. kswy/=3) &
      usol(k,1) = grhs(k,1)
  if (kswx/=2 .and. kswx/=3 .and. kswy/=2 .and. kswy/=5) &
      usol(1,l) = grhs(1,l)
  if (kswx/=2 .and. kswx/=5 .and. kswy/=2 .and. kswy/=5) &
      usol(k,l) = grhs(k,l)
  i1 = 1
!
!     set switches for periodic or non-periodic boundaries
!
  mp = 1
  np = 1
  if (kswx == 1) mp = 0
  if (kswy == 1) np = 0
!
!     set dlx,dly and size of block tri-diagonal system generated
!     in nint,mint
!
  dlx = (bit-ait)/real(m)
  mit = k-1
  if (kswx == 2) mit = k-2
  if (kswx == 4) mit = k
  dly = (dit-cit)/real(n)
  nit = l-1
  if (kswy == 2) nit = l-2
  if (kswy == 4) nit = l
  tdlx3 = 2.0*dlx**3
  dlx4 = dlx**4
  tdly3 = 2.0*dly**3
  dly4 = dly**4
!
!     set subscript limits for portion of array to input to blktri
!
  is = 1
  js = 1
  if (kswx==2 .or. kswx==3) is = 2
  if (kswy==2 .or. kswy==3) js = 2
  ns = nit+js-1
  ms = mit+is-1
!
!     set x - direction
!
  do i=1,mit
     xi = ait+real(is+i-2)*dlx
     call cofx (xi,ai,bi,ci)
     axi = (ai/dlx-0.5*bi)/dlx
     bxi = -2.*ai/dlx**2+ci
     cxi = (ai/dlx+0.5*bi)/dlx
     am(i) = axi
     bm(i) = bxi
     cm(i) = cxi
  end do
!
!     set y direction
!
  do 120 j=1,nit
     yj = cit+real(js+j-2)*dly
     call cofy (yj,dj,ej,fj)
     dyj = (dj/dly-0.5*ej)/dly
     eyj = (-2.*dj/dly**2+fj)
     fyj = (dj/dly+0.5*ej)/dly
     an(j) = dyj
     bn(j) = eyj
     cn(j) = fyj
  120 continue
!
!     adjust edges in x direction unless periodic
!
  ax1 = am(1)
  cxm = cm(mit)
  go to (170,130,150,160,140),kswx
!
!     dirichlet-dirichlet in x direction
!
  130 am(1) = 0.0
  cm(mit) = 0.0
  go to 170
!
!     mixed-dirichlet in x direction
!
  140 am(1) = 0.0
  bm(1) = bm(1)+2.*alpha*dlx*ax1
  cm(1) = cm(1)+ax1
  cm(mit) = 0.0
  go to 170
!
!     dirichlet-mixed in x direction
!
  150 am(1) = 0.0
  am(mit) = am(mit)+cxm
  bm(mit) = bm(mit)-2.*beta*dlx*cxm
  cm(mit) = 0.0
  go to 170
!
!     mixed - mixed in x direction
!
  160 continue
  am(1) = 0.0
  bm(1) = bm(1)+2.*dlx*alpha*ax1
  cm(1) = cm(1)+ax1
  am(mit) = am(mit)+cxm
  bm(mit) = bm(mit)-2.*dlx*beta*cxm
  cm(mit) = 0.0
  170 continue
!
!     adjust in y direction unless periodic
!
  dy1 = an(1)
  fyn = cn(nit)
  go to (220,180,200,210,190),kswy
!
!     dirichlet-dirichlet in y direction
!
  180 continue
  an(1) = 0.0
  cn(nit) = 0.0
  go to 220
!
!     mixed-dirichlet in y direction
!
  190 continue
  an(1) = 0.0
  bn(1) = bn(1)+2.*dly*gama*dy1
  cn(1) = cn(1)+dy1
  cn(nit) = 0.0
  go to 220
!
!     dirichlet-mixed in y direction
!
  200 an(1) = 0.0
  an(nit) = an(nit)+fyn
  bn(nit) = bn(nit)-2.*dly*xnu*fyn
  cn(nit) = 0.0
  go to 220
!
!     mixed - mixed direction in y direction
!
  210 continue
  an(1) = 0.0
  bn(1) = bn(1)+2.*dly*gama*dy1
  cn(1) = cn(1)+dy1
  an(nit) = an(nit)+fyn
  bn(nit) = bn(nit)-2.0*dly*xnu*fyn
  cn(nit) = 0.0
  220 if (kswx == 1) go to 270
!
!     adjust usol along x edge
!
  do 260 j=js,ns
     if (kswx/=2 .and. kswx/=3) go to 230
     usol(is,j) = usol(is,j)-ax1*usol(1,j)
     go to 240
  230    usol(is,j) = usol(is,j)+2.0*dlx*ax1*bda(j)
  240    if (kswx/=2 .and. kswx/=5) go to 250
     usol(ms,j) = usol(ms,j)-cxm*usol(k,j)
     go to 260
  250    usol(ms,j) = usol(ms,j)-2.0*dlx*cxm*bdb(j)
  260 continue
  270 if (kswy == 1) go to 320
!
!     adjust usol along y edge
!
  do 310 i=is,ms
     if (kswy/=2 .and. kswy/=3) go to 280
     usol(i,js) = usol(i,js)-dy1*usol(i,1)
     go to 290
  280    usol(i,js) = usol(i,js)+2.0*dly*dy1*bdc(i)
  290    if (kswy/=2 .and. kswy/=5) go to 300
     usol(i,ns) = usol(i,ns)-fyn*usol(i,l)
     go to 310
  300    usol(i,ns) = usol(i,ns)-2.0*dly*fyn*bdd(i)
  310 continue
  320 continue
!
!     save adjusted edges in grhs if iorder=4
!
  if (iorder /= 4) go to 350
  do 330 j=js,ns
     grhs(is,j) = usol(is,j)
     grhs(ms,j) = usol(ms,j)
  330 continue
  do 340 i=is,ms
     grhs(i,js) = usol(i,js)
     grhs(i,ns) = usol(i,ns)
  340 continue
  350 continue
  iord = iorder
  pertrb = 0.0
!
!     check if operator is singular
!
  call chksng (mbdcnd,nbdcnd,alpha,beta,gama,xnu,cofx,cofy,singlr)
!
!     compute non-zero eigenvector in null space of transpose
!     if singular
!
  if (singlr) call trisp (mit,am,bm,cm,dm,um,zm)
  if (singlr) call trisp (nit,an,bn,cn,dn,un,zn)
!
!     make initialization call to blktri
!
  if (intl == 0) &
      call blktri (intl,np,nit,an,bn,cn,mp,mit,am,bm,cm,idmn, &
                   usol(is,js),ierror,w)
  if (ierror /= 0) return
!
!     adjust right hand side if necessary
!
  360 continue
  if (singlr) call orthg (usol,idmn,zn,zm,pertrb)
!
!     compute solution
!
  call blktri (i1,np,nit,an,bn,cn,mp,mit,am,bm,cm,idmn,usol(is,js), &
               ierror,w)
  if (ierror /= 0) return
!
!  set periodic boundaries if necessary
!
  if ( kswx == 1 ) then
    usol(k,1:l) = usol(1,1:l)
  end if

  if ( kswy == 1 ) then
    usol(1:k,l) = usol(1:k,1)
  end if
!
!  Minimize solution with respect to weighted least squares
!  norm if operator is singular.
!
  if ( singlr ) then
    call minsol (usol,idmn,zn,zm,prtrb)
  end if
!
!  return if deferred corrections and a fourth order solution are not flagged.
!
  if (iord == 2) then
    return
  end if

  iord = 2
!
!  Compute new right hand side for fourth order solution.
!
  call defer (cofx,cofy,usol,idmn,grhs,mn)

  go to 360
end
subroutine sepell (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c, &
                     d,n,nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,grhs,mn, &
                     usol,idmn,w,pertrb,ierror)
!
!*******************************************************************************
!
!! SEPELL solves a separable elliptic pde on a rectangular domain.
!
!
! dimension of           bda(n+1), bdb(n+1), bdc(m+1), bdd(m+1),
! arguments              usol(idmn,n+1), grhs(mn,n+1),
!                        w (see argument list)
!
! latest revision        january 1978 (by the authors)
!                        modified 1986 by a.h. morris (nswc)
!
! purpose                sepell solves for either the second-order
!                        finite difference approximation or a
!                        fourth-order approximation to a separable
!                        elliptic equation
!
!                                    2    2
!                             af(x)*d u/dx + bf(x)*du/dx  + cf(x)*u +
!                                    2    2
!                             df(y)*d u/dy  + ef(y)*du/dy + ff(y)*u
!
!                             = g(x,y)
!
!                        on a rectangle (x greater than or equal to a
!                        and less than or equal to b, y greater than
!                        or equal to c and less than or equal to d).
!                        any combination of periodic or mixed boundary
!                        conditions is allowed.
!
! purpose                the possible boundary conditions are ...
!                        in the x-direction..
!                         (0) periodic, u(x+b-a,y)=u(x,y) for all y,x
!                         (1) u(a,y), u(b,y) are specified for all y
!                         (2) u(a,y), du(b,y)/dx+beta*u(b,y) are
!                             specified for all y
!                         (3) du(a,y)/dx+alpha*u(a,y),du(b,y)/dx+
!                             beta*u(b,y) are specified for all y
!                         (4) du(a,y)/dx+alpha*u(a,y),u(b,y) are
!                             specified for all y
!
!                        in the y-direction..
!                         (0) periodic, u(x,y+d-c)=u(x,y) for all x,y
!                         (1) u(x,c),u(x,d) are specified for all x
!                         (2) u(x,c),du(x,d)/dy+xnu*u(x,d) are specified
!                             for all x
!                         (3) du(x,c)/dy+gama*u(x,c),du(x,d)/dy+
!                             xnu*u(x,d) are specified for all x
!                         (4) du(x,c)/dy+gama*u(x,c),u(x,d) are
!                             specified for all x
!
! arguments
!
! on input               intl
!                          = 0 on initial entry to sepell or if any of
!                              the arguments c, d, n, nbdcnd, cofy are
!                              changed from a previous call
!                          = 1 if c, d, n, nbdcnd, cofy are unchanged
!                              from the previous call.
!
!                        iorder
!                          = 2 if a second-order approximation is sought
!                          = 4 if a fourth-order approximation is sought
!
!                        a,b
!                          the range of the x-independent variable,
!                          i.e., x is greater than or equal to a and
!                          less than or equal to b. a must be less than
!                          b.
!
!                        m
!                          the number of panels into which the interval
!                          (a,b) is subdivided.  hence, there will be
!                          m+1 grid points in the x-direction given by
!                          xi=a+(i-1)*dlx for i=1,2,...,m+1 where
!                          dlx=(b-a)/m is the panel width.  m must be
!                          less than idmn and greater than 5.
!
!                        mbdcnd
!                          indicates the type of boundary condition at
!                          x=a and x=b
!                          = 0 if the solution is periodic in x, i.e.,
!                              u(x+b-a,y)=u(x,y) for all y,x
!                          = 1 if the solution is specified at x=a and
!                              x=b, i.e., u(a,y) and u(b,y) are
!                              specified for all y
!                          = 2 if the solution is specified at x=a and
!                              the boundary condition is mixed at x=b,
!                              i.e., u(a,y) and du(b,y)/dx+beta*u(b,y)
!                              are specified for all y
!                          = 3 if the boundary conditions at x=a and x=b
!                              are mixed, i.e., du(a,y)/dx+alpha*u(a,y)
!                              and du(b,y)/dx+beta*u(b,y) are specified
!                              for all y
!                          = 4 if the boundary condition at x=a is mixed
!                              and the solution is specified at x=b,
!                              i.e., du(a,y)/dx+alpha*u(a,y) and u(b,y)
!                              are specified for all y
!
!                        bda
!                          a one-dimensional array of length n+1 that
!                          specifies the values of du(a,y)/dx+
!                          alpha*u(a,y) at x=a. when mbdcnd=3 or 4
!                               bda(j) = du(a,yj)/dx+alpha*u(a,yj),
!                               j=1,2,...,n+1.
!                          when mbdcnd has any other value, bda is a
!                          dummy parameter.
!
! on input               alpha
!                          the scalar multiplying the solution in case
!                          of a mixed boundary condition at x=a (see
!                          argument bda). if mbdcnd/=3,4 then alpha
!                          is a dummy parameter.
!
!                        bdb
!                          a one-dimensional array of length n+1 that
!                          specifies the values of du(b,y)/dx+
!                          beta*u(b,y) at x=b.  when mbdcnd=2 or 3
!                               bdb(j) = du(b,yj)/dx+beta*u(b,yj),
!                               j=1,2,...,n+1.
!                          when mbdcnd has any other value, bdb is a
!                          dummy parameter.
!
!                        beta
!                          the scalar multiplying the solution in case
!                          of a mixed boundary condition at x=b (see
!                          argument bdb). if mbdcnd/=2,3 then beta is
!                          a dummy parameter.
!
!                        c,d
!                          the range of the y-independent variable,
!                          i.e., y is greater than or equal to c and
!                          less than or equal to d.  c must be less
!                          than d.
!
!                        n
!                          the number of panels into which the interval
!                          (c,d) is subdivided.  hence, there will be
!                          n+1 grid points in the y-direction given by
!                          yj=c+(j-1)*dly for j=1,2,...,n+1 where
!                          dly=(d-c)/n is the panel width. in addition,
!                          n must be greater than 4.
!
!                        nbdcnd
!                          indicates the types of boundary conditions
!                          at y=c and y=d
!                          = 0 if the solution is periodic in y, i.e.,
!                              u(x,y+d-c)=u(x,y) for all x,y
!                          = 1 if the solution is specified at y=c and
!                              y = d, i.e., u(x,c) and u(x,d) are
!                              specified for all x
!                          = 2 if the solution is specified at y=c and
!                              the boundary condition is mixed at y=d,
!                              i.e., u(x,c) and du(x,d)/dy+xnu*u(x,d)
!                              are specified for all x
!                          = 3 if the boundary conditions are mixed at
!                              y=c and y=d, i.e., du(x,d)/dy+gama*u(x,c)
!                              and du(x,d)/dy+xnu*u(x,d) are specified
!                              for all x
!                          = 4 if the boundary condition is mixed at y=c
!                              and the solution is specified at y=d,
!                              i.e. du(x,c)/dy+gama*u(x,c) and u(x,d)
!                              are specified for all x
!
!                        bdc
!                          a one-dimensional array of length m+1 that
!                          specifies the value of du(x,c)/dy+gama*u(x,c)
!                          at y=c.  when nbdcnd=3 or 4
!                             bdc(i) = du(xi,c)/dy + gama*u(xi,c),
!                             i=1,2,...,m+1.
!                          when nbdcnd has any other value, bdc is a
!                          dummy parameter.
!
!                        gama
!                          the scalar multiplying the solution in case
!                          of a mixed boundary condition at y=c (see
!                          argument bdc). if nbdcnd/=3,4 then gama is
!                          a dummy parameter.
!
!                        bdd
!                          a one-dimensional array of length m+1 that
!                          specifies the value of du(x,d)/dy +
!                          xnu*u(x,d) at y=c.  when nbdcnd=2 or 3
!                            bdd(i) = du(xi,d)/dy + xnu*u(xi,d),
!                            i=1,2,...,m+1.
!                          when nbdcnd has any other value, bdd is a
!                          dummy parameter.
!
!                        xnu
!                          the scalar multiplying the solution in case
!                          of a mixed boundary condition at y=d (see
!                          argument bdd). if nbdcnd/=2 or 3 then xnu
!                          is a dummy parameter.
!
!                        cofx
!                          a user-supplied subprogram with
!                          parameters x, afun, bfun, cfun which
!                          returns the values of the x-dependent
!                          coefficients af(x), bf(x), cf(x) in
!                          the elliptic equation at x.
!
!                        cofy
!                          a user-supplied subprogram with
!                          parameters y, dfun, efun, ffun which
!                          returns the values of the y-dependent
!                          coefficients df(y), ef(y), ff(y) in
!                          the elliptic equation at y.
!
!                        note.  cofx and cofy must be declared external
!                        in the calling routine. the values returned in
!                        afun and dfun must satisfy afun*dfun greater
!                        than 0 for a less than x less than b,
!                        c less than y less than d (see ierror=10).
!                        the coefficients provided may lead to a matrix
!                        equation which is not diagonally dominant in
!                        which case solution may fail (see ierror=4).
!
!                        grhs
!                          a two-dimensional array that specifies the
!                          values of the right-hand side of the elliptic
!                          equation, i.e., grhs(i,j)=g(xi,yi), for
!                          i=2,...,m, j=2,...,n.  at the boundaries,
!                          grhs is defined by
!
!                          mbdcnd   grhs(1,j)   grhs(m+1,j)
!
!                            0      g(a,yj)     g(b,yj)
!                            1         *           *
!                            2         *        g(b,yj)  j=1,2,...,n+1
!                            3      g(a,yj)     g(b,yj)
!                            4      g(a,yj)        *
!
!                          nbdcnd   grhs(i,1)   grhs(i,n+1)
!
!                            0      g(xi,c)     g(xi,d)
!                            1         *           *
!                            2         *        g(xi,d)  i=1,2,...,m+1
!                            3      g(xi,c)     g(xi,d)
!                            4      g(xi,c)        *
!
!                          where * means these quantites are not used.
!                          grhs should be dimensioned mn by at least
!                          n+1 in the calling routine.
!
!                        mn
!                          the row (or first) dimension of the array
!                          grhs as it appears in the program calling
!                          sepell. mn must be at least 7 and greater
!                          than or equal to m+1.
!
!                        usol
!                          a two-dimensional array that specifies the
!                          values of the solution along the boundaries.
!                          at the boundaries, usol is defined by
!
!                          mbdcnd   usol(1,j)   usol(m+1,j)
!
!                            0         *           *
!                            1      u(a,yj)     u(b,yj)
!                            2      u(a,yj)        *     j=1,2,...,n+1
!                            3         *           *
!                            4         *        u(b,yj)
!
!                          nbdcnd   usol(i,1)   usol(i,n+1)
!
!                            0         *           *
!                            1      u(xi,c)     u(xi,d)
!                            2      u(xi,c)        *     i=1,2,...,m+1
!                            3         *           *
!                            4         *        u(xi,d)
!
!                          where * means the quantites are not used in
!                          the solution.
!
!                          if iorder=2 and idmn=mn, then the user may
!                          equivalence grhs and usol. note that in this
!                          case the tables specifying the boundaries of
!                          the grhs and usol arrays determine the
!                          boundaries uniquely except at the corners.
!                          if the tables call for both g(x,y) and
!                          u(x,y) at a corner then the solution must be
!                          chosen.  for example, if mbdcnd=2 and
!                          nbdcnd=4, then u(a,c), u(a,d), u(b,d) must be
!                          chosen at the corners in addition to g(b,c).
!
!                          if iorder=4, then the two arrays, usol and
!                          grhs, must be distinct.
!
!                          usol should be dimensioned idmn by at least
!                          n+1 in the calling routine.
!
!                        idmn
!                          the row (or first) dimension of the array
!                          usol as it appears in the program calling
!                          sepell. idmn must be at least 7 and greater
!                          than or equal to m+1.
!
!                        w
!                          a one-dimensional array that must be provided
!                          by the user for work space.  let
!                          k=int(log2(n+1))+1 and set  l=2**(k+1).
!                          then (k-2)*l+k+10*n+12*m+27 will suffice
!                          as a length of w.  the actual length of w in
!                          the calling routine must be set in w(1) (see
!                          ierror=11).
!
! on output              usol
!                          contains the approximate solution to the
!                          elliptic equation.  usol(i,j) is the
!                          approximation to u(xi,yj) for i=1,2...,m+1
!                          and j=1,2,...,n+1.  the approximation has
!                          error o(dlx**2+dly**2) if called with
!                          iorder=2 and o(dlx**4+dly**4) if called with
!                          iorder=4.
!
!                        w
!                          contains intermediate values that must not be
!                          destroyed if sepell is called again with
!                          intl=1.  in addition w(1) contains the exact
!                          minimal length (in floating point) required
!                          for the work space (see ierror=11).
!
!                        pertrb
!                          if a combination of periodic or derivative
!                          boundary conditions (i.e., alpha=beta=0 if
!                          mbdcnd=3, gama=xnu=0 if nbdcnd=3) is
!                          specified and if the coefficients of u(x,y)
!                          in the separable elliptic equation are zero
!                          (i.e., cf(x)=0 for x greater than or equal to
!                          a and less than or equal to b, ff(y)=0 for
!                          y greater than or equal to c and less than
!                          or equal to d) then a solution may not exist.
!                          pertrb is a constant calculated and
!                          subtracted from the right-hand side of the
!                          matrix equations generated by sepell which
!                          insures that a solution exists.  sepell then
!                          computes this solution which is a weighted
!                          minimal least squares solution to the
!                          original problem.
!
!                        ierror
!                          an error flag that indicates invalid input
!                          parameters or failure to find a solution
!                          = 0 no error
!                          = 1 if a greater than b or c greater than d
!                          = 2 if mbdcnd less than 0 or mbdcnd greater
!                              than 4
!                          = 3 if nbdcnd less than 0 or nbdcnd greater
!                              than 4
!                          = 4 if attempt to find a solution fails.
!                              (the linear system generated is not
!                              diagonally dominant.)
!                          = 5 if idmn or mn is too small.
!                          = 6 if m is too small or too large (see
!                              discussion of m)
!                          = 7 if n is too small (see discussion of n)
!                          = 8 if iorder is not 2 or 4
!                          = 9 if intl is not 0 or 1
!                          = 10 if afun*dfun less than or equal to 0 for
!                               some interior mesh point (xi,yj)
!                          = 11 if the work space length input in w(1)
!                               is less than the exact minimal work
!                               space length required output in w(1).
!
!                          note (concerning ierror=4).  for the
!                          coefficients input through cofx, cofy, the
!                          discretization may lead to a block
!                          tridiagonal linear system which is not
!                          diagonally dominant (for example, this
!                          happens if cfun=0 and bfun/(2.*dlx) greater
!                          than afun/dlx**2).  in this case solution may
!                          fail.  this cannot happen in the limit as
!                          dlx, dly approach zero.  hence, the condition
!                          may be remedied by taking larger values for m
!                          or n.
!
! entry points           sepell, sepel1, chkprm, chksng, orthg, minsol,
!                        trisp, defer, dxfn, dyfn, blktri, blktr1,indxb,
!                        indxa, indxc, prod0, prodp, cprod0, cprodp,
!                        ppadd, psgf, bsrh, ppsgf, ppspf, compb,
!                        tqlrt0
!
! special conditions     none
!
! common blocks          splp, cblkt
!
! i/o                    none
!
! precision              single
!
! specialist             john c. adams, ncar, boulder, colorado  80307
!
! history                developed at ncar during 1975-76.
!
! algorithm              sepell automatically discretizes the separable
!                        elliptic equation which is then solved by a
!                        generalized cyclic reduction algorithm in the
!                        subroutine, blktri.  the fourth-order solution
!                        is obtained using deferred corrections, which
!                        is described and referenced in sections,
!                        references and method.
!
! accuracy and timing    the following computational results were
!                        obtained by solving the sample problem at the
!                        end of this write-up on the control data 7600.
!                        the op count is proportional to m*n*log2(n).
!                        in contrast to the other routines in this
!                        chapter, accuracy is tested by computing and
!                        tabulating second- and fourth-order
!                        discretization errors.  below is a table
!                        containing computational results.  the times
!                        given do not include initialization (i.e.,
!                        times are for intl=1).  note that the
!                        fourth-order accuracy is not realized until the
!                        mesh is sufficiently refined.
!
!              second-order    fourth-order   second-order  fourth-order
!    m    n   execution time  execution time    error         error
!               (m sec)         (m sec)
!     6    6         6              14          6.8e-1        1.2e0
!    14   14        23              58          1.4e-1        1.8e-1
!    30   30       100             247          3.2e-2        9.7e-3
!    62   62       445           1,091          7.5e-3        3.0e-4
!   126  126     2,002           4,772          1.8e-3        3.5e-6
!
!
! references             keller, h.b., numerical methods for two-point
!                          boundary-value problems, blaisdel (1968),
!                          waltham, mass.
!
!                        swarztrauber, p., and r. sweet (1975),
!                          efficient fortran subprograms for the
!                          solution of elliptic partial differential
!                          equations.  ncar technical note
!                          ncar-tn/ia-109, pp. 135-137.
!
!
!
  real grhs(mn,*), usol(idmn,*)
  real bda(*), bdb(*), bdc(*), bdd(*), w(*)
  external cofx, cofy
!
!
!     check input parameters
!
  call chkprm (intl,iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,cofy, &
               idmn,mn,ierror)
  if (ierror /= 0) return
!
!     compute minimum work space and check work space length input
!
  l = n+1
  if (nbdcnd == 0) l = n
  logb2n = int(alog(real(l)+0.5)/alog(2.0))+1
  ll = 2**(logb2n+1)
  k = m+1
  l = n+1
  length = (logb2n-2)*ll+logb2n+max (2*l,6*k)+5
  if (nbdcnd == 0) length = length+2*l
  ierror = 11
  linput = int(w(1)+0.5)
  loutpt = length+6*(k+l)+1
  w(1) = real(loutpt)
  if (loutpt > linput) return
  ierror = 0
!
!     set work space indices
!
  i1 = length+2
  i2 = i1+l
  i3 = i2+l
  i4 = i3+l
  i5 = i4+l
  i6 = i5+l
  i7 = i6+l
  i8 = i7+k
  i9 = i8+k
  i10 = i9+k
  i11 = i10+k
  i12 = i11+k
  i13 = 2
  call sepel1 (intl,iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, &
               nbdcnd,bdc,gama,bdd,xnu,cofx,cofy,w(i1),w(i2),w(i3), &
               w(i4),w(i5),w(i6),w(i7),w(i8),w(i9),w(i10),w(i11), &
               w(i12),grhs,mn,usol,idmn,w(i13),pertrb,ierror)
  return
end
subroutine seval (x,y,a,b,c,n,xi,yi,ypi,yppi,ni,ierr)
!
!*******************************************************************************
!
!! SEVAL evaluates a cubic spline and its first and second derivatives
!  at the abscissas in xi.  it is assumed that
!         the coefficients of the polynomials which form the spline
!         are provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of the first n abscissas (in increasing order)
!               that define the spline.
!         y   - array of the first n ordinates that define the spline.
!         a,b,c arrays that contain the coefficients of the polynomials
!               which form the spline. if i = 1,...,n  then the spline
!               has the value
!                    y(i) + a(i)*dx + b(i)*dx**2 + c(i)*dx**3
!               for x(i) <= xx <= x(i+1).  here dx = xx-x(i).
!         n   - the number of polynomials that define the spline.
!               the arrays x, y, a, b, c  must be dimensioned at
!               least n.  n must be greater than or equal to 1.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1, then xi, yi, ypi,
!               and yppi must be arrays dimensioned at least ni.
!               ni must be greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ypi - array of values of the first derivative of spline at xi.
!         yppi- array of values of second derivatives of spline at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n),y(n),a(n),b(n),c(n),xi(ni),yi(ni),ypi(ni),yppi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  il = 1
  ir = n
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = n
  go to 100
   90 i = 1
!
!     evaluation
!
  100 dx = xx - x(i)
  yi(k) = y(i) + dx*(a(i) + dx*(b(i) + dx*c(i)))
  bi = b(i) + b(i)
  ci = 3.0*c(i)
  ypi(k) = a(i) + dx*(bi + dx*ci)
  yppi(k) = bi + dx*(ci + ci)
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(n)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,n)
  go to 10
end
subroutine seval1 (x,y,yp,n,xi,yi,ypi,yppi,ni,ierr)
!
!*******************************************************************************
!
!! SEVAL1 evaluates a cubic spline and its first and second derivatives
!  at the abscissas in xi.  it is assumed that
!         the first derivatives at the nodes have been provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of abscissas (in increasing order) that define the
!               spline.
!         y   - array of ordinates that define the spline.
!         yp  - array of first derivatives that define the spline.
!         n   - the number of data points that define the spline.
!               the arrays x, y, and yp must be dimensioned at least n.
!               n must be greater than or equal to 2.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1, then xi, yi, ypi,
!               and yppi must be arrays dimensioned at least ni.
!               ni must be greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ypi - array of values of the first derivative of spline at xi.
!         yppi- array of values of second derivatives of spline at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n),y(n),yp(n),xi(ni),yi(ni),ypi(ni),yppi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
  nm1 = n - 1
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  il = 1
  ir = nm1
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = nm1
  go to 100
   90 i = 1
!
!     evaluation
!
  100 h = x(i+1) - x(i)
  d = (y(i+1) - y(i))/h
  a = yp(i) + yp(i+1)
  b = (-a - yp(i) + 3.0*d)/h
  c = (a - d - d)/(h*h)
  dx = xx - x(i)
  yi(k) = y(i) + dx*(yp(i) + dx*(b + dx*c))
  b = b + b
  c = 3.0*c
  ypi(k) = yp(i) + dx*(b + dx*c)
  yppi(k) = b + dx*(c + c)
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,nm1)
  go to 10
end
subroutine seval2 (x,y,ypp,n,xi,yi,ypi,yppi,ni,ierr)
!
!*******************************************************************************
!
!! SEVAL2 evaluates a cubic spline and its first and second derivatives
!  at the abscissas in xi.  it is assumed that
!         the second derivatives at the nodes have been provided.
!
!     description of arguments
!
!       --input--
!
!         x   - array of abscissas (in increasing order) that define the
!               spline.
!         y   - array of ordinates that define the spline.
!         ypp - array of second derivatives that define the spline.
!         n   - the number of data points that define the spline.
!               the arrays x, y, and ypp must be dimensioned at least n.
!               n must be greater than or equal to 2.
!         xi  - the abscissa or array of abscissas (in arbitrary order)
!               at which the spline is to be evaluated.
!         ni  - the number of abscissas at which the spline is to be
!               evaluated.  if ni is greater than 1, then xi, yi, ypi,
!               and yppi must be arrays dimensioned at least ni.
!               ni must be greater than or equal to 1.
!
!       --output--
!
!         yi  - array of values of the spline (ordinates) at xi.
!         ypi - array of values of the first derivative of spline at xi.
!         yppi- array of values of second derivatives of spline at xi.
!         ierr- status code
!               0  the spline was evaluated at each abscissa in xi.
!               1  input error - ni is not positive.
!
  real x(n),y(n),ypp(n),xi(ni),yi(ni),ypi(ni),yppi(ni)
!
!     check input
!
  if (ni > 0) go to 1
     ierr = 1
     return
1 ierr = 0
  nm1 = n - 1
!
!     k is index on value of xi being worked on.  xx is that value.
!     i is current index into x array.
!
  k  = 1
  xx = xi(1)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  il = 1
  ir = nm1
!
!     bisection search
!
   10 i = (il + ir)/2
  if (i == il) go to 100
  if (xx - x(i)) 20,100,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     linear forward search
!
   50 if (xx < x(i+1)) go to 100
  i = i + 1
  go to 50
!
!     xx is greater than x(n) or less than x(1)
!
   80 i = nm1
  go to 100
   90 i = 1
!
!     evaluation
!
  100 h  = x(i+1) - x(i)
  h2 = h*h
  xr = (x(i+1) - xx)/h
  xr2 = xr*xr
  xr3 = xr*xr2
  xl = (xx - x(i))/h
  xl2 = xl*xl
  xl3 = xl*xl2
  yi(k) = y(i)*xr + y(i+1)*xl &
         - h2*(ypp(i)*(xr-xr3) + ypp(i+1)*(xl-xl3))/6.0
  ypi(k) = (y(i+1)-y(i))/h &
          + h*(ypp(i)*(1.0-3.0*xr2) - ypp(i+1)*(1.0-3.0*xl2))/6.0
  yppi(k) = ypp(i)*xr + ypp(i+1)*xl
!
!     next point
!
  if (k >= ni) return
  k = k + 1
  xx = xi(k)
  if (xx < x(1)) go to 90
  if (xx >= x(nm1)) go to 80
  if (xx - xi(k-1)) 110,100,50
  110 il = 1
  ir = min (i+1,nm1)
  go to 10
end
subroutine sfft(a,b,ntot,n,nspan,isn,ierr)
!
!*******************************************************************************
!
!! SFFT: multivariate complex fourier transform, computed in place
!    using mixed-radix fast fourier transform algorithm.
!  by r. c. singleton, stanford research institute, oct. 1968
!    modified by a. h. morris, nswc/dl, dahlgren va
!  arrays a and b originally hold the real and imaginary
!    components of the data, and return the real and
!    imaginary components of the resulting fourier coefficients.
!  multivariate data is indexed according to the fortran
!    array element successor function, without limit
!    on the number of implied multiple subscripts.
!    the subroutine is called once for each variate.
!    the calls for a multivariate transform may be in any order.
!  ntot is the total number of complex data values.
!  n is the dimension of the current variable.
!  nspan/n is the spacing of consecutive data values
!    while indexing the current variable.
!  the sign of isn determines the sign of the complex
!    exponential, and the magnitude of isn is normally one.
!  a tri-variate transform with a(n1,n2,n3), b(n1,n2,n3)
!    is computed by
!      call sfft(a,b,n1*n2*n3,n1,n1,1,ierr)
!      call sfft(a,b,n1*n2*n3,n2,n1*n2,1,ierr)
!      call sfft(a,b,n1*n2*n3,n3,n1*n2*n3,1,ierr)
!  for a single-variate transform,
!    ntot = n = nspan = (number of complex data values), e.g.
!      call sfft(a,b,n,n,n,1,ierr)
!  the data may alternatively be stored in a single complex
!    array a, then the magnitude of isn changed to two to
!    give the correct indexing increment and a(2) used to
!    pass the initial address for the sequence of imaginary
!    values, e.g.
!      call sfft(a,a(2),ntot,n,nspan,2,ierr)
!  arrays nfac(maxn),np(maxp),at(maxf),ck(maxf),bt(maxf),sk(maxf)
!    are used for temporary storage.
!    maxn must be >= the number of factors of n
!    maxf must be >= the maximum prime factor of n.
!    maxp must be > the number of prime factors of n.
!    in addition, maxn is assumed to be odd.
!    if the square-free portion k of n has two or more prime
!    factors, then maxp must be >= k-1.
!  ierr is a variable. ierr is set to 0 if no input errors are
!    detected. otherwise, ierr is assigned one of the values
!      ierr=1    n is less than 1
!      ierr=2    n has more than maxn factors
!      ierr=3    n has a prime factor greater than
!                maxf or the square-free portion of
!                n is greater than maxp+1
  dimension a(*),b(*)
!  array storage in nfac for a maximum of 15 factors of n.
!  if n has more than one square-free factor, the product of the
!    square-free factors must be <= 210
  dimension nfac(15),np(209)
!  array storage for maximum prime factor of 23
  dimension at(23),ck(23),bt(23),sk(23)
  equivalence (i,ii)
!  the following constants should agree with the array dimensions.
  maxn=15
  maxf=23
  maxp=209
!  set the following constants
!     rad=2.0*pi
!     s72=sin(rad/5.0)
!     c72=cos(rad/5.0)
!     s120=sqrt(0.75)
  rad=6.2831853071796
  s72=.951056516295154
  c72=.309016994374947
  s120=.86602540378444
!
  ierr=0
  if(n-1) 1000,960,5
5 inc=isn
  if(isn >= 0) go to 10
  s72=-s72
  s120=-s120
  rad=-rad
  inc=-inc
   10 nt=inc*ntot
  ks=inc*nspan
  kspan=ks
  nn=nt-inc
  jc=ks/n
  radf=rad*real(jc)*0.5
  i=0
  jf=0
!  determine the factors of n
  m=0
  k=n
  max=maxn/2
  go to 20
   15 if(m == max) go to 1001
  m=m+1
  nfac(m)=4
  k=l
   20 l=k/16
  if(k == l*16) go to 15
  j=3
  jj=9
  go to 30
   25 if(m == max) go to 1001
  m=m+1
  nfac(m)=j
  k=k/jj
   30 if(mod(k,jj) == 0) go to 25
  j=j+2
  jj=j**2
  if(j <= maxf .and. jj <= k) go to 30
  if(k > 4) go to 40
  kt=m
  nfac(m+1)=k
  if(k /= 1) m=m+1
  go to 80
   40 l=k/4
  if(k /= l*4) go to 50
  if(m == max) go to 1001
  m=m+1
  nfac(m)=2
  k=l
  kt=m
  if(k == 1) go to 85
   50 kt=m
  if(k-1 > maxp) go to 1002
  num=maxn-kt-kt
  j=2
   60 if(mod(k,j) /= 0) go to 70
  m=m+1
  nfac(m)=j
  num=num-1
  k=k/j
  if(k == 1) go to 80
  if(num <= 0) go to 1001
   70 l=(j+1)/2
  j=l+l+1
  if(j <= maxf) go to 60
  go to 1002
   80 if(kt == 0) go to 100
   85 j=kt
   90 m=m+1
  nfac(m)=nfac(j)
  j=j-1
  if(j /= 0) go to 90
!  compute fourier transform
  100 sd=radf/real(kspan)
  cd=2.0*sin(sd)**2
  sd=sin(sd+sd)
  kk=1
  i=i+1
  if(nfac(i) /= 2) go to 400
!  transform for factor of 2 (including rotation factor)
  kspan=kspan/2
  k1=kspan+2
  210 k2=kk+kspan
  ak=a(k2)
  bk=b(k2)
  a(k2)=a(kk)-ak
  b(k2)=b(kk)-bk
  a(kk)=a(kk)+ak
  b(kk)=b(kk)+bk
  kk=k2+kspan
  if(kk <= nn) go to 210
  kk=kk-nn
  if(kk <= jc) go to 210
  if(kk > kspan) go to 800
  220 c1=1.0-cd
  s1=sd
  230 k2=kk+kspan
  ak=a(kk)-a(k2)
  bk=b(kk)-b(k2)
  a(kk)=a(kk)+a(k2)
  b(kk)=b(kk)+b(k2)
  a(k2)=c1*ak-s1*bk
  b(k2)=s1*ak+c1*bk
  kk=k2+kspan
  if(kk < nt) go to 230
  k2=kk-nt
  c1=-c1
  kk=k1-k2
  if(kk > k2) go to 230
  u=sd*s1+cd*c1
  v=sd*c1-cd*s1
  ak=c1-u
  s1=s1+v
!  the following three statements compensate for truncation error.
!    if rounded arithmetic is used then one may substitute
!     c1=ak
  c1=1.5-0.5*(ak*ak+s1*s1)
  s1=c1*s1
  c1=c1*ak
  kk=kk+jc
  if(kk < k2) go to 230
  k1=k1+inc+inc
  kk=(k1-kspan)/2+jc
  if(kk <= jc+jc) go to 220
  go to 100
!  transform for factor of 3 (optional code)
  320 k1=kk+kspan
  k2=k1+kspan
  ak=a(kk)
  bk=b(kk)
  aj=a(k1)+a(k2)
  bj=b(k1)+b(k2)
  a(kk)=ak+aj
  b(kk)=bk+bj
  ak=-0.5*aj+ak
  bk=-0.5*bj+bk
  aj=(a(k1)-a(k2))*s120
  bj=(b(k1)-b(k2))*s120
  a(k1)=ak-bj
  b(k1)=bk+aj
  a(k2)=ak+bj
  b(k2)=bk-aj
  kk=k2+kspan
  if(kk < nn) go to 320
  kk=kk-nn
  if(kk <= kspan) go to 320
  go to 700
!  transform for factor of 4
  400 if(nfac(i) /= 4) go to 600
  kspnn=kspan
  kspan=kspan/4
  410 c1=1.0
  s1=0.0
  420 k1=kk+kspan
  k2=k1+kspan
  k3=k2+kspan
  akp=a(kk)+a(k2)
  akm=a(kk)-a(k2)
  ajp=a(k1)+a(k3)
  ajm=a(k1)-a(k3)
  a(kk)=akp+ajp
  ajp=akp-ajp
  bkp=b(kk)+b(k2)
  bkm=b(kk)-b(k2)
  bjp=b(k1)+b(k3)
  bjm=b(k1)-b(k3)
  b(kk)=bkp+bjp
  bjp=bkp-bjp
  if(isn < 0) go to 450
  akp=akm-bjm
  akm=akm+bjm
  bkp=bkm+ajm
  bkm=bkm-ajm
  if(s1 == 0.0) go to 460
  430 a(k1)=akp*c1-bkp*s1
  b(k1)=akp*s1+bkp*c1
  a(k2)=ajp*c2-bjp*s2
  b(k2)=ajp*s2+bjp*c2
  a(k3)=akm*c3-bkm*s3
  b(k3)=akm*s3+bkm*c3
  kk=k3+kspan
  if(kk <= nt) go to 420
  440 u=sd*s1+cd*c1
  v=sd*c1-cd*s1
  c2=c1-u
  s1=s1+v
!  the following three statements compensate for truncation error.
!    if rounded arithmetic is used then one may substitute
!     c1=c2
  c1=1.5-0.5*(c2*c2+s1*s1)
  s1=c1*s1
  c1=c1*c2
  c2=c1*c1-s1*s1
  s2=2.0*c1*s1
  c3=c2*c1-s2*s1
  s3=c2*s1+s2*c1
  kk=kk-nt+jc
  if(kk <= kspan) go to 420
  kk=kk-kspan+inc
  if(kk <= jc) go to 410
  if(kspan == jc) go to 800
  go to 100
  450 akp=akm+bjm
  akm=akm-bjm
  bkp=bkm-ajm
  bkm=bkm+ajm
  if(s1 /= 0.0) go to 430
  460 a(k1)=akp
  b(k1)=bkp
  a(k2)=ajp
  b(k2)=bjp
  a(k3)=akm
  b(k3)=bkm
  kk=k3+kspan
  if(kk <= nt) go to 420
  go to 440
!  transform for factor of 5 (optional code)
  510 c2=c72**2-s72**2
  s2=2.0*c72*s72
  520 k1=kk+kspan
  k2=k1+kspan
  k3=k2+kspan
  k4=k3+kspan
  akp=a(k1)+a(k4)
  akm=a(k1)-a(k4)
  bkp=b(k1)+b(k4)
  bkm=b(k1)-b(k4)
  ajp=a(k2)+a(k3)
  ajm=a(k2)-a(k3)
  bjp=b(k2)+b(k3)
  bjm=b(k2)-b(k3)
  aa=a(kk)
  bb=b(kk)
  a(kk)=aa+akp+ajp
  b(kk)=bb+bkp+bjp
  ak=akp*c72+ajp*c2+aa
  bk=bkp*c72+bjp*c2+bb
  aj=akm*s72+ajm*s2
  bj=bkm*s72+bjm*s2
  a(k1)=ak-bj
  a(k4)=ak+bj
  b(k1)=bk+aj
  b(k4)=bk-aj
  ak=akp*c2+ajp*c72+aa
  bk=bkp*c2+bjp*c72+bb
  aj=akm*s2-ajm*s72
  bj=bkm*s2-bjm*s72
  a(k2)=ak-bj
  a(k3)=ak+bj
  b(k2)=bk+aj
  b(k3)=bk-aj
  kk=k4+kspan
  if(kk < nn) go to 520
  kk=kk-nn
  if(kk <= kspan) go to 520
  go to 700
!  transform for odd factors
  600 k=nfac(i)
  kspnn=kspan
  kspan=kspan/k
  if(k == 3) go to 320
  if(k == 5) go to 510
  if(k == jf) go to 640
  jf=k
  s1=rad/real(k)
  c1=cos(s1)
  s1=sin(s1)
  ck(jf)=1.0
  sk(jf)=0.0
  j=1
  630 ck(j)=ck(k)*c1+sk(k)*s1
  sk(j)=ck(k)*s1-sk(k)*c1
  k=k-1
  ck(k)=ck(j)
  sk(k)=-sk(j)
  j=j+1
  if(j < k) go to 630
  640 k1=kk
  k2=kk+kspnn
  aa=a(kk)
  bb=b(kk)
  ak=aa
  bk=bb
  j=1
  k1=k1+kspan
  650 k2=k2-kspan
  j=j+1
  at(j)=a(k1)+a(k2)
  ak=at(j)+ak
  bt(j)=b(k1)+b(k2)
  bk=bt(j)+bk
  j=j+1
  at(j)=a(k1)-a(k2)
  bt(j)=b(k1)-b(k2)
  k1=k1+kspan
  if(k1 < k2) go to 650
  a(kk)=ak
  b(kk)=bk
  k1=kk
  k2=kk+kspnn
  j=1
  660 k1=k1+kspan
  k2=k2-kspan
  jj=j
  ak=aa
  bk=bb
  aj=0.0
  bj=0.0
  k=1
  670 k=k+1
  ak=at(k)*ck(jj)+ak
  bk=bt(k)*ck(jj)+bk
  k=k+1
  aj=at(k)*sk(jj)+aj
  bj=bt(k)*sk(jj)+bj
  jj=jj+j
  if(jj > jf) jj=jj-jf
  if(k < jf) go to 670
  k=jf-j
  a(k1)=ak-bj
  b(k1)=bk+aj
  a(k2)=ak+bj
  b(k2)=bk-aj
  j=j+1
  if(j < k) go to 660
  kk=kk+kspnn
  if(kk <= nn) go to 640
  kk=kk-nn
  if(kk <= kspan) go to 640
!  multiply by rotation factor (except for factors of 2 and 4)
  700 if(i == m) go to 800
  kk=jc+1
  710 c2=1.0-cd
  s1=sd
  720 c1=c2
  s2=s1
  kk=kk+kspan
  730 ak=a(kk)
  a(kk)=c2*ak-s2*b(kk)
  b(kk)=s2*ak+c2*b(kk)
  kk=kk+kspnn
  if(kk <= nt) go to 730
  ak=s1*s2
  s2=s1*c2+c1*s2
  c2=c1*c2-ak
  kk=kk-nt+kspan
  if(kk <= kspnn) go to 730
  u=sd*s1+cd*c1
  v=sd*c1-cd*s1
  c2=c1-u
  s1=s1+v
!  the following three statements compensate for truncation
!    error.  if rounded arithmetic is used then they may
!    be deleted.
  c1=1.5-0.5*(c2*c2+s1*s1)
  s1=c1*s1
  c2=c1*c2
  kk=kk-kspnn+jc
  if(kk <= kspan) go to 720
  kk=kk-kspan+jc+inc
  if(kk <= jc+jc) go to 710
  go to 100
!  permute the results to normal order---done in two stages
!  permutation for square factors of n
  800 np(1)=ks
  if(kt == 0) go to 890
  k=kt+kt+1
  if(m < k) k=k-1
  j=1
  np(k+1)=jc
  810 np(j+1)=np(j)/nfac(j)
  np(k)=np(k+1)*nfac(j)
  j=j+1
  k=k-1
  if(j < k) go to 810
  k3=np(k+1)
  kspan=np(2)
  kk=jc+1
  k2=kspan+1
  j=1
  if(n /= ntot) go to 850
!  permutation for single-variate transform (optional code)
  820 ak=a(kk)
  a(kk)=a(k2)
  a(k2)=ak
  bk=b(kk)
  b(kk)=b(k2)
  b(k2)=bk
  kk=kk+inc
  k2=kspan+k2
  if(k2 < ks) go to 820
  830 k2=k2-np(j)
  j=j+1
  k2=np(j+1)+k2
  if(k2 > np(j)) go to 830
  j=1
  840 if(kk < k2) go to 820
  kk=kk+inc
  k2=kspan+k2
  if(k2 < ks) go to 840
  if(kk < ks) go to 830
  jc=k3
  go to 890
!  permutation for multivariate transform
  850 k=kk+jc
  860 ak=a(kk)
  a(kk)=a(k2)
  a(k2)=ak
  bk=b(kk)
  b(kk)=b(k2)
  b(k2)=bk
  kk=kk+inc
  k2=k2+inc
  if(kk < k) go to 860
  kk=kk+ks-jc
  k2=k2+ks-jc
  if(kk < nt) go to 850
  k2=k2-nt+kspan
  kk=kk-nt+jc
  if(k2 < ks) go to 850
  870 k2=k2-np(j)
  j=j+1
  k2=np(j+1)+k2
  if(k2 > np(j)) go to 870
  j=1
  880 if(kk < k2) go to 850
  kk=kk+jc
  k2=kspan+k2
  if(k2 < ks) go to 880
  if(kk < ks) go to 870
  jc=k3
  890 if(2*kt+1 >= m) return
  kspnn=np(kt+1)
!  permutation for square-free factors of n
  j=m-kt
  nfac(j+1)=1
  900 nfac(j)=nfac(j)*nfac(j+1)
  j=j-1
  if(j /= kt) go to 900
  kt=kt+1
  nn=nfac(kt)-1
  jj=0
  j=0
  go to 906
  902 jj=jj-k2
  k2=kk
  k=k+1
  kk=nfac(k)
  904 jj=kk+jj
  if(jj >= k2) go to 902
  np(j)=jj
  906 k2=nfac(kt)
  k=kt+1
  kk=nfac(k)
  j=j+1
  if(j <= nn) go to 904
!  determine the permutation cycles of length greater than 1
  j=0
  go to 914
  910 k=kk
  kk=np(k)
  np(k)=-kk
  if(kk /= j) go to 910
  k3=kk
  914 j=j+1
  kk=np(j)
  if(kk < 0) go to 914
  if(kk /= j) go to 910
  np(j)=-j
  if(j /= nn) go to 914
  maxf=inc*maxf
!  reorder a and b, following the permutation cycles
  go to 950
  924 j=j-1
  if(np(j) < 0) go to 924
  jj=jc
  926 kspan=jj
  if(jj > maxf) kspan=maxf
  jj=jj-kspan
  k=np(j)
  kk=jc*k+ii+jj
  k1=kk+kspan
  k2=0
  928 k2=k2+1
  at(k2)=a(k1)
  bt(k2)=b(k1)
  k1=k1-inc
  if(k1 /= kk) go to 928
  932 k1=kk+kspan
  k2=k1-jc*(k+np(k))
  k=-np(k)
  936 a(k1)=a(k2)
  b(k1)=b(k2)
  k1=k1-inc
  k2=k2-inc
  if(k1 /= kk) go to 936
  kk=k2
  if(k /= j) go to 932
  k1=kk+kspan
  k2=0
  940 k2=k2+1
  a(k1)=at(k2)
  b(k1)=bt(k2)
  k1=k1-inc
  if(k1 /= kk) go to 940
  if(jj /= 0) go to 926
  if(j /= 1) go to 924
  950 j=k3+1
  nt=nt-kspnn
  ii=nt-inc+1
  if(nt >= 0) go to 924
  960 return
!  error finish - there is an input error
 1000 ierr=1
  return
 1001 ierr=2
  return
 1002 ierr=3
  return
end
subroutine sfode (f,neq,y,t,tout,info,rerr,aerr,idid, &
                    rwork,lrw,iwork,liw,rpar,ipar)
!
!*******************************************************************************
!
!! SFODE ???
!
  external f, zzzjac
  real y(neq), rtol(1), atol(1), rwork(lrw), rpar(*)
  integer info(*), info1(15), iwork(liw), ipar(*)
!
  info1(1) = info(1)
  info1(2) = 0
  info1(3) = info(2)
  info1(4) = info(3)
  info1(5) = 0
  info1(6) = info(4)
!
  rtol(1) = rerr
  atol(1) = aerr
  call stfode (f,neq,y,t,tout,info1,rtol,atol,idid, &
               rwork,lrw,iwork,liw,rpar,ipar,zzzjac)
  info(1) = info1(1)
  rerr = rtol(1)
  aerr = atol(1)
  return
end
subroutine sfode1 (f,neq,y,t,tout,info,rtol,atol,idid, &
                     rwork,lrw,iwork,liw,rpar,ipar)
!
!*******************************************************************************
!
!! SFODE1 ???
!
  external f, zzzjac
  real y(neq), rtol(neq), atol(neq), rwork(lrw), rpar(*)
  integer info(*), info1(15), iwork(liw), ipar(*)
!
  info1(1) = info(1)
  info1(2) = 1
  info1(3) = info(2)
  info1(4) = info(3)
  info1(5) = 0
  info1(6) = info(4)
!
  call stfode (f,neq,y,t,tout,info1,rtol,atol,idid, &
               rwork,lrw,iwork,liw,rpar,ipar,zzzjac)
  info(1) = info1(1)
  return
end
subroutine sgbfa ( abd, lda, n, ml, mu, ipvt, info )
!
!*******************************************************************************
!
!! SGBFA factors a real band matrix by elimination.
!
!
!  Discussion:
!
!    SGBFA is usually called by SGBCO, but it can be called
!    directly with a saving in time if RCOND is not needed.
!
!  Parameters:
!
!    Input/output, real ABD(LDA,N).  On input, contains the matrix in band
!    storage.  The columns of the matrix are stored in the columns of ABD
!    and the diagonals of the matrix are stored in rows ML+1 through
!    2*ML+MU+1 of ABD.  On output, an upper triangular matrix in band storage
!    and the multipliers which were used to obtain it.  The factorization
!    can be written A = L*U where L is a product of permutation and unit lower
!    triangular matrices and U is upper triangular.
!
!    Input, integer LDA, the leading dimension of the array ABD.
!    LDA must be >= 2*ML + MU + 1.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer ML, MU, the number of diagonals below and above the
!    main diagonal.  0 <= ML < N, 0 <= MU < N.
!
!    Output, integer IPVT(N), the pivot indices.
!
!    Output, integer INFO, error flag.
!    0, normal value.
!    K, if U(K,K) == 0.0E+00 .  This is not an error condition for this
!      subroutine, but it does indicate that SGBSL will divide by zero if
!      called.  Use RCOND in SGBCO for a reliable indication of singularity.
!
  integer lda
  integer n
!
  real abd(lda,n)
  integer i
  integer i0
  integer info
  integer ipvt(n)
  integer isamax
  integer j
  integer j0
  integer j1
  integer ju
  integer jz
  integer k
  integer l
  integer lm
  integer m
  integer ml
  integer mm
  integer mu
  real t
!
  m = ml + mu + 1
  info = 0
!
!  Zero initial fill-in columns.
!
  j0 = mu + 2
  j1 = min ( n, m ) - 1

  do jz = j0, j1
    i0 = m + 1 - jz
    do i = i0, ml
      abd(i,jz) = 0.0E+00
    end do
  end do

  jz = j1
  ju = 0
!
!  Gaussian elimination with partial pivoting.
!
  do k = 1, n-1
!
!  Zero next fill-in column.
!
     jz = jz + 1
     if ( jz <= n ) then
       abd(1:ml,jz) = 0.0E+00
     end if
!
!  Find L = pivot index.
!
     lm = min ( ml, n-k )
     l = isamax ( lm+1, abd(m,k), 1 ) + m - 1
     ipvt(k) = l + k - m
!
!  Zero pivot implies this column already triangularized.
!
     if ( abd(l,k) == 0.0E+00 ) then

       info = k
!
!  Interchange if necessary.
!
     else

        if ( l /= m ) then
           t = abd(l,k)
           abd(l,k) = abd(m,k)
           abd(m,k) = t
        end if
!
!  Compute multipliers.
!
        t = -1.0E+00 / abd(m,k)
        call sscal ( lm, t, abd(m+1,k), 1 )
!
!  Row elimination with column indexing.
!
        ju = min ( max ( ju, mu+ipvt(k) ), n )
        mm = m

        do j = k+1, ju
           l = l - 1
           mm = mm - 1
           t = abd(l,j)
           if ( l /= mm ) then
              abd(l,j) = abd(mm,j)
              abd(mm,j) = t
           end if
           call saxpy ( lm, t, abd(m+1,k), 1, abd(mm+1,j), 1 )
        end do

     end if

  end do

  ipvt(n) = n

  if ( abd(m,n) == 0.0E+00 ) then
    info = n
  end if

  return
end
subroutine sgbsl ( abd, lda, n, ml, mu, ipvt, b, job )
!
!*******************************************************************************
!
!! SGBSL solves a real banded system factored by SGBCO or SGBFA.
!
!
!  Discussion:
!
!    SGBSL can solve either A * X = B  or  A' * X = B.
!
!    A division by zero will occur if the input factor contains a
!    zero on the diagonal.  Technically this indicates singularity
!    but it is often caused by improper arguments or improper
!    setting of LDA.  It will not occur if the subroutines are
!    called correctly and if SGBCO has set RCOND > 0.0E+00
!    or SGBFA has set INFO == 0.
!
!    To compute inverse(A) * C  where C is a matrix with P columns:
!
!      call sgbco ( abd, lda, n, ml, mu, ipvt, rcond, z )
!
!      if ( rcond is too small ) then
!        exit
!      end if
!
!      do j = 1, p
!        call sgbsl ( abd, lda, n, ml, mu, ipvt, c(1,j), 0 )
!      end do
!
!  Parameters:
!
!    Input, real ABD(LDA,N), the output from SGBCO or SGBFA.
!
!    Input, integer LDA, the leading dimension of the array ABD.
!
!    Input, integer N, the order of the matrix.
!
!    Input, integer ML, MU, the number of diagonals below and above the
!    main diagonal.  0 <= ML < N, 0 <= MU < N.
!
!    Input, integer IPVT(N), the pivot vector from SGBCO or SGBFA.
!
!    Input/output, real B(N).  On input, the right hand side.
!    On output, the solution.
!
!    Input, integer JOB, job choice.
!    0, solve A*X=B.
!    nonzero, solve A'*X=B.
!
  integer lda
  integer n
!
  real abd(lda,n)
  real b(n)
  integer ipvt(n)
  integer job
  integer k
  integer l
  integer la
  integer lb
  integer lm
  integer m
  integer ml
  integer mu
  real sdot
  real t
!
  m = mu + ml + 1
!
!  JOB = 0, Solve  a * x = b.
!
!  First solve l*y = b.
!
  if ( job == 0 ) then

     if ( ml > 0 ) then

        do k = 1, n-1
           lm = min ( ml, n-k )
           l = ipvt(k)
           t = b(l)
           if ( l /= k ) then
              b(l) = b(k)
              b(k) = t
           end if
           call saxpy ( lm, t, abd(m+1,k), 1, b(k+1), 1 )
        end do

     end if
!
!  Now solve u*x = y.
!
     do k = n, 1, -1
        b(k) = b(k) / abd(m,k)
        lm = min ( k, m ) - 1
        la = m - lm
        lb = k - lm
        t = -b(k)
        call saxpy ( lm, t, abd(la,k), 1, b(lb), 1 )
     end do
!
!  JOB nonzero, solve  trans(a) * x = b.
!
!  First solve  trans(u)*y = b.
!
  else

     do k = 1, n
        lm = min ( k, m ) - 1
        la = m - lm
        lb = k - lm
        t = sdot ( lm, abd(la,k), 1, b(lb), 1 )
        b(k) = ( b(k) - t ) / abd(m,k)
     end do
!
!  Now solve trans(l)*x = y
!
     if ( ml > 0 ) then

        do k = n-1, 1, -1
           lm = min ( ml, n-k )
           b(k) = b(k) + sdot ( lm, abd(m+1,k), 1, b(k+1), 1 )
           l = ipvt(k)
           if ( l /= k ) then
              t = b(l)
              b(l) = b(k)
              b(k) = t
           end if
        end do

      end if

  end if

  return
end
subroutine sgeco ( a, lda, n, ipvt, rcond, z )
!
!*******************************************************************************
!
!! SGECO factors a real matrix and estimates its condition number.
!
!
!  Discussion:
!
!    If RCOND is not needed, SGEFA is slightly faster.
!
!    To solve A * X = B, follow SGECO by SGESL.
!
!    To compute inverse ( A ) * C, follow SGECO by SGESL.
!
!    To compute determinant ( A ), follow SGECO by SGEDI.
!
!    To compute inverse ( A ), follow SGECO by SGEDI.
!
!    For the system A * X = B, relative perturbations in A and B 
!    of size EPSILON may cause relative perturbations in X of size  
!    EPSILON/RCOND.
!
!    If RCOND is so small that the logical expression
!      1.0E+00 + rcond == 1.0E+00
!    is true, then A may be singular to working precision.  In particular,  
!    RCOND is zero if exact singularity is detected or the estimate
!    underflows.
!
!  Author:
!
!    Cleve Moler, 
!    University of New Mexico / Argonne National Lab.
!
!  Parameters:
!
!    Input/output, real A(LDA,N).  On input, a matrix to be factored.
!    On output, the LU factorization of the matrix. 
!
!    Input, integer LDA, the leading dimension of the array A.
!
!    Input, integer N, the order of the matrix A.
!
!    Output, integer IPVT(N), the pivot indices.
!
!    Output, real RCOND, an estimate of the reciprocal condition number of A.  
!
!    Output, real Z(N), a work vector whose contents are usually unimportant.
!    If A is close to a singular matrix, then Z is an approximate null vector 
!    in the sense that
!      norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ).
!
  integer lda
  integer n
!
  real a(lda,n)
  real anorm
  real ek
  integer info
  integer ipvt(n)
  integer j
  integer k
  integer l
  real rcond
  real s
  real sm
  real t
  real wk
  real wkm
  real ynorm
  real z(n)
!
!  Compute the L1 norm of A.
!
  anorm = 0.0E+00
  do j = 1, n
    anorm = max ( anorm, sum ( abs ( a(1:n,j) ) ) )
  end do
!
!  Compute the LU factorization.
!
  call sgefa ( a, lda, n, ipvt, info )
!
!  RCOND = 1 / ( norm(A) * (estimate of norm(inverse(A))) )
!
!  estimate of norm(inverse(A)) = norm(Z) / norm(Y) 
!
!  where  
!    A * Z = Y  
!  and  
!    A' * Y = E
!
!  The components of E are chosen to cause maximum local growth in the 
!  elements of W, where U'*W = E.  The vectors are frequently rescaled 
!  to avoid overflow.
!
!  Solve U' * W = E.
!
  ek = 1.0E+00
  z(1:n) = 0.0E+00

  do k = 1, n

    if ( z(k) /= 0.0E+00 ) then
      ek = sign ( ek, -z(k) )
    end if

    if ( abs ( ek - z(k) ) > abs ( a(k,k) ) ) then
      s = abs ( a(k,k) ) / abs ( ek - z(k) )
      z(1:n) = s * z(1:n)
      ek = s * ek
    end if

    wk = ek - z(k)
    wkm = -ek - z(k)
    s = abs ( wk )
    sm = abs ( wkm )

    if ( a(k,k) /= 0.0E+00 ) then
      wk = wk / a(k,k)
      wkm = wkm / a(k,k)
    else
      wk = 1.0E+00
      wkm = 1.0E+00
    end if

    if ( k+1 <= n ) then

      do j = k+1, n
        sm = sm + abs ( z(j) + wkm * a(k,j) )
        z(j) = z(j) + wk * a(k,j)
        s = s + abs ( z(j) )
      end do

      if ( s < sm ) then
        t = wkm - wk
        wk = wkm
        z(k+1:n) = z(k+1:n) + t * a(k,k+1:n)
      end if

    end if

    z(k) = wk

  end do

  z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) )
!
!  Solve L' * Y = W
!
  do k = n, 1, -1

    z(k) = z(k) + dot_product ( a(k+1:n,k), z(k+1:n) )

    if ( abs ( z(k) ) > 1.0E+00 ) then
      z(1:n) = z(1:n) / abs ( z(k) )
    end if

    l = ipvt(k)

    t = z(l)
    z(l) = z(k)
    z(k) = t

  end do

  z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) )

  ynorm = 1.0E+00
!
!  Solve L * V = Y.
!
  do k = 1, n

    l = ipvt(k)

    t = z(l)
    z(l) = z(k)
    z(k) = t

    z(k+1:n) = z(k+1:n) + t * a(k+1:n,k)

    if ( abs ( z(k) ) > 1.0E+00 ) then
      ynorm = ynorm / abs ( z(k) )
      z(1:n) = z(1:n) / abs ( z(k) )
    end if

  end do

  s = sum ( abs ( z(1:n) ) )
  z(1:n) = z(1:n) / s
  ynorm = ynorm / s
!
!  Solve U * Z = V.
!
  do k = n, 1, -1

    if ( abs ( z(k) ) > abs ( a(k,k) ) ) then
      s = abs ( a(k,k) ) / abs ( z(k) )
      z(1:n) = s * z(1:n)
      ynorm = s * ynorm
    end if

    if ( a(k,k) /= 0.0E+00 ) then
      z(k) = z(k) / a(k,k)
    else
      z(k) = 1.0E+00
    end if

    z(1:k-1) = z(1:k-1) - z(k) * a(1:k-1,k)

  end do
!
!  Normalize Z in the L1 norm.
!
  s = 1.0E+00 / sum ( abs ( z(1:n) ) )
  z(1:n) = s * z(1:n)
  ynorm = s * ynorm

  if ( anorm /= 0.0E+00 ) then
    rcond = ynorm / anorm
  else
    rcond = 0.0E+00
  end if

  return
end
subroutine sgedi ( a, lda, n, ipvt, det, work, job )

!*****************************************************************************80
!
!! SGEDI: determinant and inverse of a matrix factored by SGECO or SGEFA.
!
!
!  Discussion:
!
!    A division by zero will occur if the input factor contains
!    a zero on the diagonal and the inverse is requested.
!    It will not occur if the subroutines are called correctly
!    and if SGECO has set RCOND > 0.0E+00 or SGEFA has set
!    info == 0.
!
!  Parameters:
!
!    Input/output, real A(LDA,N), on input, the N by N factored matrix.
!    as output by SGECO or SGEFA.  On output, contains the inverse
!    matrix if requested.
!
!    Input, integer LDA, the leading dimension of the array A.
!
!    Input, integer N, the order of the matrix A.
!
!    Input, integer IPVT(N), the pivot vector from SGECO or SGEFA.
!
!    Workspace, real WORK(N).
!
!    Output, real DET(2), the determinant of original matrix if requested.
!    determinant = det(1) * 10.0**det(2)
!    with  1.0E+00 <= abs ( det(1) ) < 10.0E+00
!    or  det(1) == 0.0E+00 .
!
!    Input, integer JOB, specifies what is to be computed.
!    11, both determinant and inverse.
!    01, inverse only.
!    10, determinant only.
!
  integer lda
  integer n
!
  real a(lda,n)
  real det(2)
  integer i
  integer ipvt(n)
  integer j
  integer job
  integer k
  integer kp1
  integer l
  real t
  real, parameter :: ten = 10.0E+00
  real work(n)
!
!  Compute the determinant.
!
  if ( job / 10 /= 0 ) then

     det(1) = 1.0E+00
     det(2) = 0.0E+00

     do i = 1, n

        if ( ipvt(i) /= i ) then
          det(1) = - det(1)
        end if

        det(1) = a(i,i) * det(1)

        if ( det(1) == 0.0E+00 ) then
          exit
        end if

        do while ( abs ( det(1) ) < 1.0E+00 ) 
          det(1) = ten * det(1)
          det(2) = det(2) - 1.0E+00
        end do

        do while ( abs ( det(1) ) >= ten )
          det(1) = det(1) / ten
          det(2) = det(2) + 1.0E+00
        end do

    end do

  end if
!
!  Compute inverse(u).
!
  if ( mod ( job, 10 ) /= 0 ) then

     do k = 1, n

        a(k,k) = 1.0E+00 / a(k,k)
        t = - a(k,k)
        call sscal ( k-1, t, a(1,k), 1 )

        do j = k+1, n
           t = a(k,j)
           a(k,j) = 0.0E+00
           call saxpy ( k, t, a(1,k), 1, a(1,j), 1 )
        end do

     end do
!
!  Form inverse(u) * inverse(l).
!
     do k = n-1, 1, -1

        do i = k+1, n
           work(i) = a(i,k)
           a(i,k) = 0.0E+00
        end do

        do j = k+1, n
           t = work(j)
           call saxpy ( n, t, a(1,j), 1, a(1,k), 1 )
        end do

        l = ipvt(k)
        if ( l /= k ) then
          call sswap ( n, a(1,k), 1, a(1,l), 1 )
        end if

     end do

  end if

  return
end
subroutine sgefa ( a, lda, n, ipvt, info )
!
!*****************************************************************************80
!
!! SGEFA factors a real matrix.
!
!
!  Modified:
!
!    07 March 2001
!
!  Parameters:
!
!    Input/output, real A(LDA,N).
!    On intput, the matrix to be factored.
!    On output, an upper triangular matrix and multipliers used to obtain it.
!    The factorization can be written A=L*U, where L is a product of
!    permutation and unit lower triangular matrices, and U is upper triangular.
!
!    Input, integer LDA, the leading dimension of A.
!
!    Input, integer N, the order of the matrix A.
!
!    Output, integer IPVT(N), the pivot indices.
!
!    Output, integer INFO, singularity indicator.
!    0, normal value.
!    K, if U(K,K) == 0.  This is not an error condition for this subroutine,
!    but it does indicate that SGESL or SGEDI will divide by zero if called.
!    Use RCOND in SGECO for a reliable indication of singularity.
!
  integer lda
  integer n
!
  real a(lda,n)
  integer info
  integer ipvt(n)
  integer isamax
  integer j
  integer k
  integer l
  real t
!
!  Gaussian elimination with partial pivoting.
!
  info = 0

  do k = 1, n - 1
!
!  Find L = pivot index.
!
    l = isamax ( n-k+1, a(k,k), 1 ) + k - 1
    ipvt(k) = l
!
!  Zero pivot implies this column already triangularized.
!
    if ( a(l,k) == 0.0E+00 ) then
      info = k
      cycle
    end if
!
!  Interchange if necessary.
!
    if ( l /= k ) then
      t = a(l,k)
      a(l,k) = a(k,k)
      a(k,k) = t
    end if
!
!  Compute multipliers.
!
    t = -1.0E+00 / a(k,k)
    call sscal ( n-k, t, a(k+1,k), 1 )
!
!  Row elimination with column indexing.
!
    do j = k+1, n
      t = a(l,j)
      if ( l /= k ) then
        a(l,j) = a(k,j)
        a(k,j) = t
      end if
      call saxpy ( n-k, t, a(k+1,k), 1, a(k+1,j), 1 )
    end do

  end do

  ipvt(n) = n

  if ( a(n,n) == 0.0E+00 ) then
    info = n
  end if

  return
end
subroutine sgesl ( a, lda, n, ipvt, b, job )
!
!*******************************************************************************
!
!! SGESL solves a real general linear system A * X = B.
!
!
!  Discussion:
!
!    SGESL can solve either of the systems A * X = B or transpose ( A ) * X = B.
!
!    The system matrix must have been factored by SGECO or SGEFA.
!
!    A division by zero will occur if the input factor contains a
!    zero on the diagonal.  Technically this indicates singularity
!    but it is often caused by improper arguments or improper
!    setting of LDA.  It will not occur if the subroutines are
!    called correctly and if SGECO has set RCOND > 0.0E+00
!    or SGEFA has set INFO == 0.
!
!  Modified:
!
!    07 March 2001
!
!  Parameters:
!
!    Input, real A(LDA,N), the output from SGECO or SGEFA.
!
!    Input, integer LDA, the leading dimension of A.
!
!    Input, integer N, the order of the matrix A.
!
!    Input, integer IPVT(N), the pivot vector from SGECO or SGEFA.
!
!    Input/output, real B(N).
!    On input, the right hand side vector.
!    On output, the solution vector.
!
!    Input, integer JOB.
!    0, solve A * X = B;
!    nonzero, solve transpose ( A ) * X = B.
!
  integer lda
  integer n
!
  real a(lda,n)
  real b(n)
  integer ipvt(n)
  integer job
  integer k
  integer l
  real sdot
  real t
!
!  Solve A * X = B.
!
  if ( job == 0 ) then

    do k = 1, n-1

      l = ipvt(k)
      t = b(l)

      if ( l /= k ) then
        b(l) = b(k)
        b(k) = t
      end if

      call saxpy ( n-k, t, a(k+1,k), 1, b(k+1), 1 )

    end do

    do k = n, 1, -1
      b(k) = b(k) / a(k,k)
      t = -b(k)
      call saxpy ( k-1, t, a(1,k), 1, b(1), 1 )
    end do

  else
!
!  Solve transpose ( A ) * X = B.
!
    do k = 1, n
      t = sdot ( k-1, a(1,k), 1, b(1), 1 )
      b(k) = ( b(k) - t ) / a(k,k)
    end do

    do k = n-1, 1, -1

      b(k) = b(k) + sdot ( n-k, a(k+1,k), 1, b(k+1), 1 )
      l = ipvt(k)

      if ( l /= k ) then
        t = b(l)
        b(l) = b(k)
        b(k) = t
      end if

    end do

  end if

  return
end
subroutine shell (a, n)
!
!*******************************************************************************
!
!! SHELL uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. it is assumed that n >= 1.
!
  real a(n)
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 31 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31    a(ll) = s
!
   40 i = i - 1
  return
end
subroutine shell2 (a, b, n)
!
!*******************************************************************************
!
!! SHELL2 uses the shell sorting procedure to reorder the elements of a
!     so that a(i) <= a(i+1) for i=1,...,n-1. the same permutations are
!     performed on b that are performed on a. it is assumed that n >= 1.
!
  real a(n), b(n)
  integer k(10)
!
  data k(1)/1/, k(2)/4/, k(3)/13/, k(4)/40/, k(5)/121/, k(6)/364/, &
       k(7)/1093/, k(8)/3280/, k(9)/9841/, k(10)/29524/
!
!
!             selection of the increments k(i) = (3**i-1)/2
!
  if (n < 2) return
  imax = 1
  do 10 i = 3,10
     if (n <= k(i)) go to 20
     imax = imax + 1
   10 continue
!
!            stepping through the increments k(imax),...,k(1)
!
   20 i = imax
  do 40 ii = 1,imax
     ki = k(i)
!
!             sorting elements that are ki positions apart
!               so that a(j) <= a(j+ki) for j=1,...,n-ki
!
     jmax = n - ki
     do 32 j = 1,jmax
        l = j
        ll = j + ki
        s = a(ll)
        t = b(ll)
   30          if (s >= a(l)) go to 31
           a(ll) = a(l)
           b(ll) = b(l)
           ll = l
           l = l - ki
           if (l > 0) go to 30
   31       a(ll) = s
        b(ll) = t
   32    continue
!
   40 i = i - 1
  return
end
subroutine shrslv (a,b,c,m,n,na,nb,nc,ierr)
!
!*******************************************************************************
!
!! SHRSLV solves the matrix equation ax + xb = c
!  where a is in lower schur form and b in upper schur form.
!
  integer m,n,na,nb,nc,ierr
  real a(na,m), b(nb,n), c(nc,n)
  real sum, p(4), t(4,4)
  integer dk,dl,i,ib,j,ja,k,km1,kk,l,lm1,ll
!
  l = 1
   10    lm1 = l - 1
     dl = 1
     if (l == n) go to 15
     if (b(l+1,l) /= 0.0) dl = 2
   15    ll = l + dl - 1
     if (l == 1) go to 30
!
     do 22 j = l,ll
        do 21 i = 1,m
        sum = c(i,j)
           do 20 ib = 1,lm1
   20          sum = sum - c(i,ib)*b(ib,j)
   21       c(i,j) = sum
   22    continue
!
   30    k = 1
   40       km1 = k - 1
        dk = 1
        if (k == m) go to 45
        if (a(k,k+1) /= 0.0) dk = 2
   45       kk = k + dk - 1
        if (k == 1) go to 60
!
        do 52 i = k,kk
           do 51 j = l,ll
           sum = c(i,j)
              do 50 ja = 1,km1
   50             sum = sum - a(i,ja)*c(ja,j)
   51          c(i,j) = sum
   52       continue
!
   60       if (dl == 2) go to 80
        if (dk == 2) go to 70
        t(1,1) = a(k,k) + b(l,l)
        if (t(1,1) == 0.0) go to 200
        c(k,l) = c(k,l)/t(1,1)
        ierr = 0
        go to 100
!
   70       t(1,1) = a(k,k) + b(l,l)
        t(1,2) = a(k,kk)
        t(2,1) = a(kk,k)
        t(2,2) = a(kk,kk) + b(l,l)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        call slv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        go to 100
!
   80       if (dk == 2) go to 90
        t(1,1) = a(k,k) + b(l,l)
        t(1,2) = b(ll,l)
        t(2,1) = b(l,ll)
        t(2,2) = a(k,k) + b(ll,ll)
        p(1) = c(k,l)
        p(2) = c(k,ll)
        call slv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(k,ll) = p(2)
        go to 100
!
   90       t(1,1) = a(k,k) + b(l,l)
        t(1,2) = a(k,kk)
        t(1,3) = b(ll,l)
        t(1,4) = 0.0
        t(2,1) = a(kk,k)
        t(2,2) = a(kk,kk) + b(l,l)
        t(2,3) = 0.0
        t(2,4) = t(1,3)
        t(3,1) = b(l,ll)
        t(3,2) = 0.0
        t(3,3) = a(k,k) + b(ll,ll)
        t(3,4) = t(1,2)
        t(4,1) = 0.0
        t(4,2) = t(3,1)
        t(4,3) = t(2,1)
        t(4,4) = a(kk,kk) + b(ll,ll)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        p(3) = c(k,ll)
        p(4) = c(kk,ll)
        call slv (4, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        c(k,ll) = p(3)
        c(kk,ll) = p(4)
!
  100    k = k + dk
     if (k <= m) go to 40
  l = l + dl
  if (l <= n) go to 10
  return
!
!     error return
!
  200 ierr = 1
  return
end
function si ( x )
!
!*******************************************************************************
!
!! SI evaluates the sine integral function for a given X.
!
!
!  Discussion:
!
!    SI(X) = integral ( 0 <= T <= X ) sin ( T ) / T dt
!
!    Chebyshev expansions are used on (0,5) and (5,infinity).
!
!  Author:
!
!    D E Amos and S L Daniel
!
!  References:
!
!    Y L Luke,
!    The Special Functions and Their Approximations, Volume II, 
!    Academic Press, New York, 1969.
!
!  Parameters:
!
!    Input, real X, the argument of the function.
!
!    Output, real SI, the value of the sine integral.
!
  real bb(16)
  real cc(46)
!
  data n1,n2,m1,m2/16,46,14,21/
  data pio2/1.5707963267949/
!
  data bb(1) / 6.84101190850653e-01/, bb(2) /-3.74538448460062e-01/, &
       bb(3) /-2.82656062651542e-02/, bb(4) / 3.06078454012071e-02/, &
       bb(5) /-8.99242948380352e-04/, bb(6) /-1.09884251456048e-03/, &
       bb(7) / 5.81151604367358e-05/, bb(8) / 2.28802638122969e-05/, &
       bb(9) /-1.35078982929539e-06/, bb(10)/-3.13213946132892e-07/, &
       bb(11)/ 1.86619586786257e-08/, bb(12)/ 3.03991719607226e-09/, &
       bb(13)/-1.76437788946489e-10/, bb(14)/-2.20236421792690e-11/, &
       bb(15)/ 1.22710107703240e-12/, bb(16)/ 1.23680681116783e-13/
!
  data cc(1) / 9.76155271128712e-01/, cc(2) / 8.96845854916423e-02/, &
       cc(3) /-3.04656658030696e-02/, cc(4) / 8.50892472922945e-02/, &
       cc(5) /-5.78073683148386e-03/, cc(6) /-5.07182677775691e-03/, &
       cc(7) / 8.38643256650893e-04/, cc(8) /-3.34223415981738e-04/, &
       cc(9) /-2.15746207281216e-05/, cc(10)/ 1.28560650086065e-04/, &
       cc(11)/-1.56456413510232e-05/, cc(12)/-1.52025513597262e-05/, &
       cc(13)/ 4.04001013843204e-06/, cc(14)/-5.95896122752160e-07/, &
       cc(15)/-4.34985305974340e-07/, cc(16)/ 7.13472533530840e-07/, &
       cc(17)/-5.34302186061100e-08/, cc(18)/-1.76003581156610e-07/, &
       cc(19)/ 3.85028855125900e-08/, cc(20)/ 1.92576544441700e-08/, &
       cc(21)/-1.00735358217200e-08/, cc(22)/ 3.36359194377000e-09/, &
       cc(23)/ 1.28049619406000e-09/, cc(24)/-2.42546870827000e-09/, &
       cc(25)/ 1.86917288950000e-10/, cc(26)/ 7.13431298340000e-10/, &
       cc(27)/-1.70673483710000e-10/, cc(28)/-1.14604070350000e-10/, &
       cc(29)/ 5.88004411500000e-11/, cc(30)/-6.78417843000000e-12/, &
       cc(31)/-1.21572380900000e-11/, cc(32)/ 1.26561248700000e-11/, &
       cc(33)/ 4.74814180000000e-13/, cc(34)/-5.32309477000000e-12/, &
       cc(35)/ 9.05903810000000e-13/, cc(36)/ 1.40046450000000e-12/, &
       cc(37)/-5.00968320000000e-13/, cc(38)/-1.80458040000000e-13/
  data cc(39)/ 1.66162910000000e-13/, cc(40)/-5.02616400000000e-14/, &
       cc(41)/-3.48453600000000e-14/, cc(42)/ 4.60056600000000e-14/, &
       cc(43)/ 5.74000000000000e-16/, cc(44)/-1.95310700000000e-14/, &
       cc(45)/ 3.68837000000000e-15/, cc(46)/ 5.62862000000000e-15/
!
!     ****** amax is a machine dependent constant. it is assumed that
!            sin(x) and cos(x) are defined for  abs(x) <= amax, and
!            that pio2 - (1 + 1/x)/x = pio2 for x > amax.
!
  amax = 1.0/ epsilon ( amax )
!
!
  ax=abs(x)
  if (ax > 5.0) go to 20
  j=n1
  bx=0.40*ax-1.0
  tx=bx+bx
  b1=bb(j)
  b2=0.
  do 10 i=1,m1
  j=j-1
  temp=b1
  b1=tx*b1-b2+bb(j)
   10 b2=temp
  si=(bx*b1-b2+bb(1))*x
  return
!
   20 if (ax > amax) go to 50
  bx=10./ax-1.
  tx=bx+bx
  j=n2
  b1=cc(j)
  b2=0.0
  do 30 i=1,m2
  j=j-2
  temp=b1
  b1=tx*b1-b2+cc(j)
   30 b2=temp
  aic=bx*b1-b2+cc(2)
!
  j=n2-1
  b1=cc(j)
  b2=0.0
  do 40 i=1,m2
  j=j-2
  temp=b1
  b1=tx*b1-b2+cc(j)
   40 b2=temp
  rc=bx*b1-b2+cc(1)
!
  si=(rc*cos(ax)+aic*sin(ax))/ax
  si=pio2-si
  if (x < 0.0) si=-si
  return
!
   50 si=sign(pio2,x)
  return
end
subroutine si_values ( n, x, fx )
!
!*******************************************************************************
!
!! SI_VALUES returns some values of the sine integral function.
!
!
!  Discussion:
!
!    SI(X) = integral ( 0 <= T <= X ) sin ( T ) / T dt
!
!  Modified:
!
!    27 April 2001
!
!  Reference:
!
!    Milton Abramowitz and Irene Stegun,
!    Handbook of Mathematical Functions,
!    US Department of Commerce, 1964.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer N.
!    On input, if N is 0, the first test data is returned, and N is set
!    to the index of the test data.  On each subsequent call, N is
!    incremented and that test data is returned.  When there is no more
!    test data, N is set to 0.
!
!    Output, real X, the argument of the function.
!
!    Output, real FX, the value of the function.
!
  integer, parameter :: nmax = 16
!
  real fx
  real, save, dimension ( nmax ) :: fxvec = (/ &
    0.4931074180E+00, 0.5881288096E+00, 0.6812222391E+00, 0.7720957855E+00, &
    0.8604707107E+00, 0.9460830704E+00, 1.1080471990E+00, 1.2562267328E+00, &
    1.3891804859E+00, 1.5058167803E+00, 1.6054129768E+00, 1.7785201734E+00, &
    1.8486525280E+00, 1.8331253987E+00, 1.7582031389E+00, 1.6541404144E+00 /)
  integer n
  real x
  real, save, dimension ( nmax ) :: xvec = (/ &
     0.5E+00,  0.6E+00,  0.7E+00,  0.8E+00, &
     0.9E+00,  1.0E+00,  1.2E+00,  1.4E+00, &
     1.6E+00,  1.8E+00,  2.0E+00,  2.5E+00, &
     3.0E+00,  3.5E+00,  4.0E+00,  4.5E+00 /)
!
  if ( n < 0 ) then
    n = 0
  end if

  n = n + 1

  if ( n > nmax ) then
    n = 0
    x = 0.0E+00
    fx = 0.0E+00
    return
  end if

  x = xvec(n)
  fx = fxvec(n)

  return
end
subroutine sigma1 (n,m,p,w,q,i,b,kub,ub,np1,n5,lx,lr, &
                     bs,ps,ws,xs,iwk)
!
!*******************************************************************************
!
!! SIGMA1 computes an upper bound ub on the best final solution
!  which can be obtained from the current solution.
!
  integer p(n),w(n),q(m),b(np1),ub,iwk(n5)
  integer lx(n),bs(n),ps(np1),ws(np1),xs(n)
  integer qs,sb
!
  ns = 0
  qs = 0
  do 10 j=i,m
    qs = qs + q(j)
   10 continue
  sb = 0
  do 20 j=1,n
    lx(j) = 0
    if ( b(j) == 0 ) go to 20
    ns = ns + 1
    bs(ns) = j
    ps(ns) = p(j)
    ws(ns) = w(j)
    sb = sb + w(j)
   20 continue
  if ( sb > qs ) go to 40
  lr = qs - sb
  ub = 0
  if ( ns == 0 ) return
  do 30 j=1,ns
    ub = ub + ps(j)
    xs(j) = 1
   30 continue
  go to 50
   40 call sknp (ns,qs,kub,ub,n,np1,n5,ps,ws,xs,iwk)
  lr = qs
   50 do 60 j=1,ns
    jj = bs(j)
    lx(jj) = xs(j)
   60 continue
  return
end
function sin0 (x)
!
!*******************************************************************************
!
!! SIN0: computation of sin(x*pi/2) for abs(x) <= 0.5
!
  real sin0
!
  data a0 /.157079632679490e+01/, a1 /-.645964097506244e+00/, &
       a2 /.796926262460396e-01/, a3 /-.468175413228242e-02/, &
       a4 /.160441150291651e-03/, a5 /-.359864175444606e-05/, &
       a6 /.563372101191893e-07/
!
  t = x*x
  sin0 = ((((((a6*t + a5)*t + a4)*t + a3)*t + a2)*t &
                    + a1)*t + a0)*x
  return
end
function sin1 (x)
!
!*******************************************************************************
!
!! SIN1: evaluation  of sin(x*pi)
!
  integer imax
  real sin1
!
  data a0 /.314159265358979e+01/, a1 /-.516771278004995e+01/, &
       a2 /.255016403987327e+01/, a3 /-.599264528932149e+00/, &
       a4 /.821458689493251e-01/, a5 /-.737001831310553e-02/, &
       a6 /.461514425296398e-03/
  data b1 /-.493480220054460e+01/, b2 /.405871212639605e+01/, &
       b3 /-.133526276691575e+01/, b4 /.235330543508553e+00/, &
       b5 /-.258048861575714e-01/, b6 /.190653140279462e-02/
!
  imax = huge ( imax )
  a = abs(x)

  if ( a >= real ( imax ) ) then
    sin1 = 0.0
    return
  end if

  n = a
  a = a - real(n)
  if (a > 0.75) go to 20
  if (a < 0.25) go to 21
!
!                    0.25 <= a <= 0.75
!
  a = 0.25 + (0.25 - a)
  t = a*a
  sin1 = ((((((b6*t + b5)*t + b4)*t + b3)*t + b2)*t &
                    + b1)*t + 0.5) + 0.5
  go to 30
!
!                 a < 0.25  or  a > 0.75
!
   20 a = 0.25 + (0.75 - a)
   21 t = a*a
  sin1 = ((((((a6*t + a5)*t + a4)*t + a3)*t + a2)*t &
                    + a1)*t + a0)*a
!
!                        termination
!
   30 if (x < 0.0) sin1 = - sin1
  if (mod(n,2) /= 0) sin1 = - sin1
  return
end
subroutine sinqb (n,x,wsave)
!
!*******************************************************************************
!
!! SINQB: ???
!
  dimension       x(*)       ,wsave(*)
  if (n > 1) go to 101
  x(1) = 4.*x(1)
  return
  101 ns2 = n/2
  do 102 k=2,n,2
     x(k) = -x(k)
  102 continue
  call cosqb (n,x,wsave)
  do 103 k=1,ns2
     kc = n-k
     xhold = x(k)
     x(k) = x(kc+1)
     x(kc+1) = xhold
  103 continue
  return
end
subroutine sinqf (n,x,wsave)
!
!*******************************************************************************
!
!! SINQF: ???
!
  dimension       x(*)       ,wsave(*)
  if (n == 1) return
  ns2 = n/2
  do 101 k=1,ns2
     kc = n-k
     xhold = x(k)
     x(k) = x(kc+1)
     x(kc+1) = xhold
  101 continue
  call cosqf (n,x,wsave)
  do 102 k=2,n,2
     x(k) = -x(k)
  102 continue
  return
end
subroutine sknp (ns,qs,kub,vs,n,np1,n5,ps,ws,xs,iwk)
!
!*******************************************************************************
!
!! SKNP solves the 0-1 single knapsack problem
!
! maximize    vs = ps(1)*xs(1) + ... + ps(ns)*xs(ns)
! subject to       ws(1)*xs(1) + ... + ws(ns)*xs(ns) <= qs
!                  xs(j) = 0 or 1   for  j=1,...,ns
!                  vs > kub
!
! this subroutine is a modified version of subroutine kp01
! which appeared in  computing 21, 81-86(1978).
!
  integer qs, vs
  integer ps(np1), ws(np1), xs(n), iwk(n5)
!
  i1 = 1
  i2 = i1 + n
  i3 = i2 + n
  i4 = i3 + n
  i5 = i4 + n
  call sknp1 (ns,qs,kub,vs,n,np1,ps,ws,xs,iwk(i1),iwk(i2), &
              iwk(i3),iwk(i4),iwk(i5))
  return
end
subroutine sknp1 ( ns, qs, kub, vs, n, np1, ps, ws, xs, d, min, pbar, wbar, &
  zbar )
!
!*******************************************************************************
!
!! SKNP1 solves the 0-1 single knapsack problem
!
!
!  Discussion:
!
!    The problem is to maximize:
!
!      vs = ps(1)*xs(1) + ... + ps(ns)*xs(ns)
!
!    subject to       
!
!      ws(1)*xs(1) + ... + ws(ns)*xs(ns) <= qs
!      xs(j) = 0 or 1   for  j=1,...,ns
!      vs > kub
!
! this subroutine is a modified version of subroutine kp01
! which appeared in  computing 21, 81-86(1978).
!
  integer qs
  integer vs,diff,pr,r,t
  integer ps(np1),ws(np1),xs(n)
  integer d(n),min(n),pbar(n),wbar(n),zbar(n)
!
  vs = kub
  ip = 0
  ms = qs
  do l=1,ns
    ll = l
    if ( ws(l) > ms ) go to 20
    ip = ip + ps(l)
    ms = ms - ws(l)
  end do

   20 ll = ll - 1
  if ( ms == 0 ) go to 50
  ps(ns+1) = 0
  ws(ns+1) = qs + 1
  lim = ip + (ms*ps(ll+2))/ws(ll+2)
  a = ip + ps(ll+1)
  b = (ws(ll+1) - ms)*ps(ll)
  c = ws(ll)
  lim1 = a - b/c
  if ( lim1 > lim ) lim = lim1
  if ( lim <= vs ) return
  mink = qs + 1
  min(ns) = mink
  do j=2,ns
    kk = ns + 2 - j
    if ( ws(kk) < mink ) mink = ws(kk)
    min(kk-1) = mink
  end do

  d(1:ns) = 0
  pr = 0
  lold = ns
  ii = 1
  go to 170
50 continue

  if ( vs >= ip ) then
    return
  end if

  vs = ip
  xs(1:ll) = 1
  nn = ll + 1
  xs(nn:ns) = 0
  qs = 0
  return

   80 if ( ws(ii) <= qs ) go to 90
  ii1 = ii + 1
  if ( vs >= (qs*ps(ii1))/ws(ii1) + pr ) go to 280
  ii = ii1
  go to 80
   90 ip = pbar(ii)
  ms = qs - wbar(ii)
  in = zbar(ii)
  ll = ns
  if ( in > ns) go to 110
  do 100 l=in,ns
    ll = l
    if ( ws(l) > ms ) go to 160
    ip = ip + ps(l)
    ms = ms - ws(l)
  100 continue
  110 if ( vs >= ip + pr ) go to 280
  vs = ip + pr
  mfirst = ms
  nn = ii - 1
  do 120 j=1,nn
    xs(j) = d(j)
  120 continue
  do 130 j=ii,ll
    xs(j) = 1
  130 continue
  if ( ll == ns ) go to 150
  nn = ll + 1
  do 140 j=nn,ns
    xs(j) = 0
  140 continue
  150 if ( vs /= lim ) go to 280
  qs = mfirst
  return
  160 l = ll
  ll = ll - 1
  if ( ms == 0 ) go to 110
  if ( vs >= pr + ip + (ms*ps(l))/ws(l) ) go to 280
  170 wbar(ii) = qs - ms
  pbar(ii) = ip
  zbar(ii) = ll + 1
  d(ii) = 1
  nn = ll - 1
  if ( nn < ii ) go to 190
  do 180 j=ii,nn
    wbar(j+1) = wbar(j) - ws(j)
    pbar(j+1) = pbar(j) - ps(j)
    zbar(j+1) = ll + 1
    d(j+1) = 1
  180 continue
  190 j1 = ll + 1
  do 200 j=j1,lold
    wbar(j) = 0
    pbar(j) = 0
    zbar(j) = j
  200 continue
  lold = ll
  qs = ms
  pr = pr + ip
  if ( ll - (ns - 2) ) 240, 220, 210
  210 ii = ns
  go to 250
  220 if ( qs < ws(ns) ) go to 230
  qs = qs - ws(ns)
  pr = pr + ps(ns)
  d(ns) = 1
  230 ii = ns - 1
  go to 250
  240 ii = ll + 2
  if ( qs >= min(ii-1) ) go to 80
  250 if ( vs >= pr ) go to 270
  vs = pr
  do 260 j=1,ns
    xs(j) = d(j)
  260 continue
  mfirst = qs
  if ( vs == lim ) return
  270 if ( d(ns) == 0 ) go to 280
  d(ns) = 0
  qs = qs + ws(ns)
  pr = pr - ps(ns)
  280 nn = ii - 1
  if ( nn == 0 ) go to 300
  do 290 j=1,nn
    kk = ii - j
    if ( d(kk) == 1 ) go to 310
  290 continue
  300 qs = mfirst
  return
  310 r = qs
  qs = qs + ws(kk)
  pr = pr - ps(kk)
  d(kk) = 0
  if ( r < min(kk) ) go to 320
  ii = kk + 1
  go to 80
  320 nn = kk + 1
  ii = kk
  330 if ( vs >= pr + (qs*ps(nn))/ws(nn) ) go to 280
  diff = ws(nn) - ws(kk)
  if ( diff ) 390, 340, 350
  340 nn = nn + 1
  go to 330
  350 if ( diff > r ) go to 340
  if ( vs >= pr + ps(nn) ) go to 340
  vs = pr + ps(nn)
  do 360 j=1,kk
    xs(j) = d(j)
  360 continue
  jj = kk + 1
  do 370 j=jj,ns
    xs(j) = 0
  370 continue
  xs(nn) = 1
  mfirst = qs - ws(nn)
  if ( vs /= lim ) go to 380
  qs = mfirst
  return
  380 r = r - diff
  kk = nn
  nn = nn + 1
  go to 330
  390 t = r - diff
  if ( t < min(nn) ) go to 340
  n1 = nn + 1
  if ( vs >= pr + ps(nn) + (t*ps(n1))/ws(n1) ) go to 280
  qs = qs - ws(nn)
  pr = pr + ps(nn)
  d(nn) = 1
  ii = nn + 1
  wbar(nn) = ws(nn)
  pbar(nn) = ps(nn)
  zbar(nn) = ii
  do 400 j=n1,lold
    wbar(j) = 0
    pbar(j) = 0
    zbar(j) = j
  400 continue
  lold = nn
  go to 80
end
subroutine slv (n, m, a, ka, b, kb, ierr)
!
!*******************************************************************************
!
!! SLV: partial pivot solution of a*x = b
!
!
!  A is a matrix of order n and b is a matrix having n rows and m columns.
!     the solution matrix x is stored in b.
!
!     ierr is a variable that reports the status of the results.
!        ierr = 0   the equations have been solved.
!        ierr = j   the j-th pivot element was found to be 0.
!
  real a(ka,n)
  real b(kb,m)
  integer ierr
!
  ierr = 0
  nm1 = n - 1
  if (nm1 == 0) go to 140
  do 80 j = 1,nm1
!
!     search for the j-th pivot element
!
     p = 0.0
     do 10 i = j,n
        t = abs(a(i,j))
        if (t <= p) go to 10
        p = t
        l = i
   10    continue
     if (p == 0.0) go to 210
     if (j == l) go to 40
!
!     interchange rows j and l
!
     do 20 k = j,n
        t = a(j,k)
        a(j,k) = a(l,k)
        a(l,k) = t
   20    continue
     do 30 k = 1,m
        t = b(j,k)
        b(j,k) = b(l,k)
        b(l,k) = t
   30    continue
!
!     eliminate the coefficients of x(j) in rows i = j+1,...,n
!
   40    p = a(j,j)
     jp1 = j + 1
     do 70 i = jp1,n
        t = a(i,j)/p
        do 50 k = jp1,n
   50          a(i,k) = a(i,k) - t*a(j,k)
        do 60 k = 1,m
   60          b(i,k) = b(i,k) - t*b(j,k)
   70    continue
   80 continue
  if (a(n,n) == 0.0) go to 220
!
!     backsolve the triangular set of equations
!
  do 100 j = 1,m
  100 b(n,j) = b(n,j)/a(n,n)
!
  do 130 l = 1,nm1
  i = n - l
  ip1 = i + 1
     do 120 j = 1,m
     sum = b(i,j)
        do 110 k = ip1,n
  110       sum = sum - a(i,k)*b(k,j)
  120    b(i,j) = sum/a(i,i)
  130 continue
  return
!
!     case when n = 1
!
 140  if (a(1,1) == 0.0) go to 200
  do 150 j = 1,m
 150  b(1,j) = b(1,j)/a(1,1)
  return
!
!     error return
!
 200  ierr = 1
  return
 210  ierr = j
  return
 220  ierr = n
  return
end
subroutine slvmp(mo, n, a, ka, b, x, wk, iwk, ierr)
!
!*******************************************************************************
!
!! SLVMP: solution of real linear equations with iterative improvement
!
  dimension a(ka,n), b(n), x(n), wk(*), iwk(n)
!
!     dimension wk(n*n + n)
!
  if (mo /= 0) go to 10
!
!             compute the lu decomposition of a
!
  call mcopy(n, n, a, ka, wk, n)
  call sgefa(wk, n, n, iwk, ierr)
  if (ierr == 0) go to 10
  ierr = -ierr
  return
!
!            solve the system of equations ax = b
!
   10 do 11 i = 1,n
   11 x(i) = b(i)
!
  ir = n*n + 1
  call sgesl(wk, n, n, iwk, x, 0)
  call luimp(a, ka, n, wk(1), n, iwk, b, x, wk(ir), ierr)
  return
end
subroutine slvs (wm, iwm, x, tem)
!
!*******************************************************************************
!
!! SLVS solves the linear system in the iteration scheme for sfode.
!
!
! this routine manages the solution of the linear system arising from
! a chord iteration.  it is called by stod  if miter /= 0.
! if miter is 1 or 2, it calls sgesl to accomplish this.
! if miter = 3 it updates the coefficient h*el0 in the diagonal
! matrix, and then computes the solution.
! if miter is 4 or 5, it calls sgbsl.
! communication with slvs uses the following variables..
! wm  = real work space containing the inverse diagonal matrix if miter
!       is 3 and the lu decomposition of the matrix otherwise.
!       storage of matrix elements starts at wm(3).
!       wm also contains the following matrix-related data..
!       wm(1) = sqrt(uround) (not used here),
!       wm(2) = hl0, the previous value of h*el0, used if miter = 3.
! iwm = integer work space containing pivot information, starting at
!       iwm(21), if miter is 1, 2, 4, or 5.  iwm also contains the
!       band parameters ml = iwm(1) and mu = iwm(2) if miter is 4 or 5.
! x   = the right-hand side vector on input, and the solution vector
!       on output, of length n.
! tem = vector of work space of length n, not used in this version.
! ier = output flag (in common).  ier = 0 if no trouble occurred.
!       ier = -1 if a singular matrix arose with miter = 3.
! this routine also uses the common variables el0, h, miter, and n.
!
  integer iwm, i, ier, iownd, iowns, jstart, kflag, l, maxord, &
     meband, meth, miter, ml, mu, n, nfe, nje, nq, nqu, nst
  real wm, x, tem, &
     rownd, rowns, el0, h, hmin, hmxi, hu, tn, uround, &
     di, hl0, phl0, r
  dimension wm(*), iwm( *), x(*), tem(*)
  common /debdf1/ rownd, rowns(210), &
     el0, h, hmin, hmxi, hu, tn, uround, iownd(14), iowns(6), &
     ier, jstart, kflag, l, meth, miter, maxord, n, nq, nst, nfe, &
     nje, nqu
!
  ier = 0
  go to (100, 100, 300, 400, 400), miter
 100  call sgesl (wm(3), n, n, iwm(21), x, 0)
  return
!
 300  phl0 = wm(2)
  hl0 = h*el0
  wm(2) = hl0
  if (hl0 == phl0) go to 330
  r = hl0/phl0
  do 320 i = 1,n
    di = 1.0e0 - r*(1.0e0 - 1.0e0/wm(i+2))
    if (abs(di) == 0.0e0) go to 390
 320    wm(i+2) = 1.0e0/di
 330  do 340 i = 1,n
 340    x(i) = wm(i+2)*x(i)
  return
 390  ier = -1
  return

 400  ml = iwm(1)
  mu = iwm(2)
  meband = 2*ml + mu + 1
  call sgbsl (wm(3), meband, n, ml, mu, iwm(21), x, 0)
  return
end
subroutine smadd(n,a,b,c)
!
!*******************************************************************************
!
!! SMADD adds two real symmetric storage matrices.
!
  real a(*),b(*),c(*)
!
  m=(n*(n+1))/2

  c(1:m) = a(1:m) + b(1:m)

  return
end
subroutine smcopy(n,a,b)
!
!*******************************************************************************
!
!! SMCOPY copies a real symmetric storage matrix.
!
  real a(*)
  real b(*)
!
  l = (n*(n + 1))/2

  b(1:l) = a(1:l)

  return
end
subroutine smplx (a,b0,c,ka,m,n0,ind,ibasis,x,z,iter,mxiter, &
                         numle,numge,bi,wk,iwk)
!
!*******************************************************************************
!
!! SMPLX: simplex procedure for solving linear programming problems
!
!
!  Author:
!
!    Alfred Morris,
!    Naval Surface Weapons Center,
!    Dahlgren, Virginia
!
!     initial version  dec  1977
!     last update      sept 1986
!
  dimension a(ka,n0),b0(m),c(n0)
  dimension ibasis(m),bi(m,m)
  dimension x(*),wk(*),iwk(*)
!
!     dimension x(n0+numle+numge)
!     dimension wk(2*m),iwk(2*m+n0)
!
!
  eps0 = epsilon ( eps0 )
  rerrmn = amin1(1.e-6,1.e3*eps0)
  rerrmx = 1.e-5
  if (eps0 < 1.e-13) rerrmx = 1.e-6
!
  ip = m + n0 + 1
  call smplx1(a,b0,c,ka,m,n0,ind,ibasis,x,z,iter,mxiter, &
              eps0,rerrmn,rerrmx,rerr,numle,numge,bi, &
              wk(1),wk(m+1),iwk(1),iwk(ip))
  return
end
subroutine smplx1(a,b0,c,ka,m,n0,ind,ibasis,r,z,iter,mxiter, &
      eps0,rerrmn,rerrmx,rerr,numle,numge,bi,xb,y,basis,index)
!
!*******************************************************************************
!
!! SMPLX1: utility routine called by smplx.
!
!
!     nstep = 1   eliminate the negative variables
!     nstep = 2   phase 1 of the simplex algorithm
!     nstep = 3   phase 2 of the simplex algorithm
!
!     mxiter = the maximum number of iterations permitted
!     iter = the number of the current iteration
!     icount = the number of iterations since the last inversion
!
!     numle = the number of <= constraints
!     numge = the number of >= constraints
!
!     the routine assumes that the <= constraints precede the  >= 
!     constraints and that the == constraints come last. there are
!     m constraints. x(n0+i) is the slack, surplus, or artificial
!     variable for the i-th constraint (i=1,...,m).
!
!     n0 = the number of orginal variables
!     ns = the number of orginal and slack variables
!     n  = the number of orginal, slack, and surplus variables
!     num = the total number of variables
!
!     rerrmn = the smallest relative error tolerance used
!     rerrmx = the largest relative error tolerace used
!     rerr   = the estimated current relative error
!
!     assume that
!         b0 = (b0(1),...,b0(m))
!         c  = (c(1),...,c(n0))
!         z  = c(1)*x(1)+...+c(n0)*x(n0)
!     the problem is to maximize z subject to
!         ax(le,eq,ge)b0
!         x >= 0
!
!     on input ind can have the values
!         ind = 0   no beginning basis is provided by the user
!         ind = 1   the array ibasis has been set by the user
!     on output ind is assigned one of the values
!         ind = 0   z was successfully maximized
!         ind = 1   the problem has no feasible solution
!         ind = 2   mxiter iterations were performed
!         ind = 3   sufficient accuracy cannot be maintained
!         ind = 4   the problem has an unbounded solution
!         ind = 5   there is an input error
!         ind = 6   z was possibly maximized
!
!     basis is an integer array of dimension n0+m. for j <= n
!         basis(j) = 1  if x(j) is a basic variable
!         basis(j) = 0  if x(j) is not a basic variable
!     if the basic variables are x(i1),...,x(im) then
!         ibasis = (i1,...,im)
!     also xb(1),...,xb(m) are the corresponding values of the
!     basic variables.
!
!     bi is an mxm array containing the inverse of the basis matrix.
!
!     r is an array of dimension n. on output r contains the current
!     value of x. during computation r normally contains the reduced
!     costs used for the selection of the variable to be made basic.
!
  dimension a(ka,n0),b0(m),c(n0)
  dimension bi(m,m),xb(m),y(m),r(*)
  integer   ibasis(m),basis(*)
  integer   bflag,index(m)
  double precision dzero,dsum,dsump,dsumn,dt
  data zero/0.0/,dzero/0.d0/,one/1.0/
!
  xmax = huge ( xmax )
  iter=0
  icount=0
  mcheck=min (5,1+m/15)
  z=zero
!
!                check for input errors
!
  ms=numle+numge
  if (m < 2.or.n0 < 2.or.ms > m.or.ka < m) go to 12
  do 10 i=1,m
  if (b0(i)) 12,10,10
   10 xb(i)=zero
  rtol=xmax
  do 11 i=1,n0
  if (c(i)/=zero) rtol=amin1(abs(c(i)),rtol)
   11 continue
  rtol=rerrmx*rtol
  go to 20
   12 ind=5
  return
!
!     formation of the ibasis and basis arrays. (if ind=1
!     then the ibasis array is defined by the user.)
!
   20 ns=n0+numle
  n=ns+numge
  if (ind==0) go to 30
  num=n
  do 21 i=1,m
  if (ibasis(i) > n) num=num+1
   21 continue
  go to 32
   22 if (ind==0) go to 590
  ind=0
!
   30 num=n0+m
  do 31 i=1,m
   31 ibasis(i)=n0+i
   32 bflag=0
  do 33 i=1,n
   33 basis(i)=0
  do 34 i=1,m
  ki=ibasis(i)
   34 basis(ki)=1
  if (ind==1) go to 100
!
!          calculation of xb and bi when ind=0
!
  rerr=rerrmn
  do 41 j=1,m
  xb(j)=b0(j)
  do 40 i=1,m
   40 bi(i,j)=zero
   41 bi(j,j)=one
  if (numge==0) go to 630
  jmin=numle+1
  do 42 j=jmin,ms
  xb(j)=-xb(j)
   42 bi(j,j)=-1.0
  go to 601
!
!                  reorder the basis
!
  100 ibeg=1
  iend=m
  do 102 i=1,m
  if (ibasis(i) <= n0) go to 101
  index(ibeg)=ibasis(i)
  ibeg=ibeg+1
  go to 102
  101 index(iend)=ibasis(i)
  iend=iend-1
  102 continue
  if (iend==m) go to 22
  do 103 i=1,m
  103 ibasis(i)=index(i)
!
!            reinversion of the basis matrix
!
  do 132 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 110
  if (kj <= ns) go to 120
  if (kj <= n) go to 130
  go to 120
!
  110 do 111 i=1,m
  111 bi(i,j)=a(i,kj)
  go to 132
!
  120 l=kj-n0
  do 121 i=1,m
  121 bi(i,j)=zero
  bi(l,j)=one
  go to 132
!
  130 l=kj-n0
  do 131 i=1,m
  131 bi(i,j)=zero
  bi(l,j)=-1.0
  132 continue
!
  icount=0
  call crout1(bi,m,m,iend,index,y,jcol,ierr)
  if (ierr/=0) go to 580
!
!         check the accuracy of bi and reset rerr
!
  bnorm=zero
  do 142 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 140
  sum=one
  go to 142
  140 sum=zero
  do 141 i=1,m
  141 sum=sum+abs(a(i,kj))
  142 bnorm=max ( bnorm,sum)
!
  binorm=zero
  do 151 j=1,m
  sum=zero
  do 150 i=1,m
  150 sum=sum+abs(bi(i,j))
  151 binorm=max ( binorm,sum)
  rerr=max ( rerrmn,eps0*bnorm*binorm)
  if (rerr > 1.e-2) go to 580
  bflag=0
!
!                 recalculation of xb
!
  180 do 184 i=1,m
  dsump=dzero
  dsumn=dzero
  do 183 l=1,m
  dt=bi(i,l)*b0(l)
  if (dt) 181,183,182
  181 dsumn=dsumn+dt
  go to 183
  182 dsump=dsump+dt
  183 continue
  xb(i)=dsump+dsumn
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(xb(i)) <= tol) xb(i)=zero
  184 continue
  go to 601
!
!     find the next vector a(--,jp) to be inserted into
!                       the basis
!
  200 jp=0
  rmin=zero
  if (nstep==3) rmin=-rtol
  do 201 j=1,n0
  if (basis(j)==1) go to 201
  if (r(j) >= rmin) go to 201
  jp=j
  rmin=r(j)
  201 continue
  if (n0==n) go to 203
  jmin=n0+1
  rmin=rmin*1.1
  do 202 j=jmin,n
  if (basis(j)==1) go to 202
  if (r(j) >= rmin) go to 202
  jp=j
  rmin=r(j)
  202 continue
  203 if (jp/=0) go to 300
  if (nstep-2) 800,230,250
!
!     insert the values of the orginal, slack, and surplus
!             variables into r. then terminate.
!
  220 do 221 j=1,n
  221 r(j)=zero
  do 222 i=1,m
  ki=ibasis(i)
  if (ki <= n) r(ki)=xb(i)
  222 continue
  return
!
!              completion of the nstep=2 case
!
  230 do 231 i=1,m
  if (ibasis(i) <= n) go to 231
  if (xb(i)) 231,231,800
  231 continue
  go to 680
!
  240 if (icount >= 5) go to 100
  ind=1
  go to 220
!
!              completion of the nstep=3 case
!
  250 if (rerr > 1.e-3) go to 251
  ind=0
  go to 800
  251 if (icount >= 5) go to 100
  ind=6
  go to 800
!
!     if mxiter iterations have not been performed then
!     begin the next iteration. compute the jp-th column
!               of bi*a and store it in y.
!
  300 if (iter < mxiter) go to 301
  ind=2
  go to 220
  301 iter=iter+1
  icount=icount+1
  if (jp > ns) go to 330
  if (jp > n0) go to 320
!
  nrow=0
  amax=zero
  do 305 i=1,m
  if (a(i,jp)==zero) go to 305
  nrow=nrow+1
  index(nrow)=i
  amax=max ( abs(a(i,jp)),amax)
  305 continue
  if (nrow/=0) go to 310
  ind=4
  go to 220
!
  310 rerr1=rerrmx*amax
  do 313 i=1,m
  dsum=dzero
  do 311 ll=1,nrow
  l=index(ll)
  311 dsum=dsum+dble(bi(i,l)*a(l,jp))
  y(i)=dsum
  if (abs(y(i)) >= 1.e-3) go to 313
  bmax=zero
  do 312 l=1,m
  312 bmax=max ( abs(bi(i,l)),bmax)
  tol=rerr1*bmax
  if (abs(y(i)) <= tol) y(i)=zero
  313 continue
  go to 350
!
  320 l=jp-n0
  do 321 i=1,m
  321 y(i)=bi(i,l)
  go to 350
!
  330 l=jp-n0
  do 331 i=1,m
  331 y(i)=-bi(i,l)
!
  350 do 352 i=1,m
  if (y(i)) 351,352,351
  351 if (nstep-2) 400,430,440
  352 continue
  r(jp)=zero
  iter=iter-1
  icount=icount-1
  go to 200
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=1 case
!
  400 npos=0
  ip=0
  eps=zero
  epsi=xmax
  do 403 i=1,m
  if (xb(i) < zero.or.y(i) <= zero) go to 403
  ratio=xb(i)/y(i)
  if (ratio-epsi) 401,402,403
  401 epsi=ratio
  npos=1
  index(1)=i
  go to 403
  402 npos=npos+1
  index(npos)=i
  403 continue
  if (npos==0) go to 420
  if (epsi==zero) go to 460
!
  do 410 i=1,m
  if (xb(i) >= zero.or.y(i) >= zero) go to 410
  ratio=xb(i)/y(i)
  if (ratio > epsi) go to 410
  if (ratio < eps) go to 410
  eps=ratio
  ip=i
  410 continue
  if (ip/=0) go to 500
  go to 460
!
  420 do 421 i=1,m
  if (xb(i) >= zero.or.y(i) >= zero) go to 421
  ratio=xb(i)/y(i)
  if (ratio < eps) go to 421
  eps=ratio
  ip=i
  421 continue
  go to 500
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=2 case
!
  430 npos=0
  epsi=xmax
  do 433 i=1,m
  if (y(i) <= zero) go to 433
  ratio=xb(i)/y(i)
  if (ratio-epsi) 431,432,433
  431 epsi=ratio
  npos=1
  index(1)=i
  go to 433
  432 npos=npos+1
  index(npos)=i
  433 continue
  go to 450
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=3 case
!
  440 npos=0
  epsi=xmax
  do 445 i=1,m
  if (y(i)) 441,445,442
  441 if (ibasis(i) <= n) go to 445
  ip=i
  go to 500
  442 ratio=xb(i)/y(i)
  if (ratio-epsi) 443,444,445
  443 epsi=ratio
  npos=1
  index(1)=i
  go to 445
  444 npos=npos+1
  index(npos)=i
  445 continue
!
  450 if (npos/=0) go to 460
  if (icount >= 5) go to 100
  ind=4
  go to 220
!
!              tie breaking procedure
!
  460 ip=index(1)
  if (npos==1) go to 500
  ip = 0
  bmin=xmax
  cmin=xmax
  do 464 ii=1,npos
  i=index(ii)
  l=ibasis(i)
  if (l > n0) go to 461
  if (c(l) <= zero) cmin=amin1(zero,cmin)
  if (c(l) > cmin) go to 464
  imin=i
  cmin=c(l)
  go to 464
  461 if (l <= n) go to 462
  ip=i
  go to 500
  462 lrow=l-n0
  s=b0(lrow)
  if (lrow > numle) go to 463
  if (s > bmin) go to 464
  ip=i
  bmin=s
  go to 464
  463 s=-s
  bmin=amin1(zero,bmin)
  if (s > bmin) go to 464
  ip=i
  bmin=s
  464 continue
  if (cmin <= zero.or.ip==0) ip=imin
!
!               transformation of xb
!
  500 if (xb(ip)==zero) go to 510
  const=xb(ip)/y(ip)
  do 501 i=1,m
  s=xb(i)
  xb(i)=xb(i)-const*y(i)
  if (xb(i) >= zero) go to 501
  if (s >= zero.or.xb(i) >= rerrmx*s) xb(i)=zero
  501 continue
  xb(ip)=const
!
!               transformation of bi
!
  510 do 512 j=1,m
  if (bi(ip,j)==zero) go to 512
  const=bi(ip,j)/y(ip)
  do 511 i=1,m
  511 bi(i,j)=bi(i,j)-const*y(i)
  bi(ip,j)=const
  512 continue
!
!             updating ibasis and basis
!
  iout=ibasis(ip)
  ibasis(ip)=jp
  basis(iout)=0
  basis(jp)=1
  if (iout > n) num=num-1
!
!        check the accuracy of bi and reset rerr
!
  if (rerr > 1.e-3) go to 530
  k=0
  do 521 j=1,m
  kj=ibasis(j)
  if (kj > n0) go to 521
  sum=zero
  do 520 l=1,m
  520 sum=sum+bi(j,l)*a(l,kj)
  rerr=max ( rerr,abs(one-sum))
  k=k+1
  if (k >= mcheck) go to 522
  521 continue
  522 if (rerr <= 1.e-3) go to 600
!
!        the accuracy criteria are not satisfied
!
  530 if (icount < 5) go to 600
  bflag=1
  go to 100
!
  580 if (iter==0) go to 12
  if (bflag==0) go to 590
  bflag=0
  do 581 ip=1,m
  if (jp==ibasis(ip)) go to 582
  581 continue
  582 ibasis(ip)=iout
  basis(jp)=0
  basis(iout)=1
  if (iout > n) num=num+1
  go to 100
!
  590 ind=3
  go to 220
!
!       set up the r array for the nstep=1 case
!
  600 if (nstep-2) 601,630,700
  601 do 602 j=1,m
  if (xb(j)) 610,602,602
  602 continue
  go to 630
!
  610 nstep=1
  m0=0
  do 612 l=1,m
  if (xb(l)) 611,612,612
  611 m0=m0+1
  index(m0)=l
  612 continue
!
  do 623 j=1,m
  dsump=dzero
  dsumn=dzero
  do 622 ll=1,m0
  l=index(ll)
  if (bi(l,j)) 620,622,621
  620 dsumn=dsumn+dble(bi(l,j))
  go to 622
  621 dsump=dsump+dble(bi(l,j))
  622 continue
  y(j)=dsump+dsumn
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(y(j)) <= tol) y(j)=zero
  623 continue
  go to 650
!
!       set up the r array for the nstep=2 case
!
  630 if (n==num) go to 680
  nstep=2
  m0=0
  do 631 l=1,m
  if (ibasis(l) <= n) go to 631
  m0=m0+1
  index(m0)=l
  631 continue
!
  do 643 j=1,m
  dsump=dzero
  dsumn=dzero
  do 642 ll=1,m0
  l=index(ll)
  if (bi(l,j)) 640,642,641
  640 dsumn=dsumn+dble(bi(l,j))
  go to 642
  641 dsump=dsump+dble(bi(l,j))
  642 continue
  y(j)=-(dsump+dsumn)
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(y(j)) <= tol) y(j)=zero
  643 continue
!
  650 do 653 j=1,n0
  sum=zero
  if (basis(j)/=0) go to 653
  do 652 l=1,m
  if (a(l,j)) 651,652,651
  651 sum=sum+y(l)*a(l,j)
  652 continue
  653 r(j)=sum
!
  660 if (n0==ns) go to 670
  jmin=n0+1
  do 661 j=jmin,ns
  r(j)=zero
  if (basis(j)/=0) go to 661
  jj=j-n0
  r(j)=y(jj)
  661 continue
!
  670 if (ns==n) go to 200
  jmin=ns+1
  do 671 j=jmin,n
  r(j)=zero
  if (basis(j)/=0) go to 671
  jj=j-n0
  r(j)=-y(jj)
  671 continue
  go to 200
!
!      set up a new r array for the nstep=3 case
!
  680 nstep=3
  do 682 j=1,m
  dsum=dzero
  do 681 l=1,m
  il=ibasis(l)
  if (il <= n0) dsum=dsum+dble(c(il)*bi(l,j))
  681 continue
  682 y(j)=dsum
!
  do 691 j=1,n0
  r(j)=zero
  if (basis(j)/=0) go to 691
  dsum=-c(j)
  do 690 l=1,m
  690 dsum=dsum+dble(y(l)*a(l,j))
  r(j)=dsum
  if (r(j) >= zero) go to 691
  tol=rerrmx*abs(c(j))
  if (abs(r(j)) <= tol) r(j)=zero
  691 continue
  go to 660
!
!       update the r array for the nstep=3 case
!
  700 const=r(jp)
  do 703 j=1,n0
  if (basis(j)==0) go to 701
  r(j)=zero
  go to 703
  701 sum=zero
  do 702 l=1,m
  702 sum=sum+bi(ip,l)*a(l,j)
  r(j)=r(j)-const*sum
  if (r(j) >= zero) go to 703
  tol=rerrmx*abs(c(j))
  if (abs(r(j)) <= tol) r(j)=zero
  703 continue
!
  710 if (n0==ns) go to 720
  jmin=n0+1
  do 712 j=jmin,ns
  if (basis(j)==0) go to 711
  r(j)=zero
  go to 712
  711 jj=j-n0
  r(j)=r(j)-const*bi(ip,jj)
  712 continue
!
  720 if (ns==n) go to 200
  jmin=ns+1
  do 722 j=jmin,n
  if (basis(j)==0) go to 721
  r(j)=zero
  go to 722
  721 jj=j-n0
  r(j)=r(j)+const*bi(ip,jj)
  722 continue
  go to 200
!
!
!        refine xb and store the result in y
!
  800 do 801 i=1,m
  801 y(i)=zero
!
  m0=0
  do 831 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 810
  if (kj <= ns) go to 820
  if (kj <= n) go to 830
  go to 820
!
  810 m0=m0+1
  index(m0)=j
  go to 831
!
  820 l=kj-n0
  y(l)=xb(j)
  go to 831
!
  830 l=kj-n0
  y(l)=-xb(j)
  831 continue
!
  if (m0/=0) go to 841
  do 840 i=1,m
  840 r(i)=b0(i)-y(i)
  go to 850
  841 do 843 i=1,m
  dsum=y(i)
  do 842 jj=1,m0
  j=index(jj)
  kj=ibasis(j)
  842 dsum=dsum+dble(a(i,kj)*xb(j))
  843 r(i)=b0(i)-dsum
!
  850 rerr1=amin1(rerrmx,rerr)
  do 858 i=1,m
  if (xb(i)) 851,857,852
  851 dsump=dzero
  dsumn=xb(i)
  go to 853
  852 dsump=xb(i)
  dsumn=dzero
  853 do 856 l=1,m
  dt=bi(i,l)*r(l)
  if (dt) 854,856,855
  854 dsumn=dsumn+dt
  go to 856
  855 dsump=dsump+dt
  856 continue
  y(i)=dsump+dsumn
  if (xb(i) > zero.and.y(i) < zero) go to 857
  if (xb(i) < zero.and.y(i) > zero) go to 857
  s=dsump
  t=dsumn
  tol=rerr1*max ( s,-t)
  if (abs(y(i)) > tol) go to 858
  857 y(i)=zero
  858 continue
  if (nstep-2) 860,870,880
!
!          check the refinement (nstep=1)
!
  860 do 861 i=1,m
  if (y(i) >= zero) go to 861
  if (y(i) < -rerrmx) go to 240
  y(i)=zero
  861 xb(i)=y(i)
  go to 630
!
!          check the refinement (nstep=2)
!
  870 do 871 i=1,m
  if (ibasis(i) <= n) go to 871
  if (y(i) > rerrmx) go to 240
  y(i)=zero
  871 xb(i)=y(i)
  go to 680
!
!               compute z  (nstep=3)
!
  880 dsum=dzero
  do 881 i=1,m
  ki=ibasis(i)
  if (ki > n0) go to 881
  dsum=dsum+dble(c(ki)*y(i))
  881 xb(i)=y(i)
  z=dsum
  go to 220
end
subroutine smprod(m,n,a,ka,b)
!
!*******************************************************************************
!
!! SMPROD ???
!
  real a(ka,n),b(*)
  double precision s
!
  ii=1
  do i=1,n
    do 11 j=1,i
      s = 0.d0
      do k=1,m
        s = s + dble(a(k,i))*dble(a(k,j))
      end do
      b(ii) = s
   11 ii = ii + 1
  end do

  return
end
subroutine smslv(mo,n,m,a,b,kb,det,rcond,inert,ierr,ipvt,wk)
!
!*******************************************************************************
!
!! SMSLV: matrix factorization and computation of rcond
!
  real a(*),b(*)
  real det(2),rcond,t,wk(n)
  integer inert(3),ipvt(n),onej
!
  ierr = 0
  call sspco(a,n,ipvt,rcond,wk)
  t = 1.0 + rcond
  if (t == 1.0) go to 30
!
!                  solution of the equation ax=b
!
  if (m < 1) go to 20
  onej = 1
  do 10 j=1,m
  call sspsl(a,n,ipvt,b(onej))
   10 onej = onej + kb
!
!             calculation of det and the inverse of a
!
   20 job = 110
  if (mo == 0) job = 111
  call sspdi(a,n,ipvt,det,inert,wk,job)
  return
!
!                  the problem cannot be solved
!
   30 ierr = 1
  return
end
subroutine smsubt(n,a,b,c)
!
!*******************************************************************************
!
!! SMSUBT: ???
!
  real a(*),b(*),c(*)
  m=(n*(n+1))/2
  do 10 k=1,m
   10 c(k)=a(k)-b(k)
  return
end
subroutine snbfa (a, lda, n, ml, mu, ipvt, info)
!
!*******************************************************************************
!
!! SNBFA factors a real band matrix by elimination.
!
!
!     on entry
!
!        a       real(lda, nc)
!                contains the matrix in band storage. the rows
!                of the original matrix are stored in the rows
!                of a and the diagonals of the original matrix
!                are stored in columns 1 through ml+mu+1 of a.
!                nc must be >= 2*ml+mu+1 .
!                see the comments below for details.
!
!        lda     integer
!                the leading dimension of the array a. it is
!                assumed that lda >= n.
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!                0 <= ml < n .
!
!        mu      integer
!                number of diagonals above the main diagonal.
!                0 <= mu < n .
!                more efficient if ml <= mu .
!
!     on return
!
!        a       an upper triangular matrix in band storage
!                and the multipliers which were used to obtain it.
!                the factorization can be written  a = l*u  where
!                l is a product of permutation and unit lower
!                triangular matrices and u is upper triangular.
!
!        ipvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                =0  normal value
!                =k  if  u(k,k) == 0. this is not an error
!                condition for this subroutine, but it does
!                indicate that snbsl will divide by zero if
!                it is called.
!
!     band storage
!
!           if a0 is the matrix then the following code will store
!           a0 in band form.
!
!                   ml = (band width below the diagonal)
!                   mu = (band width above the diagonal)
!                   do 20 i = 1, n
!                      j1 = max (1, i-ml)
!                      j2 = min (n, i+mu)
!                      do 10 j = j1, j2
!                         k = j - i + ml + 1
!                         a(i,k) = a0(i,j)
!                10    continue
!                20 continue
!
!           this uses columns 1 through  ml + mu + 1  of a.
!           furthermore, ml additional columns are needed in
!           a (starting with column  ml+mu+2) for elements
!           generated during the triangularization. the total
!           number of columns needed in a is  2*ml+mu+1 .
!
!     example..  if the original matrix is
!
!           11 12 13  0  0  0
!           21 22 23 24  0  0
!            0 32 33 34 35  0
!            0  0 43 44 45 46
!            0  0  0 54 55 56
!            0  0  0  0 65 66
!
!      then  n = 6, ml = 1, mu = 2, lda >= 6  and a should contain
!
!            * 11 12 13  +     , * = not used
!           21 22 23 24  +     , + = used for pivoting
!           32 33 34 35  +
!           43 44 45 46  +
!           54 55 56  *  +
!           65 66  *  *  +
!
!     written by e.a.voorhees, los alamos scientific laboratory.
!     modified by a.h.morris, Naval Surface Weapons Center,.
!
!     subroutines and functions
!        min0,isamax,saxpy,sscal,sswap
!
  integer lda,n,ml,mu,info
  real a(lda,*)
  integer ipvt(n)
  real t
  integer ml1,mb,m,n1,ldb,i,j,k,l,lm,lm1,lm2,mp,isamax
  integer lmk,ll,jj,j1
!
  info = 0
  if (ml == 0) go to 100
  m = ml + mu + 1
!
!     set fill-in columns to zero
!
  do 11 j = 1,ml
  jj = m + j
    do 10 i = 1,n
   10   a(i,jj) = 0.0
   11 continue
!
!     gaussian elimination with partial pivoting
!
  ml1 = ml + 1
  mb = ml + mu
  n1 = n - 1
  ldb = lda - 1
  do 40 k = 1,n1
    lm = min (n-k,ml)
    lmk = lm + k
    lm1 = lm + 1
    lm2 = ml1 - lm
!
!     search for pivot index
!
    l = -isamax(lm1, a(lmk,lm2), ldb) + lm1 + k
    ipvt(k) = l
    mp = min (mb,n-k)
!
!     swap rows if necessary
!
    ll = ml1 + k - l
    if (l /= k) call sswap(mp + 1, a(k,ml1), lda, a(l,ll), lda)
!
!     skip column reduction if pivot is zero
!
    if (a(k,ml1) /= 0.0) go to 20
       info = k
       go to 40
!
!     compute multipliers
!
   20   t = -1.0/a(k,ml1)
    call sscal(lm, t, a(lmk,lm2), ldb)
!
!     row elimination with column indexing
!
    do 30 j = 1,mp
       jj = ml1 + j
       j1 = lm2 + j
       call saxpy(lm, a(k,jj), a(lmk,lm2), ldb, a(lmk,j1), ldb)
   30   continue
   40 continue
!
  ipvt(n) = n
  if (a(n,ml1) == 0.0) info = n
  return
!
!     case when ml = 0
!
  100 do 110 k = 1,n
    ipvt(k) = k
    if (a(k,1) == 0.0) info = k
  110 continue
  return
end
subroutine snbsl(a,lda,n,ml,mu,ipvt,b,job)
!
!*******************************************************************************
!
!! SNBSL solves the real band system a*x = b or trans(a)*x = b
!     using the factors computed by snbco or snbfa.
!
!
!     on entry
!
!        a       real(lda, nc)
!                the output from snbco or snbfa.
!                nc must be >= 2*ml+mu+1 .
!
!        lda     integer
!                the leading dimension of the array a.
!
!        n       integer
!                the order of the original matrix.
!
!        ml      integer
!                number of diagonals below the main diagonal.
!
!        mu      integer
!                number of diagonals above the main diagonal.
!
!        ipvt    integer(n)
!                the pivot vector from snbco or snbfa.
!
!        b       real(n)
!                the right hand side vector.
!
!        job     integer
!                = 0         to solve  a*x = b .
!                = nonzero   to solve  trans(a)*x = b , where
!                            trans(a)  is the transpose.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains a
!        zero on the diagonal.  technically this indicates singularity
!        but it is often caused by improper arguments or improper
!        setting of lda.  it will not occur if the subroutines are
!        called correctly and if snbco has set rcond > 0.0
!        or snbfa has set info == 0 .
!
!     written by e.a. voorhees, los alamos scientific laboratory.
!     modified by a.h. morris, Naval Surface Weapons Center,.
!
  integer lda,n,ml,mu,job
  real a(lda,*),b(n)
  integer ipvt(n)
  real sdot,t
  integer k,kb,klm,l,lb,ldb,lm,m,mlm,nm1
!
  m = mu + ml + 1
  if (m == 1) go to 100
  ml1 = ml + 1
  ml2 = ml + 2
  nm1 = n - 1
  ldb = 1 - lda
  if (job /= 0) go to 50
!
!     job = 0 , solve  a * x = b
!       first solve l*y = b
!
  if (ml == 0) go to 30
  do 20 k = 1,nm1
     lm = min (ml,n-k)
     l = ipvt(k)
     t = b(l)
     if (l == k) go to 10
        b(l) = b(k)
        b(k) = t
   10    klm = k + lm
     mlm = ml1 - lm
     call saxpy(lm, t, a(klm,mlm), ldb, b(k+1), 1)
   20 continue
!
!       now solve  u*x = y
!
   30 k = n
  do 40 kb = 2,n
     b(k) = b(k)/a(k,ml1)
     lm = min (k,m) - 1
     lb = k - lm
     t = -b(k)
     call saxpy(lm, t, a(k-1,ml2), ldb, b(lb), 1)
   40 k = k - 1
  b(1) = b(1)/a(1,ml1)
  return
!
!     job = nonzero, solve trans(a) * x = b
!       first solve  trans(u)*y = b
!
   50 b(1) = b(1)/a(1,ml1)
  do 60 k = 2,n
     lm = min (k,m) - 1
     lb = k - lm
     t = sdot(lm, a(k-1,ml2), ldb, b(lb), 1)
     b(k) = (b(k) - t)/a(k,ml1)
   60 continue
  if (ml == 0) return
!
!       now solve trans(l)*x = y
!
  do 70 kb = 1,nm1
     k = n - kb
     lm = min (ml,n-k)
     klm = k + lm
     mlm = ml1 - lm
     b(k) = b(k) + sdot(lm, a(klm,mlm), ldb, b(k+1), 1)
     l = ipvt(k)
     if (l == k) go to 70
        t = b(l)
        b(l) = b(k)
        b(k) = t
   70 continue
  return
!
!     case when ml = 0 and mu = 0
!
  100 do 110 k = 1,n
  110 b(k) = b(k)/a(k,1)
  return
end
subroutine snhcsh (sinhm,coshm,x,isw)
!
!*******************************************************************************
!
!! SNHCSH approximates sinh(x)-x, cosh(x)-1 and cosh(x)-1-x*x/2.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!                          modified by a.h. morris (nswc/dl)
!
! on input--
!
!   x contains the value of the independent variable.
!
!   isw indicates the function desired
!           = -1 if only sinhm is desired,
!           =  0 if both sinhm and coshm are desired,
!           =  1 if only coshm is desired,
!           =  2 if only coshmm is desired,
!           =  3 if both sinhm and coshmm are desired.
!
! on output--
!
!   sinhm contains the value of sinhm(x) if isw <= 0 or
!   isw == 3 (sinhm is unaltered if isw ==1 or isw ==
!   2).
!
!   coshm contains the value of coshm(x) if isw == 0 or
!   isw == 1 and contains the value of coshmm(x) if isw
!   >= 2 (coshm is unaltered if isw == -1).
!
! and
!
!   x and isw are unaltered.
!
!
  integer isw
  real sinhm,coshm,x,cut(5)
!
  data sp5/.255251817302048e-09/, &
       sp4/.723809046696880e-07/, &
       sp3/.109233297700241e-04/, &
       sp2/.954811583154274e-03/, &
       sp1/.452867078563929e-01/, &
       sq1/-.471329214363072e-02/
  data cp5/.116744361560051e-08/, &
       cp4/.280407224259429e-06/, &
       cp3/.344417983443219e-04/, &
       cp2/.232293648552398e-02/, &
       cp1/.778752378267155e-01/, &
       cq1/-.545809550662099e-02/
  data zp3/5.59297116264720e-07/, &
       zp2/1.77943488030894e-04/, &
       zp1/1.69800461894792e-02/, &
       zq4/1.33412535492375e-09/, &
       zq3/-5.80858944138663e-07/, &
       zq2/1.27814964403863e-04/, &
       zq1/-1.63532871439181e-02/
  data cut(1)/1.65/, cut(2)/1.2/, cut(3)/1.2/, cut(4)/2.7/, &
       cut(5)/1.65/
!
  xx = x
  ax = abs(xx)
  xs = xx*xx
  if (ax >= cut(isw+2)) expx = exp(ax)
!
! sinhm approximation
!
  if (isw == 1 .or. isw == 2) go to 2
  if (ax >= 1.65) go to 1
  sinhm = ((((((sp5*xs+sp4)*xs+sp3)*xs+sp2)*xs+sp1)*xs+1.) &
          *xs*xx)/((sq1*xs+1.)*6.)
  go to 2
1 sinhm = -(((ax+ax)+1./expx)-expx)/2.
  if (xx < 0.) sinhm = -sinhm
!
! coshm approximation
!
2 if (isw /= 0 .and. isw /= 1) go to 4
  if (ax >= 1.2) go to 3
  coshm = ((((((cp5*xs+cp4)*xs+cp3)*xs+cp2)*xs+cp1)*xs+1.) &
          *xs)/((cq1*xs+1.)*2.)
  go to 4
3 coshm = ((1./expx-2.)+expx)/2.
!
! coshmm approximation
!
4 if (isw <= 1) return
  if (ax >= 2.70) go to 5
  coshm = ((((zp3*xs+zp2)*xs+zp1)*xs+1.)*xs*xs)/(((((zq4 &
          *xs+zq3)*xs+zq2)*xs+zq1)*xs+1.)*24.)
  return
5 coshm = (((1./expx-2.)-xs)+expx)/2.
  return
end
function snrm2 ( n, x, incx )
!
!*******************************************************************************
!
!! SNRM2 computes the Euclidean norm of a vector.
!
!
!  Discussion:
!
!    The original SNRM2 algorithm is accurate but written in a bizarre,
!    unreadable and obsolete format.  This version goes for clarity.
!
!  Modified:
!
!    01 June 2000
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real X(*), the vector whose norm is to be computed.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Output, real SNRM2, the Euclidean norm of X.
!
  integer i
  integer incx
  integer ix
  integer n
  real samax
  real snrm2
  real stemp
  real x(*)
  real xmax
!
  if ( n <= 0 ) then

    snrm2 = 0.0E+00

  else

    xmax = samax ( n, x, incx )

    if ( xmax == 0.0E+00 ) then

      snrm2 = 0.0E+00

    else

      if ( incx >= 0 ) then
        ix = 1
      else
        ix = ( - n + 1 ) * incx + 1
      end if

      stemp = 0.0E+00
      do i = 1, n
        stemp = stemp + ( x(ix) / xmax )**2
        ix = ix + incx
      end do

      snrm2 = xmax * sqrt ( stemp )

    end if

  end if

  return
end
subroutine sol (n, ndim, a, b, ip)
!
!*******************************************************************************
!
!! SOL: solution of linear system, a*x = b.
!
! input..
!   n = order of matrix.
!   ndim = declared dimension of array  a .
!   a = triangularized matrix obtained from dec.
!   b = right hand side vector.
!   ip = pivot vector obtained from dec.
! do not use if dec has set ier /= 0.
! output..
!   b = solution vector, x .
!
  integer ip, n, ndim
  integer i, k, kb, km1, kp1, m, nm1
  real a, b
  real t
  dimension a(ndim, n), b(n), ip(n)
!
  if (n == 1) go to 50
  nm1 = n - 1
!  apply row permutations and multipliers to b.
  do 20 k = 1,nm1
    kp1 = k + 1
    m = ip(k)
    t = b(m)
    b(m) = b(k)
    b(k) = t
    do 10 i = kp1,n
 10       b(i) = b(i) + a(i,k)*t
 20     continue
!  back solve.
  do 40 kb = 1,nm1
    km1 = n - kb
    k = km1 + 1
    b(k) = b(k)/a(k,k)
    t = -b(k)
    do 30 i = 1,km1
 30       b(i) = b(i) + a(i,k)*t
 40     continue
 50   b(1) = b(1)/a(1,1)
  return
end
subroutine solbt (m, n, a, b, c, y, ip)
!
!*******************************************************************************
!
!! SOLBT: solution of block-tridiagonal linear system.
!
!
! coefficient matrix must have been previously processed by decbt.
! m, n, a, b, c, and ip  must not have been changed since call to decbt.
! written by a. c. hindmarsh.
! input..
!     m = order of each block.
!     n = number of blocks in each direction of matrix.
! a,b,c = m by m by n arrays containing block lu decomposition
!         of coefficient matrix from decbt.
!    ip = m by n integer array of pivot information from decbt.
!     y = array of length m*n containing the right-hand side vector
!         (treated as an m by n array here).
! output..
!     y = solution vector, of length m*n.
! solbt makes calls to subroutine sol(m,m0,a,y,ip)
! for solution of m by m linear systems.
!
  integer m, n, ip(m,n)
  real a(m,m,n), b(m,m,n), c(m,m,n), y(m,n)
!
!
  integer nm1, nm2, km1, i, j, k
  real dp
  nm1 = n - 1
  nm2 = n - 2
! forward solution sweep.
  call sol (m, m, a, y, ip)
  do 30 k = 2,nm1
    km1 = k - 1
    do 20 i = 1,m
      dp = 0.
      do 10 j = 1,m
 10         dp = dp + c(i,j,k)*y(j,km1)
      y(i,k) = y(i,k) - dp
 20       continue
    call sol (m, m, a(1,1,k), y(1,k), ip(1,k))
 30     continue
  do 50 i = 1,m
    dp = 0.
    do 40 j = 1,m
 40       dp = dp + c(i,j,n)*y(j,nm1) + b(i,j,n)*y(j,nm2)
    y(i,n) = y(i,n) - dp
 50     continue
  call sol (m, m, a(1,1,n), y(1,n), ip(1,n))
! backward solution sweep.
  do 80 kb = 1,nm1
    k = n - kb
    kp1 = k + 1
    do 70 i = 1,m
      dp = 0.
      do 60 j = 1,m
 60         dp = dp + b(i,j,k)*y(j,kp1)
      y(i,k) = y(i,k) - dp
 70       continue
 80     continue
  do 100 i = 1,m
    dp = 0.
    do 90 j = 1,m
 90       dp = dp + c(i,j,1)*y(j,3)
    y(i,1) = y(i,1) - dp
 100    continue
  return
end
subroutine solve2(m, n, m1, a, b, w, n1, ipivot, qr, d, &
   eta, fail, numit, digitx, &
   x, res, wres, y1, y2, y, f, g, mm, mmpnn)
!
!*******************************************************************************
!
!! SOLVE2:
!
  integer ipivot(n)
  real a(mm,n), b(*), c, d(*), f(*), g(*), &
   qr(mmpnn,n), res(*), w(m), wres(*), x(*), y(*), y1(*), y2(*)
  real digitx, dxnorm, eta, eta2, rdr1, rdr2, rdx1, rdx2, rnr, &
   rnx, xnorm
  double precision sum
  logical fail
  numit = 0
  kz = 0
  eta2 = eta*eta
  mp1 = m + 1
  mpn = m + n
  n1p1 = n1 + 1
  do 10 i=1,m
    f(i) = b(i)*w(i)
    g(i) = 0.0
    wres(i) = 0.0
    res(i) = 0.0
    y1(i) = 0.0
    if (w(i)==0.0) kz = kz + 1
   10 continue
  do 20 ns=1,n
    j = m + ns
    f(j) = 0.0
    g(j) = 0.0
    x(ns) = 0.0
    y2(ns) = 0.0
   20 continue
  k = 0
  rdx2 = 0.0
  rdr2 = 0.0
! begin k-th iteration step.
   30 if (k < 2) go to 40
  if (((64.*rdx2 < rdx1) .and. (rdx2 > eta2*rnx)) .or. &
   ((64.*rdr2 < rdr1) .and. (rdr2 > eta2*rnr))) go to 40
  go to 270
   40 rdx1 = rdx2
  rdr1 = rdr2
  rdx2 = 0.0
  rdr2 = 0.0
  if (k==0) go to 160
! new residuals.
  do 50 i=1,m
    wres(i) = wres(i) + f(i)*w(i)
    if (w(i)==0.0) go to 50
    res(i) = res(i) + f(i)/w(i)
    y1(i) = y1(i) + g(i)
   50 continue
  do 100 ns=1,n
    j = m + ns
    np = ipivot(ns)
    x(np) = x(np) + f(j)
    y2(np) = y2(np) + g(j)
    sum = -dble(x(np))
    do 60 l=1,m
      sum = sum + dble(a(l,np))*dble(y1(l))
   60   continue
    g(j) = -sum
    if (ns > n1) go to 70
    go to 80
   70   f(j) = 0.0
    go to 100
   80   sum = 0.0
    do 90 l=1,m
      sum = sum + dble(a(l,np))*dble(wres(l))
   90   continue
    f(j) = -sum
  100 continue
  do 130 i=1,m
    sum = 0.0
    if (i > m1) sum = dble(res(i))
    do 110 l=1,n
      sum = sum + dble(a(i,l))*dble(x(l))
  110   continue
    sum = sum - dble(b(i))
    f(i) = -sum
    f(i) = f(i)*w(i)
    if (w(i)==0.0) res(i) = dble(res(i)) - sum
    sum = 0.0
    if (i > m1) sum = dble(y1(i))
    do 120 l=1,n
      sum = sum + dble(a(i,l))*dble(y2(l))
  120   continue
    g(i) = -sum
  130 continue
  if (n1p1 > n) go to 160
  do 150 i=n1p1,n
    ns = n + n1p1 - i
    j = m + ns
    sum = 0.0
    do 140 l=1,j
      sum = sum + dble(qr(l,ns))*dble(g(l))
  140   continue
    g(j) = sum
  150 continue
! end new residuals.
!
  160 call solve3(f, m1, m, n1, qr, d, y, mmpnn)
!
  if (n1p1 > n) go to 200
  do 190 ns=n1p1,n
    j = m + ns
    sum = dble(g(j))
    do 170 l=mp1,j
      sum = sum + dble(qr(l,ns))*dble(f(l))
  170   continue
    c = sum
    c = c/d(ns)
    do 180 i=1,j
      f(i) = f(i) - c*qr(i,ns)
  180   continue
  190 continue
  200 do 210 j=mp1,mpn
    g(j) = 0.0
    if (j <= m+n1) g(j) = g(j) + f(j)
  210 continue
!
  call solve3(g, m1, m, n1, qr, d, y, mmpnn)
!
  do 220 i=1,m
    rdr2 = rdr2 + f(i)*f(i)
  220 continue
  do 230 i=mp1,mpn
    rdx2 = rdx2 + f(i)*f(i)
  230 continue
  if (k/=0) go to 240
  rnr = rdr2
  rnx = rdx2
  240 if (k/=1) go to 260
  xnorm = sqrt(rnx)
  dxnorm = sqrt(rdx2)
  if (xnorm/=0.0) go to 250
  digitx = -alog10(eta)
  go to 260
  250 digitx = -alog10(max ( dxnorm/xnorm,eta))
! end k-th iteration step.
  260 numit = k
  k = k + 1
  go to 30
  270 if ((m1+kz==m) .and. (rdx2 > 4.*eta2*rnx)) go to 280
  if ((rdr2 > 4.*eta2*rnr) .and. &
   (rdx2 > 4.*eta2*rnx)) go to 280
  fail = .false.
  return
  280 fail = .true.
  return
end
subroutine solve3(f, m1, m, n1, qr, d, y, mmpnn)
!
!*******************************************************************************
!
!! SOLVE3 is called only by solve2.
!
!
! this subroutine calculates new values of f.
!
  real c, d(*), f(*), qr(mmpnn,n1), y(*)
  double precision sum
  mv = 1
  mh = m1
  do 100 ns=1,n1
    j = m + ns
    if (ns==m1+1) go to 10
    go to 20
   10   mv = m1 + 1
    mh = m
   20   nsm1 = ns - 1
    sum = -dble(f(j))
    if (ns==1) go to 40
    do 30 l=1,nsm1
      mpl = m + l
      sum = sum + dble(qr(mpl,ns))*dble(y(l))
   30   continue
   40   y(ns) = -sum
    if (ns > m1) go to 50
    go to 60
   50   c = -y(ns)
    go to 70
   60   c = 0.0
   70   sum = dble(c)
    do 80 l=mv,mh
      sum = sum + dble(qr(l,ns))*dble(f(l))
   80   continue
    c = sum
    c = c/d(ns)
    f(j) = c
    do 90 l=mv,m
      f(l) = f(l) - c*qr(l,ns)
   90   continue
  100 continue
  if (1 > m1) go to 150
  do 110 l=1,m1
    f(l) = 0.0
  110 continue
  do 140 ns=1,m1
    sum = -dble(y(ns))
    do 120 l=1,m
      sum = sum + dble(qr(l,ns))*dble(f(l))
  120   continue
    c = sum
    c = c/d(ns)
    do 130 l=1,m1
      f(l) = f(l) - c*qr(l,ns)
  130   continue
  140 continue
  150 do 170 ns=1,n1
    j = m + n1 + 1 - ns
    mpn1 = m + n1
    sum = 0.0
    do 160 l=j,mpn1
      lmm = l - m
      sum = sum + dble(qr(j,lmm))*dble(f(l))
  160   continue
    f(j) = -sum
  170 continue
  return
end
subroutine spfit (x, y, wgt, m, break, l, z, a, b, c, wk, ierr)
!
!*******************************************************************************
!
!! SPFIT: least squares cubic spline fitting
!
  real x(m), y(m), wgt(m), break(l)
  real z(*), a(*), b(*), c(*), wk(*)
  real temp(20)
  integer pa, pq, pw
!
!     real z(l-1), a(l-1), b(l-1), c(l-1), wk(7*l + 18)
!
  if (l < 2) go to 100
  n = l + 2
!
!                define the nodes for the b-splines
!
  wk(1) = break(1)
  wk(2) = break(1)
  wk(3) = break(1)
  wk(4) = break(1)
  do 10 j = 2,l
     if (break(j - 1) >= break(j)) go to 110
     wk(j + 3) = break(j)
   10 continue
  wk(l + 4) = break(l)
  wk(l + 5) = break(l)
  wk(l + 6) = break(l)
!
!     obtain the b-spline coefficients of the least squares fit
!
  pa = n + 5
  pw = pa + n
  pq = pw + n
  call bsl2 (wk(1), n, 4, x, y, wgt, m, wk(pa), &
               wk(pw), wk(pq), ierr)
  if (ierr /= 0) go to 120
!
!     obtain the coefficients of the fit in taylor series form
!
  call bspp (wk(1), wk(pa), n, 4, break, &
               wk(pq), lm1, temp)
  k = pq
  do 20 j = 1,lm1
     z(j) = wk(k)
     a(j) = wk(k + 1)
     b(j) = wk(k + 2)
     c(j) = wk(k + 3)
   20 k = k + 4
  return
!
!                       error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
  120 ierr = 3
  return
end
subroutine splift (x,y,yp,ypp,n,w,ierr,isx,a1,b1,an,bn)
!
!*******************************************************************************
!
!! SPLIFT fits an interpolating cubic spline to data.
!
!
!     sandia mathematical program library
!     applied mathematics division 2642
!     sandia laboratories
!     albuquerque, new mexico  87115
!     control data 6600 version 6.1  january 1976
!
!   *                 issued by sandia laboratories,
!   *                   a prime contractor to the
!   *   united states energy research and development administration
!   * * * * * * * * * * * * * *  notice   * * * * * * * * * * * * * * *
!   * this report was prepared as an account of work sponsored by the
!   * united states government.  neither the united states nor the
!   * united states energy research and development administration,
!   * nor any of their employees, nor any of their contractors,
!   * subcontractors, or their employees, makes any warranty, express
!   * or implied, or assumes any legal liability or responsibility
!   * for the accuracy, completeness or usefulness of any information,
!   * apparatus, product or process disclosed, or represents that its
!   * use would not infringe privately owned rights.
!
!     written by rondall e. jones
!
!     abstract
!         splift fits an interpolating cubic spline to the n data points
!         given in x and y and returns the first and second derivatives
!         in yp and ypp.
!
!     description of arguments
!
!       --input--
!
!         x    - array of abscissas of data (in increasing order)
!         y    - array of ordinates of data
!         n    - the number of data points.  the arrays x, y, yp, and
!                ypp must be dimensioned at least n.  (n >= 4)
!         isx  - must be zero on the initial call to splift.
!                if a spline is to be fitted to a second set of data
!                that has the same set of abscissas as a previous set,
!                and if the contents of w have not been changed since
!                that previous fit was computed, then isx may be
!                set to one for faster execution.
!         a1,b1,an,bn - specify the end conditions for the spline which
!                are expressed as constraints on the second derivative
!                of the spline at the end points (see ypp).
!                the end condition constraints are
!                        ypp(1) = a1*ypp(2) + b1
!                and
!                        ypp(n) = an*ypp(n-1) + bn
!                where
!                        abs(a1) <  1.0  and  abs(an) <  1.0.
!
!                the smoothest spline (i.e., least integral of square
!                of second derivative) is obtained by a1=b1=an=bn=0.
!                in this case there is an inflection at x(1) and x(n).
!                if the data is to be extrapolated (say, by using splint
!                to evaluate the spline outside the range x(1) to x(n)),
!                then taking a1=an=0.5 and b1=bn=0 may yield better
!                results.  in this case there is an inflection
!                at x(1) - (x(2)-x(1)) and at x(n) + (x(n)-x(n-1)).
!                in the more general case of a1=an=a  and b1=bn=0,
!                there is an inflection at x(1) - (x(2)-x(1))*a/(1.0-a)
!                and at x(n) + (x(n)-x(n-1))*a/(1.0-a).
!
!                a spline that has a given first derivative yp1 at x(1)
!                and ypn at y(n) may be defined by using the
!                following conditions.
!
!                a1=-0.5
!
!                b1= 3.0*((y(2)-y(1))/(x(2)-x(1))-yp1)/(x(2)-x(1))
!
!                an=-0.5
!
!                bn=-3.0*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn)/(x(n)-x(n-1))
!
!       --output--
!
!         yp   - array of first derivatives of spline (at the x(i))
!         ypp  - array of second derivatives of spline (at the x(i))
!         ierr - a status code
!              --normal code
!                 0 means that the requested spline was computed.
!              --abnormal codes
!                 1 means that abs(a1) or abs(an) was >= 1.
!                 2 means that n, the number of points, was < 4.
!                 3 means the abscissas were not strictly increasing.
!
!       --work--
!
!         w    - array of working storage dimensioned at least 3n.
!
  real x(n), y(n), yp(n), ypp(n), w(n,3)
!
  if (abs(a1) >= 1.0 .or. abs(an) >= 1.0) go to 100
  if (n < 4) go to 200
  nm1  = n-1
  nm2  = n-2
  if (isx > 0) go to 40
  do 5 i=2,n
  if (x(i)-x(i-1)) 300,300,5
5 continue
!
!     define the tridiagonal matrix
!
  w(1,3) = x(2)-x(1)
  do 10 i=2,nm1
  w(i,2) = w(i-1,3)
  w(i,3) = x(i+1)-x(i)
   10 w(i,1) = 2.0*(w(i,2)+w(i,3))
  w(1,1) = 4.0
  w(1,3) =-4.0*a1
  w(n,1) = 4.0
  w(n,2) =-4.0*an
!
!     l u decomposition
!
  do 30 i=2,n
  w(i-1,3) = w(i-1,3)/w(i-1,1)
   30 w(i,1)   = w(i,1) - w(i,2)*w(i-1,3)
!
!     define *constant* vector
!
   40 ypp(1) = 4.0*b1
  dold   = (y(2)-y(1))/w(2,2)
  do 50 i=2,nm2
  dnew   = (y(i+1) - y(i))/w(i+1,2)
  ypp(i) = 6.0*(dnew - dold)
  yp(i)  = dold
   50 dold   = dnew
  dnew   = (y(n)-y(n-1))/(x(n)-x(n-1))
  ypp(nm1) = 6.0*(dnew - dold)
  ypp(n) = 4.0*bn
  yp(nm1)= dold
  yp(n)  = dnew
!
!     forward substitution
!
  ypp(1) = ypp(1)/w(1,1)
  do 60 i=2,n
   60 ypp(i) = (ypp(i) - w(i,2)*ypp(i-1))/w(i,1)
!
!     backward substitution
!
  do 70 j=1,nm1
  i = n-j
   70 ypp(i) = ypp(i) - w(i,3)*ypp(i+1)
!
!     compute first derivatives
!
  yp(1)  = (y(2)-y(1))/(x(2)-x(1)) - (x(2)-x(1))*(2.0*ypp(1) &
           + ypp(2))/6.0
  do 80 i=2,nm1
   80 yp(i)  = yp(i) + w(i,2)*(ypp(i-1) + 2.0*ypp(i))/6.0
  yp(n)  = yp(n) + (x(n)-x(nm1))*(ypp(nm1) + 2.0*ypp(n))/6.0
!
  ierr = 0
  return
  100 ierr = 1
  return
  200 ierr = 2
  return
  300 ierr = 3
  return
end
subroutine splsq(m,n,a,ia,ja,damp,u,x,atol,btol,conlim,itnlim, &
                       istop,itn,acond,rnorm,xnorm,w)
!
!*******************************************************************************
!
!! SPLSQ finds a solution x to a variety of systems of linear equations.
!
!
!     1. unsymmetric equations --    solve  a*x = b
!
!     2. linear least squares  --    solve  a*x = b
!                                    in the least-squares sense
!
!     3. damped least squares  --    solve  (   a    )*x = ( b )
!                                           ( damp*i )     ( 0 )
!                                    in the least-squares sense
!
!     where a is a matrix with m rows and n columns, b an m-vector,
!     and damp a scalar. (all quantities are real.) the matrix a is
!     a sparse matrix stored rowwise in the arrays a,ia,ja.
!
!     the rhs vector b is input via u, and is subsequently overwritten.
!
!
!     note. splsq uses an iterative method to approximate the solution.
!     the number of iterations required to reach a certain accuracy
!     depends strongly on the scaling of the problem. poor scaling of
!     the rows or columns of a should therefore be avoided whenever
!     possible.
!
!     for example, in problem 1 the solution is unaltered by
!     row-scaling.  if a row of a is very small or large compared to
!     the other rows of a, the corresponding row of (a  b) should be
!     scaled up or down.
!
!     in problems 1 and 2, the solution x is easily recovered
!     following column scaling. in the absence of better information,
!     the nonzero columns of a should be scaled so that they all have
!     the same euclidean norm (e.g.  1.0).
!
!     in problem 3, there is no freedom to re-scale if damp is
!     nonzero. however, the value of damp should be assigned only
!     after attention has been paid to the scaling of a.
!
!     the parameter damp is intended to help regularize
!     ill-conditioned systems, by preventing the true solution from
!     being very large. another aid to regularization is provided by
!     the parameter acond, which may be used to terminate iterations
!     before the computed solution becomes very large.
!
!
!     notation
!
!
!     the following quantities are used in discussing the subroutine
!     parameters...
!
!     abar   =  (   a    ),          bbar  =  ( b )
!               ( damp*i )                    ( 0 )
!
!     r      =  b  -  a*x,           rbar  =  bbar  -  abar*x
!
!     rnorm  =  sqrt( norm(r)**2  +  damp**2 * norm(x)**2 )
!            =  norm( rbar )
!
!     relpr  =  the smallest floating point number for which
!               1 + relpr > 1.
!
!     splsq  minimizes the function rnorm with respect to x.
!
!
!     parameters
!
!
!     m       input      the number of rows in a.
!
!     n       input      the number of columns in a.
!
!     a,ia,ja input      the matrix a stored rowwise in sparse form.
!
!     damp    input      the damping parameter for problem 3 above.
!                        (damp  should be 0.0 for problems 1 and 2.)
!                        if the system  a*x = b  is incompatible, values
!                        of damp in the range 0 to sqrt(relpr)*norm(a)
!                        will probably have a negligible effect.
!                        larger values of damp will tend to decrease
!                        the norm of x and to reduce the number of
!                        iterations required by splsq.
!
!                        the work per iteration and the storage needed
!                        by splsq are the same for all values of damp.
!
!     u(m)    input      the rhs vector b. be aware that u is
!                        over-written by splsq.
!
!     x(n)    output     returns the computed solution x.
!
!     atol    input      an estimate of the relative error in the data
!                        defining the matrix a. for example,
!                        if a is accurate to about 6 digits, set
!                        atol = 1.0e-6 .
!
!     btol    input      an estimate of the relative error in the data
!                        defining the rhs vector b. for example,
!                        if b is accurate to about 6 digits, set
!                        btol = 1.0e-6 .
!
!     conlim  input      an upper limit on cond(abar), the apparent
!                        condition number of the matrix abar.
!                        iterations will be terminated if a computed
!                        estimate of cond(abar) exceeds conlim.
!                        this is intended to prevent certain small or
!                        zero singular values of a or abar from
!                        coming into effect and causing unwanted growth
!                        in the computed solution.
!
!                        conlim and damp may be used separately or
!                        together to regularize ill-conditioned systems.
!
!                        normally, conlim should be in the range
!                        1000  to  1/relpr.
!                        suggested value --
!                        conlim = 1/(100*relpr)  for compatible systems,
!                        conlim = 1/(10*sqrt(relpr))  for least squares.
!
!             note. if the user is not concerned about the parameters
!             atol, btol, and conlim, any or all of them may be set
!             to zero. the effect will be the same as the values
!             relpr, relpr, and  1/relpr  respectively.
!
!     itnlim  input      an upper limit on the number of iterations.
!                        suggested value --
!                        itnlim = n/2     for well conditioned systems,
!                        itnlim = 4*n     otherwise.
!
!     istop   output     an integer giving the reason for termination...
!
!                0       x = 0  is the exact solution.
!                        no iterations were performed.
!
!                1       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is sufficiently
!                        small, given the values of atol and btol.
!
!                2       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is sufficiently accurate,
!                        given the value of atol.
!
!                3       an estimate of cond(abar) has exceeded
!                        conlim. the system  a*x = b  appears to be
!                        ill-conditioned.
!
!                4       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is as small as
!                        seems reasonable on this machine.
!
!                5       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is as accurate as seems
!                        reasonable on this machine.
!
!                6       cond(abar) seems to be so large that there is
!                        not much point in doing further iterations,
!                        given the precision of this machine.
!
!                7       the iteration limit itnlim was reached.
!
!
!     itn     output     the number of iterations that were performed.
!
!     acond   output     an estimate of cond(abar), the condition
!                        number of abar.
!
!     rnorm   output     an estimate of the final value of norm(rbar),
!                        the function being minimized (see notation
!                        above). this will be small if  a*x = b  has
!                        a solution.
!
!     xnorm   output     an estimate of the norm of the final
!                        solution vector x.
!
!     w(2*n)             workspace
!
!     anorm   local      an estimate of the frobenius norm of abar.
!                        this is the square root of the sum of squares
!                        of the elements of abar.
!                        if damp is small and if the columns of a
!                        have all been scaled to have length  1.0,
!                        anorm should increase to roughly sqrt(n).
!
!     arnorm  local      an estimate of the final value of
!                        norm( abar(transpose)*rbar ), the norm of
!                        the residual for the usual normal equations.
!                        this should be small in all cases. (arnorm
!                        will often be smaller than the true value
!                        computed from the output vector x.)
!
!
!     subroutines and functions used
!
!
!                normlz,mvprd1,mtprd1
!     blas       scopy,snrm2,sscal  (see lawson et al. below)
!                (snrm2 is used only in normlz)
!     fortran    abs,sqrt
!
!
!     references
!
!
!     paige, c.c. and saunders, m.a.  lsqr, an algorithm for sparse
!        linear equations and sparse least squares.
!        acm transactions on mathematical software 8, 1 (march 1982).
!
!     lawson, c.l., hanson, r.j., kincaid, d.r. and krogh, f.t.
!        basic linear algebra subprograms for fortran usage.
!        acm transactions on mathematical software 5, 3 (sept 1979),
!        308-323 and 324-325.
!
  integer m,n,itnlim,istop
  integer ia(*),ja(*)
  real    a(*),damp,u(m),x(n),atol,btol,conlim, &
          acond,rnorm,xnorm,w(*)
!
!
!
!     local variables
!
  integer    i,itn,nconv,nstop
  real       alfa,anorm,arnorm,bbnorm,beta,bnorm, &
             cs,cs1,cs2,ctol,dampsq,ddnorm,delta, &
             gamma,gambar,one,phi,phibar,psi, &
             res1,res2,rho,rhobar,rhbar1,rhbar2,rhs,rtol, &
             sn,sn1,sn2,t,tau,test1,test2,test3, &
             theta,t1,t2,t3,xxnorm,z,zbar,zero
!
!
!     initialize.
!
  zero   = 0.0
  one    = 1.0
  ctol   = zero
  if (conlim > zero) ctol = one/conlim
  dampsq = damp**2
  anorm  = zero
  acond  = zero
  bbnorm = zero
  ddnorm = zero
  res2   = zero
  xnorm  = zero
  xxnorm = zero
  cs2    = -one
  sn2    = zero
  z      = zero
  itn    = 0
  istop  = 0
  nstop  = 0
!
  do 10 i = 1, n
     w(i) = zero
     x(i) = zero
   10 continue
!
!     set up the first vectors for the bidiagonalization.
!     these satisfy   beta*u = b,   alfa*w = a(transpose)*u.
!
  call normlz(m,u,beta)
  call mtprd1(m,n,a,ia,ja,u,w)
  call normlz(n,w,alfa)
  call scopy (n,w,1,w(n+1),1)
!
  rhobar = alfa
  phibar = beta
  bnorm  = beta
  rnorm  = beta
  arnorm = alfa*beta
  if (arnorm <= zero) go to 800
!
!
!     main iteration loop.
!
  100 itn = itn + 1
!
!     perform the next step of the bidiagonalization to obtain the
!     next  beta, u, alfa, w.  these satisfy the relations
!                beta*u  =  a*w  -  alfa*u,
!                alfa*w  =  a(transpose)*u  -  beta*w.
!
  call sscal (m,(-alfa),u,1)
  call mvprd1(m,n,a,ia,ja,w,u)
  call normlz(m,u,beta)
  bbnorm = bbnorm + alfa**2 + beta**2 + dampsq
  call sscal (n,(-beta),w,1)
  call mtprd1(m,n,a,ia,ja,u,w)
  call normlz(n,w,alfa)
!
!
!     use a plane rotation to eliminate the damping parameter.
!     this alters the diagonal (rhobar) of the lower-bidiagonal matrix.
!
  rhbar2 = rhobar**2 + dampsq
  rhbar1 = sqrt(rhbar2)
  cs1    = rhobar/rhbar1
  sn1    = damp/rhbar1
  psi    = sn1*phibar
  phibar = cs1*phibar
!
!
!     use a plane rotation to eliminate the subdiagonal element (beta)
!     of the lower-bidiagonal matrix, giving an upper-bidiagonal matrix.
!
  rho    = sqrt(rhbar2 + beta**2)
  cs     = rhbar1/rho
  sn     = beta/rho
  theta  =  sn*alfa
  rhobar = -cs*alfa
  phi    =  cs*phibar
  phibar =  sn*phibar
  tau    =  sn*phi
!
!
!     update x and w(n+1),...,w(2*n)
!
  t1 =    phi/rho
  t2 = -theta/rho
  t3 =    one/rho
!
  do 200 i = 1, n
     npi   = n + i
     t     = w(npi)
     x(i)  = t1*t + x(i)
     w(npi)= t2*t + w(i)
     t     =(t3*t)**2
     ddnorm= t + ddnorm
  200 continue
!
!
!     use a plane rotation on the right to eliminate the
!     super-diagonal element (theta) of the upper-bidiagonal matrix.
!     then use the result to estimate norm(x).
!
  delta  =  sn2*rho
  gambar = -cs2*rho
  rhs    = phi - delta*z
  zbar   = rhs/gambar
  xnorm  = sqrt(xxnorm + zbar**2)
  gamma  = sqrt(gambar**2 + theta**2)
  cs2    = gambar/gamma
  sn2    = theta/gamma
  z      = rhs/gamma
  xxnorm = xxnorm + z**2
!
!
!     test for convergence.
!     first, estimate the norm and condition of the matrix abar,
!     and the norms of rbar and abar(transpose)*rbar.
!
  anorm  = sqrt(bbnorm)
  acond  = anorm*sqrt(ddnorm)
  res1   = phibar**2
  res2   = res2 + psi**2
  rnorm  = sqrt(res1 + res2)
  arnorm = alfa*abs(tau)
!
!     now use these norms to estimate certain other quantities,
!     some of which will be small near a solution.
!
  test1  = rnorm/bnorm
  test2  = arnorm/(anorm*rnorm)
  test3  = one/acond
  t1     = test1/(one + anorm*xnorm/bnorm)
  rtol   = btol +  atol*anorm*xnorm/bnorm
!
!     the following tests guard against extremely small values of
!     atol, btol, or ctol.  (the user may have set any or all of
!     the parameters atol, btol, conlim to zero.)
!     the effect is equivalent to the normal tests using
!     atol = relpr,  btol = relpr,  conlim = 1/relpr.
!
  t3 = one + test3
  t2 = one + test2
  t1 = one + t1
  if (itn >= itnlim) istop = 7
  if (t3  <= one   ) istop = 6
  if (t2  <= one   ) istop = 5
  if (t1  <= one   ) istop = 4
!
!     allow for tolerances set by the user.
!
  if (test3 <= ctol) istop = 3
  if (test2 <= atol) istop = 2
  if (test1 <= rtol) istop = 1
!
!     stop if appropriate.
!     the convergence criteria are required to be met on  nconv
!     consecutive iterations, where  nconv  is set below.
!     suggested value --   nconv = 1, 2  or  3.
!
  if (istop == 0) nstop = 0
  if (istop == 0) go to 100
  nconv = 1
  nstop = nstop + 1
  if (nstop < nconv  .and.  itn  <  itnlim) istop = 0
  if (istop == 0) go to 100
!
!     end of iteration loop.
!
!
  800 return
end
subroutine splu (a,ia,ja,r,c,ic,n,max,d,t,it,jt,iu,w,p,ierr)
!
!*******************************************************************************
!
!! SPLU employs gaussian elimination with column interchanges
!     to perform the lu decomposition of a real sparse matrix.
!     u is a unit upper triangular matrix.
!
!
!     input arguments ---
!
!     a,ia,ja  the sparse matrix to be decomposed.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     ic       integer array of n entries which is the inverse of c
!              (i.e., ic(c(i)) = i). ic is also an output argument.
!
!     n        order of the matrix a.
!
!     max      integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     ic       integer array of n entries which is the inverse of c.
!
!     d        real array containing the n diagonal elements of l.
!
!     t,it,iu  t contains the off-diagonal nonzero elements of l and
!              u. for i = 1,...,n the off-diagonal nonzero elements
!              of the i-th row of l are stored in locations
!              it(i),...,iu(i)-1 of t, and the off-diagonal nonzero
!              elements of the i-th row of u are stored in locations
!              iu(i),...,it(i+1)-1 of t.
!
!     jt       integer array containing the column indices (according
!              to the orginal column ordering) of the elements of t
!              (i.e., for each l(i,j) and u(i,j) in t, c(j) is the
!              corresponding column index in jt).
!
!     ierr     integer specifying the status of the results. if the
!              lu decomposition is obtained then ierr = the number
!              of off-diagonal entries of l and u which were stored
!              in t. otherwise ierr is assigned a negative value.
!
!
!     work spaces ---
!
!     w        real array of dimension n.
!
!     p        integer array of dimension n+1.
!
  real a(*), d(n), t(max), w(n)
  integer ia(*), ja(*)
  integer r(n), c(n), ic(n)
  integer it(*), jt(max), iu(n)
  integer p(*), pm
  real const, wi, wmax
!
  jptr = 0
  it(1) = 1
  do 10 j = 1,n
     w(j) = 0.0
   10 continue
!
!     perform the lu factorization of the r(k)-th row of a
!
  do 100 k = 1,n
  lk = r(k)
  jmin = ia(lk)
  jmax = ia(lk+1) - 1
  if (jmin > jmax) go to 200
!
!     set p to the reordered row of a
!
  p(n+1) = n + 1
  jj = jmax
   20 lj = ja(jj)
  j = ic(lj)
  w(j) = a(jj)
  pm = n + 1
   21 m = pm
  pm = p(m)
  if (pm - j) 21,210,22
   22 p(m) = j
  p(j) = pm
  jj = jj - 1
  if (jj >= jmin) go to 20
!
!     process the entries in the lower triangle of a
!
  i = n + 1
   30 i = p(i)
  if (i >= k) go to 50
  if (w(i) == 0.0) go to 30
!
!     l(k,i) is nonzero. therefore store it in l.
!
  jptr = jptr + 1
  if (jptr > max) go to 230
  const = w(i)
  t(jptr) = const
  jt(jptr) = c(i)
  w(i) = 0.0
!
!     perform elimination using the i-th row of u
!
  jmin = iu(i)
  jmax = it(i+1) - 1
  if (jmin > jmax) go to 30
  pm = i
  do 43 jj = jmin,jmax
     lj = jt(jj)
     j = ic(lj)
     if (w(j) /= 0.0) go to 43
     if (j - pm) 40,43,41
   40       pm = i
   41       m = pm
        pm = p(m)
        if (pm - j) 41,43,42
   42       p(m) = j
        p(j) = pm
        pm = j
   43 w(j) = w(j) - const*t(jj)
  go to 30
!
!     search for the k-th pivot element
!
   50 if (i > n) go to 220
  wmax = abs(w(i))
  maxi = i
  pm = i
   51 m = pm
  pm = p(m)
  if (pm > n) go to 60
  wi = abs(w(pm))
  if (wi <= wmax) go to 51
     wmax = wi
     maxi = pm
     maxil = m
     go to 51
!
!     store the pivot in d
!
   60 if (wmax == 0.0) go to 220
  d(k) = w(maxi)
!
!     perform the column interchange
!
  if (i == k) go to 70
  if (i == maxi) go to 70
     p(maxil) = p(maxi)
     go to 80
   70 i = p(i)
!
   80 w(maxi) = w(k)
  w(k) = 0.0
  lk = c(k)
  ll = c(maxi)
  c(k) = ll
  c(maxi) = lk
  ic(lk) = maxi
  ic(ll) = k
!
!     the remaining elements of p form the k-th row of u
!
  iu(k) = jptr + 1
   90 if (i > n) go to 100
  if (w(i) == 0.0) go to 91
     jptr = jptr + 1
     if (jptr > max) go to 230
     t(jptr) = w(i)/d(k)
     jt(jptr) = c(i)
     w(i) = 0.0
   91 i = p(i)
  go to 90
!
!     prepare for the next row
!
  100 it(k+1) = jptr + 1
!
  ierr = jptr
  return
!
! error return
!
!     row r(k) is null
!
  200 ierr = -k
  return
!
!     row r(k) has a duplicate entry
!
  210 ierr = -(n + k)
  return
!
!     zero pivot in row r(k)
!
  220 ierr = -(2*n + k)
  return
!
!     storage for l and u exceeded on row r(k)
!
  230 ierr = -(3*n + k)
  return
end
function spmpar (i)
!
!*******************************************************************************
!
!! SPMPAR provides the single precision machine constants for the computer
!  being used. it is assumed that the argument
!     i is an integer having one of the values 1, 2, or 3. if the
!     single precision arithmetic being used has m base b digits and
!     its smallest and largest exponents are emin and emax, then
!
!        spmpar(1) = b**(1 - m), the machine precision,
!
!        spmpar(2) = b**(emin - 1), the smallest magnitude,
!
!        spmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
!
  integer emin, emax
  real spmpar
!
  if (i > 1) go to 10
     b = ipmpar(4)
     m = ipmpar(5)
     spmpar = b**(1 - m)
     return
!
   10 if (i > 2) go to 20
     b = ipmpar(4)
     emin = ipmpar(6)
     one = real(1)
     binv = one/b
     w = b**(emin + 2)
     spmpar = ((w * binv) * binv) * binv
     return
!
   20 ibeta = ipmpar(4)
  m = ipmpar(5)
  emax = ipmpar(7)
!
  b = ibeta
  bm1 = ibeta - 1
  one = real(1)
  z = b**(m - 1)
  w = ((z - one)*b + bm1)/(b*z)
!
  z = b**(emax - 2)
  spmpar = ((w * z) * b) * b
  return
end
subroutine spord (m, n, ia, r, iwk)
!
!*******************************************************************************
!
!! SPORD orders the rows of an mxn sparse matrix a,ia,ja
!        by increasing length. the row ordering is given in r.
!
!     iwk is a work space of dimension m + n + 1.
!
  integer ia(*), r(m), iwk(*)
!
  np1 = n + 1
  do 10 i = 1,np1
     iwk(i) = 0
   10 continue
!
  i = m
  do 20 ii = 1,m
     num = ia(i+1) - ia(i) + 1
     l = np1 + i
     iwk(l) = iwk(num)
     iwk(num) = i
     i = i - 1
   20 continue
!
  num = 1
  k = iwk(num)
  do 32 i = 1,m
   30    if (k /= 0) go to 31
        num = num + 1
        k = iwk(num)
        go to 30
   31    r(i) = k
     l = np1 + k
     k = iwk(l)
   32 continue
  return
end
subroutine sppdi(ap,n,det,job)
!
!*******************************************************************************
!
!! SPPDI: determinant and inverse of a real symmetric positive definite matrix
!  using the factors computed by sppco or sppfa .
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the output from sppco or sppfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        job     integer
!                = 11   both determinant and inverse.
!                = 01   inverse only.
!                = 10   determinant only.
!
!     on return
!
!        ap      the upper triangular half of the inverse .
!
!        det     real(2)
!                determinant of original matrix if requested.
!                otherwise not referenced.
!                determinant = det(1) * 10.0**det(2)
!                with  1.0 <= det(1) < 10.0
!                or  det(1) == 0.0 .
!
!     error condition
!
!        a division by zero will occur if the input factor contains
!        a zero on the diagonal and the inverse is requested.
!        it will not occur if the subroutines are called correctly
!        and if spoco or spofa has set info == 0 .
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas saxpy,sscal
!     fortran mod
!
  integer n,job
  real ap(*)
  real det(2)
!
!     internal variables
!
  real t
  real s
  integer i,ii,j,jj,jm1,j1,k,kj,kk,kp1,k1
!
!     compute determinant
!
  if (job/10 == 0) go to 70
     det(1) = 1.0e0
     det(2) = 0.0e0
     s = 10.0e0
     ii = 0
     do 50 i = 1, n
        ii = ii + i
        det(1) = ap(ii)**2*det(1)
!        ...exit
        if (det(1) == 0.0e0) go to 60
   10       if (det(1) >= 1.0e0) go to 20
           det(1) = s*det(1)
           det(2) = det(2) - 1.0e0
        go to 10
   20       continue
   30       if (det(1) < s) go to 40
           det(1) = det(1)/s
           det(2) = det(2) + 1.0e0
        go to 30
   40       continue
   50    continue
   60    continue
   70 continue
!
!     compute inverse(r)
!
  if (mod(job,10) == 0) go to 140
     kk = 0
     do 100 k = 1, n
        k1 = kk + 1
        kk = kk + k
        ap(kk) = 1.0e0/ap(kk)
        t = -ap(kk)
        call sscal(k-1,t,ap(k1),1)
        kp1 = k + 1
        j1 = kk + 1
        kj = kk + k
        if (n < kp1) go to 90
        do 80 j = kp1, n
           t = ap(kj)
           ap(kj) = 0.0e0
           call saxpy(k,t,ap(k1),1,ap(j1),1)
           j1 = j1 + j
           kj = kj + j
   80       continue
   90       continue
  100    continue
!
!        form  inverse(r) * trans(inverse(r))
!
     jj = 0
     do 130 j = 1, n
        j1 = jj + 1
        jj = jj + j
        jm1 = j - 1
        k1 = 1
        kj = j1
        if (jm1 < 1) go to 120
        do 110 k = 1, jm1
           t = ap(kj)
           call saxpy(k,t,ap(j1),1,ap(k1),1)
           k1 = k1 + k
           kj = kj + 1
  110       continue
  120       continue
        t = ap(jj)
        call sscal(j,t,ap(j1),1)
  130    continue
  140 continue
  return
end
subroutine sppfa(ap,n,info)
!
!*****************************************************************************80
!
!! SPPFA factors real symmetric positive definite matrix stored in packed form.
!
!     sppfa is usually called by sppco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!     (time for sppco) = (1 + 18/n)*(time for sppfa) .
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     on return
!
!        ap      an upper triangular matrix  r , stored in packed
!                form, so that  a = trans(r)*r .
!
!        info    integer
!                = 0  for normal return.
!                = k  if the leading minor of order  k  is not
!                     positive definite.
!
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k) = a(i,j)
!             10    continue
!             20 continue
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas sdot
!     fortran sqrt
!
!     internal variables
!
  integer n,info
  real ap(*)
!
  real sdot,t
  real s
  integer j,jj,jm1,k,kj,kk
!     begin block with ...exits to 40
!
!
     jj = 0
     do 30 j = 1, n
        info = j
        s = 0.0e0
        jm1 = j - 1
        kj = jj
        kk = 0
        if (jm1 < 1) go to 20
        do 10 k = 1, jm1
           kj = kj + 1
           t = ap(kj) - sdot(k-1,ap(kk+1),1,ap(jj+1),1)
           kk = kk + k
           t = t/ap(kk)
           ap(kj) = t
           s = s + t*t
   10       continue
   20       continue
        jj = jj + j
        s = ap(jj) - s
!     ......exit
        if (s <= 0.0e0) go to 40
        ap(jj) = sqrt(s)
   30    continue
     info = 0
   40 continue
  return
end
subroutine sppsl(ap,n,b)
!
!*******************************************************************************
!
!! SPPSL solves the real symmetric positive definite system a * x = b
!     using the factors computed by sppco or sppfa.
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the output from sppco or sppfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        b       real(n)
!                the right hand side vector.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero will occur if the input factor contains
!        a zero on the diagonal.  technically this indicates
!        singularity but it is usually caused by improper subroutine
!        arguments.  it will not occur if the subroutines are called
!        correctly and  info == 0 .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call sppco(ap,n,rcond,z,info)
!           if (rcond is too small .or. info /= 0) go to ...
!           do 10 j = 1, p
!              call sppsl(ap,n,c(1,j))
!        10 continue
!
!     linpack.  this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     blas saxpy,sdot
!
!     internal variables
!
  integer n
  real ap(*),b(*)
!
  real sdot,t
  integer k,kb,kk
!
  kk = 0
  do 10 k = 1, n
     t = sdot(k-1,ap(kk+1),1,b(1),1)
     kk = kk + k
     b(k) = (b(k) - t)/ap(kk)
   10 continue
  do 20 kb = 1, n
     k = n + 1 - kb
     b(k) = b(k)/ap(kk)
     kk = kk - k
     t = -b(k)
     call saxpy(k-1,t,ap(kk+1),1,b(1),1)
   20 continue
  return
end
subroutine sprod (a,ia,ja,b,ib,jb,c,ic,jc,l,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! SPROD: multiplication of sparse real matrices
!
  real a(*)
  real b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  wk(1:n) = 0.0
!
!                     compute the i-th row of c
!
  ip = 1
  do 31 i = 1,l
     ic(i) = ip
     jpmin = ia(i)
     jpmax = ia(i+1) - 1
     if (jpmin > jpmax) go to 31
!
     do 21 jp = jpmin,jpmax
        t = a(jp)
        if (t == 0.0) go to 21
        j = ja(jp)
        kpmin = ib(j)
        kpmax = ib(j+1) - 1
        if (kpmin > kpmax) go to 21
        do 20 kp = kpmin,kpmax
           k = jb(kp)
           wk(k) = wk(k) + t*b(kp)
   20       continue
   21    continue
!
     do 30 k = 1,n
        if (wk(k) == 0.0) go to 30
        if (ip > num) go to 40
        c(ip) = wk(k)
        wk(k) = 0.0
        jc(ip) = k
        ip = ip + 1
   30    continue
   31 continue
  ic(l + 1) = ip
  ierr = 0
  return
!
!                           error return
!
   40 ierr = i
  return
end
subroutine spslv (n,a,ia,ja,b,r,c,max,x,itemp,rtemp,ierr)
!
!*******************************************************************************
!
!! SPSLV: solution of real sparse equations
!
!  spslv calls nspiv1 which uses sparse gaussian elimination with
!  column interchanges to solve the linear system a x = b.  the
!  elimination phase performs row operations on a and b to obtain
!  a unit upper triangular matrix u and a vector y.  the solution
!  phase solves u x = y.
!
!  input arguments---
!
!  n      integer number of equations and unknowns
!
!  a      real array with one entry per nonzero in a, containing the
!         actual nonzeros.  (see matrix storage description below)
!
!  ia     integer array of n+1 entries containing row pointers to a
!         (see matrix storage description below)
!
!  ja     integer array with one entry per nonzero in a, containing
!         column numbers of the nonzeros of a.  (see matrix storage
!         description below)
!
!  b      real array of n entries containing right hand side data
!
!  r      integer array of n entries specifying the order of the
!         rows of a (i.e., the elimination order for the equations)
!
!  c      integer array of n entries specifying the order of the
!         columns of a.  c is also an output argument
!
!  max    integer number specifying maximum number of off-diagonal
!         nonzero entries of u which may be stored
!
!  itemp  integer array of 3*n + max + 2 entries, for internal use
!
!  rtemp  real array of n + max entries for internal use
!
!
!  output arguments---
!
!  c      integer array of n entries specifying the order of the
!         columns of u.  c is also an input argument
!
!  x      real array of n entries containing the solution vector
!
!  ierr   integer number which indicates error conditions or
!         the actual number of off-diagonal entries in u (for
!         successful completion)
!
!         ierr values are---
!
!         0 lt ierr             successful completion. ierr=max(1,m)
!                               where m is the number of off-diagonal
!                               nonzero entries of u.
!
!         ierr = 0              error.  n is less than or equal to 0
!
!         -n le ierr lt 0       error.  row number iabs(ierr) of a is
!                               is null
!
!         -2*n le ierr lt -n    error.  row number iabs(ierr+n) has a
!                               duplicate entry
!
!         -3*n le ierr lt -2*n  error.  row number iabs(ierr+2*n)
!                               has a zero pivot
!
!         -4*n le ierr lt -3*n  error.  row number iabs(ierr+3*n)
!                               exceeds storage
!
!
!  storage of sparse matrices---
!
!  the sparse matrix a is stored using three arrays ia, ja, and a.
!  the array a contains the nonzeros of the matrix row-by-row, not
!  necessarily in order of increasing column number.  the array ja
!  contains the column numbers corresponding to the nonzeros stored
!  in the array a (i.e., if the nonzero stored in a(k) is in
!  column j, then ja(k) = j).  the array ia contains pointers to the
!  rows of nonzeros/column indices in the array a/ja (i.e.,
!  a(ia(i))/ja(ia(i)) is the first entry for row i in the array a/ja).
!  ia(n+1) is set so that ia(n+1) - ia(1) = the number of nonzero
!  elements in a.
!
  real a(*), b(n), x(n), rtemp(*)
  integer ia(*), ja(*), r(n), c(n), itemp(*)
  integer iu, ju, u, y, p
!
  ierr = 0
  if (n <= 0) return
!
!  set indices to divide temporary storage for nspiv1
!
  y = 1
  u = y + n
  p = n + 1
  iu = p + n + 1
  ju = iu + n + 1
!
!  compute the inverse permutation of c
!
  do 10 k = 1,n
     l = c(k)
     itemp(l) = k
   10 continue
!
!  call nspiv1 to perform computations
!
  call nspiv1 (n,ia,ja,a,b,max,r,c,itemp(1),x,rtemp(y),itemp(p), &
               itemp(iu),itemp(ju),rtemp(u),ierr)
  if (ierr == 0) ierr = 1
  return
end
subroutine squin2(nm, n, a, b, c, iguess, s, l, u, v, z, r, xold, &
   eye, temp, nw, tol, maxits, ierr)
!
!*******************************************************************************
!
!! SQUIN2 finds a right solvent of the matrix equation ax**2 + bx + c = 0.
!
!     on entry,
!
!     nm     is the leading dimension of all the matrices in
!            the calling program.
!
!     n      is the order of the matrices a, b and c.
!
!     a      is the matrix coefficient of x**2.
!
!     b      is the matrix coefficient of x.
!
!     c      is the constant matrix.
!
!     iguess is an integer set in the call to squint.
!
!     s      is a matrix set in the call to squint.
!
!     nw, tol, and maxits are integer and real parameters set in
!            the call to squint.
!
!
!     the following are internal variables ...
!
!
!     l      is a matrix containing the iterate x(i) for
!            reduction to lower triangular form.
!
!     u      is a matrix containing ax(i) + b for reduction
!            to upper triangular form.
!
!     v      is a matrix containing a for reduction to upper
!            triangular form.
!
!     z,r    are matrices containing the history of the
!            transformations in the reductions.
!
!     xold   is a matrix holding the current iterate x(i).
!
!     eye    contains an identity matrix for the lower reduction
!            step.
!
!     temp   is a work vector.
!
!
!     on return,
!
!     a, b, c, iguess, s and ierr have the same properties as
!            described in the return from subroutine squint.
!
!     l(1,1) is a complex number with real part equal to the norm
!            of as**2+bs+c.
!
!
  integer nm, n, iguess, nw, maxits, ierr
  integer its, mats, i, j, k
  complex a(nm,n), b(nm,n), c(nm,n), s(nm,n), l(nm,n), u(nm,n)
  complex v(nm,n), z(nm,n), r(nm,n), xold(nm,n), eye(nm,n), temp(n)
  real anorm, ani, bnorm, bni, cnorm, cni, xnorm, xni
  real fxnorm, fxni, gnorm, tnorm, t, tol
!     real sqrt, cabs, float
!     complex cmplx, conjg
  k = 7*n*n + n
  if (nw < k) go to 460
  if (nm < n) go to 460
  if (n <= 0) go to 460
  if (maxits <= 0) maxits = 30
!     ********** initialize arrays **********
  do 20 i=1,n
    do 10 j=1,n
      l(i,j) = cmplx(0.0,0.0)
      u(i,j) = cmplx(0.0,0.0)
      v(i,j) = cmplx(0.0,0.0)
      z(i,j) = cmplx(0.0,0.0)
      xold(i,j) = cmplx(0.0,0.0)
      eye(i,j) = cmplx(0.0,0.0)
   10   continue
    temp(i) = cmplx(0.0,0.0)
   20 continue
!     ********** set initial guess(es) **********
  anorm = 0.0
  bnorm = 0.0
  cnorm = 0.0
  do 40 i=1,n
    ani = 0.0
    bni = 0.0
    cni = 0.0
    do 30 j=1,n
      ani = ani + cabs(a(i,j))
      bni = bni + cabs(b(i,j))
      cni = cni + cabs(c(i,j))
   30   continue
    if (ani > anorm) anorm = ani
    if (bni > bnorm) bnorm = bni
    if (cni > cnorm) cnorm = cni
   40 continue
  gnorm = (bnorm+sqrt(bnorm**2+4.0*anorm*cnorm))/(2.0*anorm)
  if (iguess==0) go to 70
  do 60 i=1,n
    do 50 j=1,n
      xold(i,j) = s(i,j)
   50   continue
   60 continue
  go to 100
!
   70 do 90 i=1,n
    do 80 j=1,n
      xold(i,j) = cmplx(0.0,0.0)
   80   continue
    xold(i,i) = cmplx(gnorm,0.0)
   90 continue
!
  100 do 360 its=1,maxits
    if (its/=31) go to 130
    do 120 i=1,n
      do 110 j=1,n
        xold(i,j) = cmplx(0.0,0.0)
  110     continue
      xold(i,i) = cmplx(0.0,gnorm)
  120   continue
!
  130   if (its/=61) go to 160
    do 150 i=1,n
      do 140 j=1,n
        xold(i,j) = c(i,j)
  140     continue
  150   continue
!        ********** set up u and right hand side.
!
  160   call cmprod(n, n, n, a, nm, xold, nm, u, nm, u)
    do 180 i=1,n
      do 170 j=1,n
        u(i,j) = u(i,j) + b(i,j)
  170     continue
  180   continue
    call cmprod(n, n, n, u, nm, xold, nm, s, nm, s)
    do 200 i=1,n
      do 190 j=1,n
        s(i,j) = s(i,j) + c(i,j)
  190     continue
  200   continue
!        ********** check for convergence.
!
    xnorm = 0.0
    fxnorm = 0.0
    do 220 i=1,n
      xni = 0.0
      fxni = 0.0
      do 210 j=1,n
        xni = xni + cabs(xold(i,j))
        fxni = fxni + cabs(s(i,j))
  210     continue
      if (xni > xnorm) xnorm = xni
      if (fxni > fxnorm) fxnorm = fxni
  220   continue
    if (tol <= 0.0) go to 230
    if (fxnorm < tol) go to 370
  230   tnorm = 8.0*real(n)*anorm*xnorm**2 + 5.0*float(n)*bnorm*xnorm &
     + cnorm
    t = 1.0 + fxnorm/tnorm
    if (t==1.0) go to 370
    if (its >= maxits) go to 400
!        ********** upper triangularization.
    if (its/=1) go to 240
    mats = 1
    call cqzhes(nm, n, u, a, mats, z, s, b, c)
  240   do 260 i=1,n
      do 250 j=1,n
        v(i,j) = a(i,j)
        l(i,j) = conjg(xold(j,i))
        eye(i,j) = cmplx(0.0,0.0)
  250     continue
      eye(i,i) = cmplx(1.0,0.0)
  260   continue
    if (its==1) go to 270
    mats = 2
    call cqzhes(nm, n, u, v, mats, z, s, b, c)
  270   call cqzit(nm, n, u, v, 0.0, mats, z, s, ierr)
    if (ierr/=0) go to 430
!        ********** lower triangularization.
!
    mats = 3
    call cqzhes(nm, n, l, eye, mats, r, s, b, c)
    call cqzit(nm, n, l, eye, 0.0, mats, r, s, ierr)
    if (ierr/=0) go to 440
    call ctrans(nm, n, l)
!        ********** update s with R.
    do 310 i=1,n
      do 280 j=1,n
        temp(j) = s(i,j)
        s(i,j) = cmplx(0.0,0.0)
  280     continue
      do 300 j=1,n
        do 290 k=1,n
          s(i,j) = s(i,j) + temp(k)*r(k,j)
  290       continue
  300     continue
  310   continue
    do 330 j=1,n
      do 320 i=1,n
        l(i,j) = l(i,j)*eye(j,j)
  320     continue
      eye(j,j) = cmplx(1.0,0.0)
  330   continue
!        ********** backsolve the transformed system.
!
    call trislv(nm, n, u, v, l, s, temp, ierr)
    if (ierr/=0) go to 450
!        ********** translate back to the solution **********
    call cmprod(n, n, n, z, nm, s, nm, l, nm, l)
    call ctrans(nm, n, r)
    call cmprod(n, n, n, l, nm, r, nm, s, nm, s)
    do 350 i=1,n
      do 340 j=1,n
        xold(i,j) = xold(i,j) - s(i,j)
  340     continue
  350   continue
  360 continue
!     ********** convergence **********
  370 iguess = its - 1
  l(1,1) = cmplx(fxnorm,0.0)
  do 390 i=1,n
    do 380 j=1,n
      s(i,j) = xold(i,j)
  380   continue
  390 continue
  ierr = 0
  return
!     ********** error returns **********
  400 ierr = 1
  l(1,1) = cmplx(fxnorm,0.0)
  do 420 i=1,n
    do 410 j=1,n
      s(i,j) = xold(i,j)
  410   continue
  420 continue
  return
  430 ierr = 2
  return
  440 ierr = 3
  return
  450 ierr = its + 10
  return
  460 ierr = 999
  return
end
subroutine squint(nm, n, a, b, c, iguess, s, work, nw, tol, &
   maxits, ierr)
!
!*******************************************************************************
!
!! SQUINT breaks down the work array into smaller pieces.
!
!
!  the actual solution to ax**2 + bx + c = 0 is
!     done in subroutine squin2.  this subroutine merely relieves
!     the user from a long calling sequence.
!
!
!     on entry,
!
!     nm     is the leading dimension of all the matrices
!            in the calling program.
!
!     n      is the order of the matrices a, b and c.
!
!     a      is the matrix coefficient of x**2.
!
!     b      is the matrix coefficient of x.
!
!     c      is the constant matrix.
!
!     iguess is an integer. if iguess/=0, the user supplies an
!            initial guess at a solvent.  this guess is stored in
!            array s.  if iguess==0, the subroutine provides its
!            own initial guess.
!
!     s      contains the users initial guess at a solvent, if iguess
!            has been set to a nonzero quantity.  otherwise the input
!            contents in s are ignored.
!
!     work   is a work vector.  it must be dimensioned at least
!            (7n**2 + n), where n is the order of a, b, c and s.
!
!     nw     is the dimension of the array work in the calling
!            program.
!
!     tol    is a user-supplied accuracy tolerance.  setting tol = 0.0
!            causes iteration to proceed until full machine precision
!            is attained.  otherwise, execution terminates when
!            norm(as**2+bs+c) < tol.
!
!     maxits is an integer.  if maxits/=0, the user specifies the
!            most interations the algorithm is to take.  if maxits.
!             <= 0, it is reset to 30.
!
!
!     on return,
!
!     a,b,c  are destroyed.
!
!     iguess contains the number of iterations performed to
!            compute s.
!
!     s      contains the right solvent.
!
!     work(1) is a complex number with real part equal to the norm
!            of as**2+bs+c.
!
!     ierr   is an integer error return.
!
!            ierr = 0 for a normal return.
!
!            ierr = 1 indicates failure of squint to converge to
!                     a solvent in the maximum number of iterations.
!
!            ierr = 2 indicates failure in the upper reduction in
!                     cqzit.
!
!            ierr = 3 indicates failure in the lower reduction in
!                     cqzit.
!
!            ierr = 10 + n  indicates an error return from trislv
!                     on iteration n, designating inconsistency of
!                     the triangular system.
!
!            ierr = 999 indicates improper dimensioning.  the
!                     conditions  nm >= n > 0   and
!                     nw >= (7*n*n + n) must hold.
!
  integer nm, n, iguess, nw, maxits, ierr, i1, i2, i3, i4, i5, i6, &
   i7
  complex work(nw)
  complex a(nm,n), b(nm,n), c(nm,n), s(nm,n)
  real tol
  i1 = n*n + 1
  i2 = n*n + i1
  i3 = n*n + i2
  i4 = n*n + i3
  i5 = n*n + i4
  i6 = n*n + i5
  i7 = n*n + i6
  call squin2(nm, n, a, b, c, iguess, s, work(1), work(i1), &
   work(i2), work(i3), work(i4), work(i5), work(i6), work(i7), nw, &
   tol, maxits, ierr)
  return
end
subroutine srch(fun,cond,xl,eta,x,num,ierr)
!
!*******************************************************************************
!
!! SRCH calculates an upper bound for the smallest number x such that a
!  given condition is satisfied, assuming
!     that the condition is satisfied for sufficiently large x.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     cond is a real subroutine defined by the user.  the actual name
!     for cond needs to be declared external in the driver program.
!     cond has the arguments fun, x, cnd, and ier, where cnd is
!     a logical variable.
!
!     xl is the smallest value of x for which a search is made.  it
!     should lie in the range - 1.0e4 <= xl < 1.0e4.  it is
!     assumed that the logical variable cnd calculated by cond is
!     .false. when x = xl.
!
!     eta is the relative tolerance to which the result is to be
!     determined.  it is a positive real number.  when this subroutine
!     is used to calculate c for use in the piessens code lainv1
!     (algorithm 619), it is usually sufficient to take eta = 0.01.
!
!     x is the calculated result.  it is larger than the exact
!     result by an amount less than eta*x.
!
!     num is a variable. on output it has for its value the number
!     of evaluations of fun that were performed.
!
!     ierr is an output integer reporting the status of the
!     calculation of x.  ierr is assigned values as follows...
!
!          ierr = 0     the calculation was fully successful.
!
!          ierr = 1     x may be in error due to the calculation
!                       of cond.
!
!          ierr = 2     cnd is .false. when x = 1.0e4.  x is set = 0.0.
!
!          ierr = 3     cnd is .true. for  x >= xl.  x is set to xl.
!
  logical cnd
  external fun, cond
  ierr = 0
!
!     search for an interval (x1, x2) containing x where
!     x1 >= 1.01269
!
  x1 = max ( 1.01269, xl)
  call cond(fun,x1,cnd,num,ier)
  if (cnd) go to 20
!
     x2 = 10.1269
     do 10 i = 1,4
        if (x2 <= x1) go to 10
        call cond(fun,x2,cnd,num1,ier)
        num = num + num1
        if (cnd) go to 200
        x1 = x2
   10    x2 = 10.0*x2
     go to 300
!
   20 if (x1 == xl) go to 400
!
!     search for an interval (x1, x2) containing x where
!     x2 <= 1.01269
!
     x2 = x1
     x1 = -1.11358
     do 30 i = 1,5
        x1 = max ( x1, xl)
        call cond(fun,x1,cnd,num1,ier)
        num = num + num1
        if(.not. cnd) go to 200
        x2 = x1
        if (x1 == xl) go to 400
   30    x1 = 10.0*x1
!
!     search for x in the interval (x1, x2) by bisection
!
  200       dx = x2 - x1
        xbar = x1 + dx/2.0
        call cond(fun,xbar,cnd,num1,ierr)
        num = num + num1
        xm = max ( abs(x1), abs(x2))
        tol = eta
        if (xm > 1.0) tol = eta*xm
        if (dx <= tol) go to 250
           if(cnd) go to 225
              x1 = xbar
              go to 200
  225          x2 = xbar
           go to 200
!
!     final assembly
!
  250       if(cnd) go to 275
           x = x2
           return
  275       x = xbar
        return
!
!     error return when x could not be found in the interval
!     (-1.0e4, 1.oe4).
!
  300 x = 0.0
  ierr = 2
  return
  400 x = xl
  ierr = 3
  return
end
subroutine srot ( n, x, incx, y, incy, c, s )
!
!*******************************************************************************
!
!! SROT applies a plane rotation.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input/output, real X(*), one of the vectors to be rotated.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), one of the vectors to be rotated.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
!    Input, real C, S, parameters (presumably the cosine and sine of
!    some angle) that define a plane rotation.
!
  real c
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer n
  real s
  real stemp
  real x(*)
  real y(*)
!
  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    do i = 1, n
      stemp = c * x(i) + s * y(i)
      y(i) = c * y(i) - s * x(i)
      x(i) = stemp
    end do

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( incy >= 0 ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      stemp = c * x(ix) + s * y(iy)
      y(iy) = c * y(iy) - s * x(ix)
      x(ix) = stemp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine srotg ( sa, sb, c, s )
!
!*******************************************************************************
!
!! SROTG constructs a Givens plane rotation.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input/output, real SA, SB, ...
!
!    Output, real C, S, ...
!
  real c
  real r
  real roe
  real s
  real sa
  real sb
  real scale
  real z
!
  if ( abs ( sa ) > abs ( sb ) ) then
    roe = sa
  else
    roe = sb
  end if

  scale = abs ( sa ) + abs ( sb )

  if ( scale == 0.0E+00 ) then
    c = 1.0E+00
    s = 0.0E+00
    r = 0.0E+00
  else
    r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 )
    r = sign ( 1.0E+00, roe ) * r
    c = sa / r
    s = sb / r
  end if

  if ( abs ( c ) > 0.0E+00 .and. abs ( c ) <= s ) then
    z = 1.0E+00 / c
  else
    z = s
  end if

  sa = r
  sb = z

  return
end
subroutine srotm (n,sx,incx,sy,incy,sparam)
!
!*******************************************************************************
!
!! SROTM applies a modified givens transformation.
!
!
!     apply the modified givens transformation, h, to the 2 by n matrix
!
!     (sx(1)     sx(n))
!     (      ...      )
!     (sy(1)     sy(n))
!
!     with sparam(1)=sflag, h has one of the following forms..
!
!     sflag=-1.e0     sflag=0.e0        sflag=1.e0     sflag=-2.e0
!
!       (sh11  sh12)    (1.e0  sh12)    (sh11  1.e0)    (1.e0  0.e0)
!     h=(          )    (          )    (          )    (          )
!       (sh21  sh22),   (sh21  1.e0),   (-1.e0 sh22),   (0.e0  1.e0).
!
  dimension sx(*),sy(*),sparam(*)
  data zero,two /0.e0,2.e0/
!
  sflag=sparam(1)
  if(n <= 0 .or.(sflag+two==zero)) go to 140
      if(.not.(incx==incy.and. incx  > 0)) go to 70
!
           nsteps=n*incx
           if(sflag) 50,10,30
   10          continue
           sh12=sparam(4)
           sh21=sparam(3)
                do 20 i=1,nsteps,incx
                w=sx(i)
                z=sy(i)
                sx(i)=w+z*sh12
                sy(i)=w*sh21+z
   20               continue
           go to 140
   30          continue
           sh11=sparam(2)
           sh22=sparam(5)
                do 40 i=1,nsteps,incx
                w=sx(i)
                z=sy(i)
                sx(i)=w*sh11+z
                sy(i)=-w+sh22*z
   40               continue
           go to 140
   50          continue
           sh11=sparam(2)
           sh12=sparam(4)
           sh21=sparam(3)
           sh22=sparam(5)
                do 60 i=1,nsteps,incx
                w=sx(i)
                z=sy(i)
                sx(i)=w*sh11+z*sh12
                sy(i)=w*sh21+z*sh22
   60               continue
           go to 140
   70     continue
      kx=1
      ky=1
      if(incx < 0) kx=1+(1-n)*incx
      if(incy < 0) ky=1+(1-n)*incy
!
      if(sflag)120,80,100
   80     continue
      sh12=sparam(4)
      sh21=sparam(3)
           do 90 i=1,n
           w=sx(kx)
           z=sy(ky)
           sx(kx)=w+z*sh12
           sy(ky)=w*sh21+z
           kx=kx+incx
           ky=ky+incy
   90          continue
      go to 140
  100     continue
      sh11=sparam(2)
      sh22=sparam(5)
           do 110 i=1,n
           w=sx(kx)
           z=sy(ky)
           sx(kx)=w*sh11+z
           sy(ky)=-w+sh22*z
           kx=kx+incx
           ky=ky+incy
  110          continue
      go to 140
  120     continue
      sh11=sparam(2)
      sh12=sparam(4)
      sh21=sparam(3)
      sh22=sparam(5)
           do 130 i=1,n
           w=sx(kx)
           z=sy(ky)
           sx(kx)=w*sh11+z*sh12
           sy(ky)=w*sh21+z*sh22
           kx=kx+incx
           ky=ky+incy
  130          continue
  140     continue
      return
end
subroutine srotmg (sd1,sd2,sx1,sy1,sparam)
!
!*******************************************************************************
!
!! SROTMG constructs a modified givens transformation.
!
!
!     construct the modified givens transformation matrix h which zeros
!     the second component of the 2-vector  (sqrt(sd1)*sx1,sqrt(sd2)*
!     sy2)**t.
!     with sparam(1)=sflag, h has one of the following forms..
!
!     sflag=-1.e0     sflag=0.e0        sflag=1.e0     sflag=-2.e0
!
!       (sh11  sh12)    (1.e0  sh12)    (sh11  1.e0)    (1.e0  0.e0)
!     h=(          )    (          )    (          )    (          )
!       (sh21  sh22),   (sh21  1.e0),   (-1.e0 sh22),   (0.e0  1.e0).
!
  dimension sparam(*)
!
  data zero/0.0/, one/1.0/, two/2.0/, gam/4096.0/
!
  iflag=1
  gamsq=1.678e7
  rgam=2.441e-4
  rgamsq=5.960e-8
!
  if(.not. sd1 < zero) go to 10
!       go zero-h-d-and-sx1..
      go to 60
   10 continue
!     case-sd1-nonnegative
  sp2=sd2*sy1
  if(.not. sp2 == zero) go to 20
      sflag=-two
      go to 260
!     regular-case..
   20 continue
  sp1=sd1*sx1
  sq2=sp2*sy1
  sq1=sp1*sx1
!
  if(.not. abs(sq1) > abs(sq2)) go to 40
      sh21=-sy1/sx1
      sh12=sp2/sp1
!
      su=one-sh12*sh21
!
      if(.not. su <= zero) go to 30
!         go zero-h-d-and-sx1..
           go to 60
   30     continue
           sflag=zero
           sd1=sd1/su
           sd2=sd2/su
           sx1=sx1*su
!         go scale-check..
           go to 100
   40 continue
      if(.not. sq2 < zero) go to 50
!         go zero-h-d-and-sx1..
           go to 60
   50     continue
           sflag=one
           sh11=sp1/sp2
           sh22=sx1/sy1
           su=one+sh11*sh22
           stemp=sd2/su
           sd2=sd1/su
           sd1=stemp
           sx1=sy1*su
!         go scale-check
           go to 100
!     procedure..zero-h-d-and-sx1..
   60 continue
      sflag=-one
      sh11=zero
      sh12=zero
      sh21=zero
      sh22=zero
!
      sd1=zero
      sd2=zero
      sx1=zero
!         return..
      go to 220
!     procedure..fix-h..
   70 continue
  if(.not. sflag >= zero) go to 90
!
      if(.not. sflag == zero) go to 80
      sh11=one
      sh22=one
      sflag=-one
      go to 90
   80     continue
      sh21=-one
      sh12=one
      sflag=-one
   90 continue
  go to igo,(120,150,180,210)
!     procedure..scale-check
  100 continue
           if(.not. iflag==1) go to 105
!
!                   recompute rescaling parameters
!                   more accurately..
!
                rgam = one/gam
                gamsq = gam**2
                rgamsq = rgam**2
                iflag = 2
  105          continue
  110     continue
      if(.not. sd1 <= rgamsq) go to 130
           if(sd1 == zero) go to 160
           assign 120 to igo
!              fix-h..
           go to 70
  120          continue
           sd1=sd1*gamsq
           sx1=sx1*rgam
           sh11=sh11*rgam
           sh12=sh12*rgam
      go to 110
  130 continue
  140     continue
      if(.not. sd1 >= gamsq) go to 160
           assign 150 to igo
!              fix-h..
           go to 70
  150          continue
           sd1=sd1*rgamsq
           sx1=sx1*gam
           sh11=sh11*gam
           sh12=sh12*gam
      go to 140
  160 continue
  170     continue
      if(.not. abs(sd2) <= rgamsq) go to 190
           if(sd2 == zero) go to 220
           assign 180 to igo
!              fix-h..
           go to 70
  180          continue
           sd2=sd2*gamsq
           sh21=sh21*rgam
           sh22=sh22*rgam
      go to 170
  190 continue
  200     continue
      if(.not. abs(sd2) >= gamsq) go to 220
           assign 210 to igo
!              fix-h..
           go to 70
  210          continue
           sd2=sd2*rgamsq
           sh21=sh21*gam
           sh22=sh22*gam
      go to 200
  220 continue
      if(sflag)250,230,240
  230     continue
           sparam(3)=sh21
           sparam(4)=sh12
           go to 260
  240     continue
           sparam(2)=sh11
           sparam(5)=sh22
           go to 260
  250     continue
           sparam(2)=sh11
           sparam(3)=sh21
           sparam(4)=sh12
           sparam(5)=sh22
  260 continue
      sparam(1)=sflag
      return
end
subroutine sscal ( n, sa, x, incx )
!
!*******************************************************************************
!
!! SSCAL scales a vector by a constant.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vector.
!
!    Input, real SA, the multiplier.
!
!    Input/output, real X(*), the vector to be scaled.
!
!    Input, integer INCX, the increment between successive entries of X.
!
  integer i
  integer incx
  integer ix
  integer m
  integer n
  real sa
  real x(*)
!
  if ( n <= 0 ) then

  else if ( incx == 1 ) then

    m = mod ( n, 5 )

    x(1:m) = sa * x(1:m)

    do i = m+1, n, 5
      x(i)   = sa * x(i)
      x(i+1) = sa * x(i+1)
      x(i+2) = sa * x(i+2)
      x(i+3) = sa * x(i+3)
      x(i+4) = sa * x(i+4)
    end do

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    do i = 1, n
      x(ix) = sa * x(ix)
      ix = ix + incx
    end do

  end if

  return
end
subroutine sspco(ap,n,kpvt,rcond,z)
!
!*******************************************************************************
!
!! SSPCO factors a real symmetric matrix stored in packed form
!  by elimination with symmetric pivoting and estimates
!     the condition of the matrix.
!
!     if  rcond  is not needed, sspfa is slightly faster.
!     to solve  a*x = b , follow sspco by sspsl.
!     to compute  inverse(a)*c , follow sspco by sspsl.
!     to compute  inverse(a) , follow sspco by sspdi.
!     to compute  determinant(a) , follow sspco by sspdi.
!     to compute  inertia(a), follow sspco by sspdi.
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     output
!
!        ap      a block diagonal matrix and the multipliers which
!                were used to obtain it stored in packed form.
!                the factorization can be written  a = u*d*trans(u)
!                where  u  is a product of permutation and unit
!                upper triangular matrices , trans(u) is the
!                transpose of  u , and  d  is block diagonal
!                with 1 by 1 and 2 by 2 blocks.
!
!        kpvt    integer(n)
!                an integer vector of pivot indices.
!
!        rcond   real
!                an estimate of the reciprocal condition of  a .
!                for the system  a*x = b , relative perturbations
!                in  a  and  b  of size  epsilon  may cause
!                relative perturbations in  x  of size  epsilon/rcond .
!                if  rcond  is so small that the logical expression
!                           1.0 + rcond == 1.0
!                is true, then  a  may be singular to working
!                precision.  in particular,  rcond  is zero  if
!                exact singularity is detected or the estimate
!                underflows.
!
!        z       real(n)
!                a work vector whose contents are usually unimportant.
!                if  a  is close to a singular matrix, then  z  is
!                an approximate null vector in the sense that
!                norm(a*z) = rcond*norm(a)*norm(z) .
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k) = a(i,j)
!             10    continue
!             20 continue
!
!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.
!
!     subroutines and functions
!
!     linpack sspfa
!     blas saxpy,sdot,sscal,sasum
!     fortran abs,amax1,iabs,sign
!
  integer n,kpvt(*)
  real ap(*),z(*)
  real rcond
!
!     internal variables
!
  real ak,akm1,bk,bkm1,sdot,denom,ek,t
  real anorm,s,sasum,ynorm
  integer i,ij,ik,ikm1,ikp1,info,j,jm1,j1
  integer k,kk,km1k,km1km1,kp,kps,ks
!
!
!     find norm of a using only upper half
!
  j1 = 1
  do 30 j = 1, n
     z(j) = sasum(j,ap(j1),1)
     ij = j1
     j1 = j1 + j
     jm1 = j - 1
     if (jm1 < 1) go to 20
     do 10 i = 1, jm1
        z(i) = z(i) + abs(ap(ij))
        ij = ij + 1
   10    continue
   20    continue
   30 continue
  anorm = 0.0e0
  do 40 j = 1, n
     anorm = max ( anorm,z(j))
   40 continue
!
!     factor
!
  call sspfa(ap,n,kpvt,info)
!
!     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
!     estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
!     the components of  e  are chosen to cause maximum local
!     growth in the elements of w  where  u*d*w = e .
!     the vectors are frequently rescaled to avoid overflow.
!
!     solve u*d*w = e
!
  ek = 1.0e0
  do 50 j = 1, n
     z(j) = 0.0e0
   50 continue
  k = n
  ik = (n*(n - 1))/2
   60 if (k == 0) go to 120
     kk = ik + k
     ikm1 = ik - (k - 1)
     ks = 1
     if (kpvt(k) < 0) ks = 2
     kp = iabs(kpvt(k))
     kps = k + 1 - ks
     if (kp == kps) go to 70
        t = z(kps)
        z(kps) = z(kp)
        z(kp) = t
   70    continue
     if (z(k) /= 0.0e0) ek = sign(ek,z(k))
     z(k) = z(k) + ek
     call saxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
     if (ks == 1) go to 80
        if (z(k-1) /= 0.0e0) ek = sign(ek,z(k-1))
        z(k-1) = z(k-1) + ek
        call saxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
   80    continue
     if (ks == 2) go to 100
        if (abs(z(k)) <= abs(ap(kk))) go to 90
           s = abs(ap(kk))/abs(z(k))
           call sscal(n,s,z,1)
           ek = s*ek
   90       continue
        if (ap(kk) /= 0.0e0) z(k) = z(k)/ap(kk)
        if (ap(kk) == 0.0e0) z(k) = 1.0e0
     go to 110
  100    continue
        km1k = ik + k - 1
        km1km1 = ikm1 + k - 1
        ak = ap(kk)/ap(km1k)
        akm1 = ap(km1km1)/ap(km1k)
        bk = z(k)/ap(km1k)
        bkm1 = z(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0e0
        z(k) = (akm1*bk - bkm1)/denom
        z(k-1) = (ak*bkm1 - bk)/denom
  110    continue
     k = k - ks
     ik = ik - k
     if (ks == 2) ik = ik - (k + 1)
  go to 60
  120 continue
  s = 1.0e0/sasum(n,z,1)
  call sscal(n,s,z,1)
!
!     solve trans(u)*y = w
!
  k = 1
  ik = 0
  130 if (k > n) go to 160
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == 1) go to 150
        z(k) = z(k) + sdot(k-1,ap(ik+1),1,z(1),1)
        ikp1 = ik + k
        if (ks == 2) &
           z(k+1) = z(k+1) + sdot(k-1,ap(ikp1+1),1,z(1),1)
        kp = iabs(kpvt(k))
        if (kp == k) go to 140
           t = z(k)
           z(k) = z(kp)
           z(kp) = t
  140       continue
  150    continue
     ik = ik + k
     if (ks == 2) ik = ik + (k + 1)
     k = k + ks
  go to 130
  160 continue
  s = 1.0e0/sasum(n,z,1)
  call sscal(n,s,z,1)
!
  ynorm = 1.0e0
!
!     solve u*d*v = y
!
  k = n
  ik = n*(n - 1)/2
  170 if (k == 0) go to 230
     kk = ik + k
     ikm1 = ik - (k - 1)
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == ks) go to 190
        kp = iabs(kpvt(k))
        kps = k + 1 - ks
        if (kp == kps) go to 180
           t = z(kps)
           z(kps) = z(kp)
           z(kp) = t
  180       continue
        call saxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
        if (ks == 2) call saxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
  190    continue
     if (ks == 2) go to 210
        if (abs(z(k)) <= abs(ap(kk))) go to 200
           s = abs(ap(kk))/abs(z(k))
           call sscal(n,s,z,1)
           ynorm = s*ynorm
  200       continue
        if (ap(kk) /= 0.0e0) z(k) = z(k)/ap(kk)
        if (ap(kk) == 0.0e0) z(k) = 1.0e0
     go to 220
  210    continue
        km1k = ik + k - 1
        km1km1 = ikm1 + k - 1
        ak = ap(kk)/ap(km1k)
        akm1 = ap(km1km1)/ap(km1k)
        bk = z(k)/ap(km1k)
        bkm1 = z(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0e0
        z(k) = (akm1*bk - bkm1)/denom
        z(k-1) = (ak*bkm1 - bk)/denom
  220    continue
     k = k - ks
     ik = ik - k
     if (ks == 2) ik = ik - (k + 1)
  go to 170
  230 continue
  s = 1.0e0/sasum(n,z,1)
  call sscal(n,s,z,1)
  ynorm = s*ynorm
!
!     solve trans(u)*z = v
!
  k = 1
  ik = 0
  240 if (k > n) go to 270
     ks = 1
     if (kpvt(k) < 0) ks = 2
     if (k == 1) go to 260
        z(k) = z(k) + sdot(k-1,ap(ik+1),1,z(1),1)
        ikp1 = ik + k
        if (ks == 2) &
           z(k+1) = z(k+1) + sdot(k-1,ap(ikp1+1),1,z(1),1)
        kp = iabs(kpvt(k))
        if (kp == k) go to 250
           t = z(k)
           z(k) = z(kp)
           z(kp) = t
  250       continue
  260    continue
     ik = ik + k
     if (ks == 2) ik = ik + (k + 1)
     k = k + ks
  go to 240
  270 continue
!     make znorm = 1.0
  s = 1.0e0/sasum(n,z,1)
  call sscal(n,s,z,1)
  ynorm = s*ynorm
!
  if (anorm /= 0.0e0) rcond = ynorm/anorm
  if (anorm == 0.0e0) rcond = 0.0e0
  return
end
subroutine sspdi(ap,n,kpvt,det,inert,work,job)
!
!*******************************************************************************
!
!! SSPDI: determinant, inertia and inverse of a real symmetric matrix
!  using the factors from sspfa, where the matrix is stored in packed form.
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the output from sspfa.
!
!        n       integer
!                the order of the matrix a.
!
!        kpvt    integer(n)
!                the pivot vector from sspfa.
!
!        work    real(n)
!                work vector.  contents ignored.
!
!        job     integer
!                job has the decimal expansion  abc  where
!                   if  c /= 0, the inverse is computed,
!                   if  b /= 0, the determinant is computed,
!                   if  a /= 0, the inertia is computed.
!
!                for example, job = 111  gives all three.
!
!     on return
!
!        variables not requested by job are not used.
!
!        ap     contains the upper triangle of the inverse of
!               the original matrix, stored in packed form.
!               the columns of the upper triangle are stored
!               sequentially in a one-dimensional array.
!
!        det    real(2)
!               determinant of original matrix.
!               determinant = det(1) * 10.0**det(2)
!               with 1.0 <= abs(det(1)) < 10.0
!               or det(1) = 0.0.
!
!        inert  integer(3)
!               the inertia of the original matrix.
!               inert(1)  =  number of positive eigenvalues.
!               inert(2)  =  number of negative eigenvalues.
!               inert(3)  =  number of zero eigenvalues.
!
!     error condition
!
!        a division by zero will occur if the inverse is requested
!        and  sspco  has set rcond == 0.0
!        or  sspfa  has set  info /= 0 .
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas saxpy,scopy,sdot,sswap
!     fortran abs,iabs,mod
!
!     internal variables.
  integer n,job
  real ap(*),work(*)
  real det(2)
  integer kpvt(*),inert(3)
!
  real akkp1,sdot,temp
  real ten,d,t,ak,akp1
  integer ij,ik,ikp1,iks,j,jb,jk,jkp1
  integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep
  logical noinv,nodet,noert
!
  noinv = mod(job,10) == 0
  nodet = mod(job,100)/10 == 0
  noert = mod(job,1000)/100 == 0
!
  if (nodet .and. noert) go to 140
     if (noert) go to 10
        inert(1) = 0
        inert(2) = 0
        inert(3) = 0
   10    continue
     if (nodet) go to 20
        det(1) = 1.0e0
        det(2) = 0.0e0
        ten = 10.0e0
   20    continue
     t = 0.0e0
     ik = 0
     do 130 k = 1, n
        kk = ik + k
        d = ap(kk)
!
!           check if 1 by 1
!
        if (kpvt(k) > 0) go to 50
!
!              2 by 2 block
!              use det (d  s)  =  (d/t * c - t) * t  ,  t = abs(s)
!                      (s  c)
!              to avoid underflow/overflow troubles.
!              take two passes through scaling.  use  t  for flag.
!
           if (t /= 0.0e0) go to 30
              ikp1 = ik + k
              kkp1 = ikp1 + k
              t = abs(ap(kkp1))
              d = (d/t)*ap(kkp1+1) - t
           go to 40
   30          continue
              d = t
              t = 0.0e0
   40          continue
   50       continue
!
        if (noert) go to 60
           if (d > 0.0e0) inert(1) = inert(1) + 1
           if (d < 0.0e0) inert(2) = inert(2) + 1
           if (d == 0.0e0) inert(3) = inert(3) + 1
   60       continue
!
        if (nodet) go to 120
           det(1) = d*det(1)
           if (det(1) == 0.0e0) go to 110
   70             if (abs(det(1)) >= 1.0e0) go to 80
                 det(1) = ten*det(1)
                 det(2) = det(2) - 1.0e0
              go to 70
   80             continue
   90             if (abs(det(1)) < ten) go to 100
                 det(1) = det(1)/ten
                 det(2) = det(2) + 1.0e0
              go to 90
  100             continue
  110          continue
  120       continue
        ik = ik + k
  130    continue
  140 continue
!
!     compute inverse(a)
!
  if (noinv) go to 270
     k = 1
     ik = 0
  150    if (k > n) go to 260
        km1 = k - 1
        kk = ik + k
        ikp1 = ik + k
        kkp1 = ikp1 + k
        if (kpvt(k) < 0) go to 180
!
!              1 by 1
!
           ap(kk) = 1.0e0/ap(kk)
           if (km1 < 1) go to 170
              call scopy(km1,ap(ik+1),1,work,1)
              ij = 0
              do 160 j = 1, km1
                 jk = ik + j
                 ap(jk) = sdot(j,ap(ij+1),1,work,1)
                 call saxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                 ij = ij + j
  160             continue
              ap(kk) = ap(kk) + sdot(km1,work,1,ap(ik+1),1)
  170          continue
           kstep = 1
        go to 220
  180       continue
!
!              2 by 2
!
           t = abs(ap(kkp1))
           ak = ap(kk)/t
           akp1 = ap(kkp1+1)/t
           akkp1 = ap(kkp1)/t
           d = t*(ak*akp1 - 1.0e0)
           ap(kk) = akp1/d
           ap(kkp1+1) = ak/d
           ap(kkp1) = -akkp1/d
           if (km1 < 1) go to 210
              call scopy(km1,ap(ikp1+1),1,work,1)
              ij = 0
              do 190 j = 1, km1
                 jkp1 = ikp1 + j
                 ap(jkp1) = sdot(j,ap(ij+1),1,work,1)
                 call saxpy(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1)
                 ij = ij + j
  190             continue
              ap(kkp1+1) = ap(kkp1+1) &
                           + sdot(km1,work,1,ap(ikp1+1),1)
              ap(kkp1) = ap(kkp1) &
                         + sdot(km1,ap(ik+1),1,ap(ikp1+1),1)
              call scopy(km1,ap(ik+1),1,work,1)
              ij = 0
              do 200 j = 1, km1
                 jk = ik + j
                 ap(jk) = sdot(j,ap(ij+1),1,work,1)
                 call saxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                 ij = ij + j
  200             continue
              ap(kk) = ap(kk) + sdot(km1,work,1,ap(ik+1),1)
  210          continue
           kstep = 2
  220       continue
!
!           swap
!
        ks = iabs(kpvt(k))
        if (ks == k) go to 250
           iks = (ks*(ks - 1))/2
           call sswap(ks,ap(iks+1),1,ap(ik+1),1)
           ksj = ik + ks
           do 230 jb = ks, k
              j = k + ks - jb
              jk = ik + j
              temp = ap(jk)
              ap(jk) = ap(ksj)
              ap(ksj) = temp
              ksj = ksj - (j - 1)
  230          continue
           if (kstep == 1) go to 240
              kskp1 = ikp1 + ks
              temp = ap(kskp1)
              ap(kskp1) = ap(kkp1)
              ap(kkp1) = temp
  240          continue
  250       continue
        ik = ik + k
        if (kstep == 2) ik = ik + k + 1
        k = k + kstep
     go to 150
  260    continue
  270 continue
  return
end
subroutine sspfa(ap,n,kpvt,info)
!
!*******************************************************************************
!
!! SSPFA factors a real symmetric matrix stored in packed form
!  by elimination with symmetric pivoting.
!
!     to solve  a*x = b , follow sspfa by sspsl.
!     to compute  inverse(a)*c , follow sspfa by sspsl.
!     to compute  determinant(a) , follow sspfa by sspdi.
!     to compute  inertia(a) , follow sspfa by sspdi.
!     to compute  inverse(a) , follow sspfa by sspdi.
!
!     on entry
!
!        ap      real (n*(n+1)/2)
!                the packed form of a symmetric matrix  a .  the
!                columns of the upper triangle are stored sequentially
!                in a one-dimensional array of length  n*(n+1)/2 .
!                see comments below for details.
!
!        n       integer
!                the order of the matrix  a .
!
!     output
!
!        ap      a block diagonal matrix and the multipliers which
!                were used to obtain it stored in packed form.
!                the factorization can be written  a = u*d*trans(u)
!                where  u  is a product of permutation and unit
!                upper triangular matrices , trans(u) is the
!                transpose of  u , and  d  is block diagonal
!                with 1 by 1 and 2 by 2 blocks.
!
!        kpvt    integer(n)
!                an integer vector of pivot indices.
!
!        info    integer
!                = 0  normal value.
!                = k  if the k-th pivot block is singular. this is
!                     not an error condition for this subroutine,
!                     but it does indicate that sspsl or sspdi may
!                     divide by zero if called.
!
!     packed storage
!
!          the following program segment will pack the upper
!          triangle of a symmetric matrix.
!
!                k = 0
!                do 20 j = 1, n
!                   do 10 i = 1, j
!                      k = k + 1
!                      ap(k)  = a(i,j)
!             10    continue
!             20 continue
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas saxpy,sswap,isamax
!     fortran abs,amax1,sqrt
!
  integer n,kpvt(*),info
  real ap(*)
!
!     internal variables
!
  real ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
  real absakk,alpha,colmax,rowmax
  integer isamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
  integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
  logical swap
!
!
!     initialize
!
!     alpha is used in choosing pivot block size.
  alpha = (1.0e0 + sqrt(17.0e0))/8.0e0
!
  info = 0
!
!     main loop on k, which goes from n to 1.
!
  k = n
  ik = (n*(n - 1))/2
   10 continue
!
!        leave the loop if k=0 or k=1.
!
!     ...exit
     if (k == 0) go to 200
     if (k > 1) go to 20
        kpvt(1) = 1
        if (ap(1) == 0.0e0) info = 1
!     ......exit
        go to 200
   20    continue
!
!        this section of code determines the kind of
!        elimination to be performed.  when it is completed,
!        kstep will be set to the size of the pivot block, and
!        swap will be set to .true. if an interchange is
!        required.
!
     km1 = k - 1
     kk = ik + k
     absakk = abs(ap(kk))
!
!        determine the largest off-diagonal element in
!        column k.
!
     imax = isamax(k-1,ap(ik+1),1)
     imk = ik + imax
     colmax = abs(ap(imk))
     if (absakk < alpha*colmax) go to 30
        kstep = 1
        swap = .false.
     go to 90
   30    continue
!
!           determine the largest off-diagonal element in
!           row imax.
!
        rowmax = 0.0e0
        imaxp1 = imax + 1
        im = imax*(imax - 1)/2
        imj = im + 2*imax
        do 40 j = imaxp1, k
           rowmax = max ( rowmax,abs(ap(imj)))
           imj = imj + j
   40       continue
        if (imax == 1) go to 50
           jmax = isamax(imax-1,ap(im+1),1)
           jmim = jmax + im
           rowmax = max ( rowmax,abs(ap(jmim)))
   50       continue
        imim = imax + im
        if (abs(ap(imim)) < alpha*rowmax) go to 60
           kstep = 1
           swap = .true.
        go to 80
   60       continue
        if (absakk < alpha*colmax*(colmax/rowmax)) go to 70
           kstep = 1
           swap = .false.
        go to 80
   70       continue
           kstep = 2
           swap = imax /= km1
   80       continue
   90    continue
     if (max ( absakk,colmax) /= 0.0e0) go to 100
!
!           column k is zero.  set info and iterate the loop.
!
        kpvt(k) = k
        info = k
     go to 190
  100    continue
     if (kstep == 2) go to 140
!
!           1 x 1 pivot block.
!
        if (.not.swap) go to 120
!
!              perform an interchange.
!
           call sswap(imax,ap(im+1),1,ap(ik+1),1)
           imj = ik + imax
           do 110 jj = imax, k
              j = k + imax - jj
              jk = ik + j
              t = ap(jk)
              ap(jk) = ap(imj)
              ap(imj) = t
              imj = imj - (j - 1)
  110          continue
  120       continue
!
!           perform the elimination.
!
        ij = ik - (k - 1)
        do 130 jj = 1, km1
           j = k - jj
           jk = ik + j
           mulk = -ap(jk)/ap(kk)
           t = mulk
           call saxpy(j,t,ap(ik+1),1,ap(ij+1),1)
           ijj = ij + j
           ap(jk) = mulk
           ij = ij - (j - 1)
  130       continue
!
!           set the pivot array.
!
        kpvt(k) = k
        if (swap) kpvt(k) = imax
     go to 190
  140    continue
!
!           2 x 2 pivot block.
!
        km1k = ik + k - 1
        ikm1 = ik - (k - 1)
        if (.not.swap) go to 160
!
!              perform an interchange.
!
           call sswap(imax,ap(im+1),1,ap(ikm1+1),1)
           imj = ikm1 + imax
           do 150 jj = imax, km1
              j = km1 + imax - jj
              jkm1 = ikm1 + j
              t = ap(jkm1)
              ap(jkm1) = ap(imj)
              ap(imj) = t
              imj = imj - (j - 1)
  150          continue
           t = ap(km1k)
           ap(km1k) = ap(imk)
           ap(imk) = t
  160       continue
!
!           perform the elimination.
!
        km2 = k - 2
        if (km2 == 0) go to 180
           ak = ap(kk)/ap(km1k)
           km1km1 = ikm1 + k - 1
           akm1 = ap(km1km1)/ap(km1k)
           denom = 1.0e0 - ak*akm1
           ij = ik - (k - 1) - (k - 2)
           do 170 jj = 1, km2
              j = km1 - jj
              jk = ik + j
              bk = ap(jk)/ap(km1k)
              jkm1 = ikm1 + j
              bkm1 = ap(jkm1)/ap(km1k)
              mulk = (akm1*bk - bkm1)/denom
              mulkm1 = (ak*bkm1 - bk)/denom
              t = mulk
              call saxpy(j,t,ap(ik+1),1,ap(ij+1),1)
              t = mulkm1
              call saxpy(j,t,ap(ikm1+1),1,ap(ij+1),1)
              ap(jk) = mulk
              ap(jkm1) = mulkm1
              ijj = ij + j
              ij = ij - (j - 1)
  170          continue
  180       continue
!
!           set the pivot array.
!
        kpvt(k) = 1 - k
        if (swap) kpvt(k) = -imax
        kpvt(k-1) = kpvt(k)
  190    continue
     ik = ik - (k - 1)
     if (kstep == 2) ik = ik - (k - 2)
     k = k - kstep
  go to 10
  200 continue
  return
end
subroutine ssplx (ta,ita,jta,b0,c,m,n0,ind,ibasis,x,z,iter,mxiter, &
                         numle,numge,bi,wk,iwk)
!
!*******************************************************************************
!
!! SSPLX: simplex procedure for solving linear programming problems
!
!     written by alfred h. morris jr.
!     Naval Surface Weapons Center,
!     Dahlgren, Virginia
!
!     initial version  dec  1977
!     last update      sept 1986
!
  dimension ta(*),ita(*),jta(*)
  dimension b0(m),c(n0)
  dimension ibasis(m),bi(m,m)
  dimension x(*),wk(*),iwk(*)
!
!     dimension x(n0+numle+numge)
!     dimension wk(2*m),iwk(2*m+n0)
!
  eps0 = epsilon ( eps0 )
  rerrmn = amin1(1.e-6,1.e3*eps0)
  rerrmx = 1.e-5
  if (eps0 < 1.e-13) rerrmx = 1.e-6
!
  ip = m + n0 + 1
  call ssplx1(ta,ita,jta,b0,c,m,n0,ind,ibasis,x,z,iter,mxiter, &
              eps0,rerrmn,rerrmx,rerr,numle,numge,bi, &
              wk(1),wk(m+1),iwk(1),iwk(ip))
  return
end
subroutine ssplx1(ta,ita,jta,b0,c,m,n0,ind,ibasis,r,z, &
      iter,mxiter,eps0,rerrmn,rerrmx,rerr,numle,numge, &
      bi,xb,y,basis,index)
!
!*******************************************************************************
!
!! SSPLX1 is a utility routine called by ssplx.
!
!
!     nstep = 1   eliminate the negative variables
!     nstep = 2   phase 1 of the simplex algorithm
!     nstep = 3   phase 2 of the simplex algorithm
!
!     mxiter = the maximum number of iterations permitted
!     iter = the number of the current iteration
!     icount = the number of iterations since the last inversion
!
!     numle = the number of <= constraints
!     numge = the number of >= constraints
!
!     the routine assumes that the <= constraints precede the  >= 
!     constraints and that the == constraints come last. there are
!     m constraints. x(n0+i) is the slack, surplus, or artificial
!     variable for the i-th constraint (i=1,...,m).
!
!     n0 = the number of orginal variables
!     ns = the number of orginal and slack variables
!     n  = the number of orginal, slack, and surplus variables
!     num = the total number of variables
!
!     rerrmn = the smallest relative error tolerance used
!     rerrmx = the largest relative error tolerance used
!     rerr   = the estimated current relative error
!
!     let a denote an mxn0 matrix. the transpose of a is stored in
!     sparse form in ta,ita,jta. assume that
!         b0 = (b0(1),...,b0(m))
!         c  = (c(1),...,c(n0))
!         z  = c(1)*x(1)+...+c(n0)*x(n0)
!     the problem is to maximize z subject to
!         ax(le,eq,ge)b0
!         x >= 0
!
!     on input ind can have the values
!         ind = 0   no beginning basis is provided by the user
!         ind = 1   the array ibasis has been set by the user
!     on output ind is assigned one of the values
!         ind = 0   z was successfully maximized
!         ind = 1   the problem has no feasible solution
!         ind = 2   mxiter iterations were performed
!         ind = 3   sufficient accuracy cannot be maintained
!         ind = 4   the problem has an unbounded solution
!         ind = 5   there is an input error
!         ind = 6   z was possibly maximized
!
!     basis is an integer array of dimension n0+m. for j <= n
!         basis(j) = 1  if x(j) is a basic variable
!         basis(j) = 0  if x(j) is not a basic variable
!     if the basic variables are x(i1),...,x(im) then
!         ibasis = (i1,...,im)
!     also xb(1),...,xb(m) are the corresponding values of the
!     basic variables.
!
!     bi is an mxm array containing the inverse of the basis matrix.
!
!     r is an array of dimension n. on output r contains the current
!     value of x. during computation r normally contains the reduced
!     costs used for the selection of the variable to be made basic.
!
  dimension ta(*),ita(*),jta(*)
  dimension b0(m),c(n0)
  dimension bi(m,m),xb(m),y(m),r(*)
  integer   ibasis(m),basis(*)
  integer   bflag,index(m)
  double precision dzero,dsum,dsump,dsumn,dt
  data zero/0.0/,dzero/0.d0/,one/1.0/
!
!     ****** xmax is a machine dependent constant. xmax is the
!            largest positive floating point number.
!
             xmax = huge ( xmax )
!
  iter=0
  icount=0
  mcheck=min (5,1+m/15)
  z=zero
!
!                check for input errors
!
  ms=numle+numge
  if (m < 2.or.n0 < 2.or.ms > m) go to 12
  do 10 i=1,m
  if (b0(i)) 12,10,10
   10 xb(i)=zero
  rtol=xmax
  do 11 i=1,n0
  if (c(i)/=zero) rtol=amin1(abs(c(i)),rtol)
   11 continue
  rtol=rerrmx*rtol
  go to 20
   12 ind=5
  return
!
!     formation of the ibasis and basis arrays. (if ind=1
!     then the ibasis array is defined by the user.)
!
   20 ns=n0+numle
  n=ns+numge
  if (ind==0) go to 30
  num=n
  do 21 i=1,m
  if (ibasis(i) > n) num=num+1
   21 continue
  go to 32
   22 if (ind==0) go to 590
  ind=0
!
   30 num=n0+m
  do 31 i=1,m
   31 ibasis(i)=n0+i
   32 bflag=0
  do 33 i=1,n
   33 basis(i)=0
  do 34 i=1,m
  ki=ibasis(i)
   34 basis(ki)=1
  if (ind==1) go to 100
!
!          calculation of xb and bi when ind=0
!
  rerr=rerrmn
  do 41 j=1,m
  xb(j)=b0(j)
  do 40 i=1,m
   40 bi(i,j)=zero
   41 bi(j,j)=one
  if (numge==0) go to 630
  jmin=numle+1
  do 42 j=jmin,ms
  xb(j)=-xb(j)
   42 bi(j,j)=-1.0
  go to 601
!
!                  reorder the basis
!
  100 ibeg=1
  iend=m
  do 102 i=1,m
  if (ibasis(i) <= n0) go to 101
  index(ibeg)=ibasis(i)
  ibeg=ibeg+1
  go to 102
  101 index(iend)=ibasis(i)
  iend=iend-1
  102 continue
  if (iend==m) go to 22
  do 103 i=1,m
  103 ibasis(i)=index(i)
!
!            reinversion of the basis matrix
!
  do 132 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 110
  if (kj <= ns) go to 120
  if (kj <= n) go to 130
  go to 120
!
  110 do 111 i=1,m
  111 bi(i,j)=zero
  lmin=ita(kj)
  lmax=ita(kj+1)-1
  if (lmin > lmax) go to 132
  do 112 ll=lmin,lmax
  l=jta(ll)
  112 bi(l,j)=ta(ll)
  go to 132
!
  120 l=kj-n0
  do 121 i=1,m
  121 bi(i,j)=zero
  bi(l,j)=one
  go to 132
!
  130 l=kj-n0
  do 131 i=1,m
  131 bi(i,j)=zero
  bi(l,j)=-1.0
  132 continue
!
  icount=0
  call crout1(bi,m,m,iend,index,y,jcol,ierr)
  if (ierr/=0) go to 580
!
!         check the accuracy of bi and reset rerr
!
  bnorm=zero
  do 142 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 140
  sum=one
  go to 142
  140 sum=zero
  lmin=ita(kj)
  lmax=ita(kj+1)-1
  do 141 ll=lmin,lmax
  141 sum=sum+abs(ta(ll))
  142 bnorm=max ( bnorm,sum)
!
  binorm=zero
  do 151 j=1,m
  sum=zero
  do 150 i=1,m
  150 sum=sum+abs(bi(i,j))
  151 binorm=max ( binorm,sum)
  rerr=max ( rerrmn,eps0*bnorm*binorm)
  if (rerr > 1.e-2) go to 580
  bflag=0
!
!                 recalculation of xb
!
  180 do 184 i=1,m
  dsump=dzero
  dsumn=dzero
  do 183 l=1,m
  dt=bi(i,l)*b0(l)
  if (dt) 181,183,182
  181 dsumn=dsumn+dt
  go to 183
  182 dsump=dsump+dt
  183 continue
  xb(i)=dsump+dsumn
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(xb(i)) <= tol) xb(i)=zero
  184 continue
  go to 601
!
!     find the next vector a(--,jp) to be inserted into
!                       the basis
!
  200 jp=0
  rmin=zero
  if (nstep==3) rmin=-rtol
  do 201 j=1,n0
  if (basis(j)==1) go to 201
  if (r(j) >= rmin) go to 201
  jp=j
  rmin=r(j)
  201 continue
  if (n0==n) go to 203
  jmin=n0+1
  rmin=rmin*1.1
  do 202 j=jmin,n
  if (basis(j)==1) go to 202
  if (r(j) >= rmin) go to 202
  jp=j
  rmin=r(j)
  202 continue
  203 if (jp/=0) go to 300
  if (nstep-2) 800,230,250
!
!     insert the values of the orginal, slack, and surplus
!             variables into r. then terminate.
!
  220 do 221 j=1,n
  221 r(j)=zero
  do 222 i=1,m
  ki=ibasis(i)
  if (ki <= n) r(ki)=xb(i)
  222 continue
  return
!
!              completion of the nstep=2 case
!
  230 do 231 i=1,m
  if (ibasis(i) <= n) go to 231
  if (xb(i)) 231,231,800
  231 continue
  go to 680
!
  240 if (icount >= 5) go to 100
  ind=1
  go to 220
!
!              completion of the nstep=3 case
!
  250 if (rerr > 1.e-3) go to 251
  ind=0
  go to 800
  251 if (icount >= 5) go to 100
  ind=6
  go to 800
!
!     if mxiter iterations have not been performed then
!     begin the next iteration. compute the jp-th column
!               of bi*a and store it in y.
!
  300 if (iter < mxiter) go to 301
  ind=2
  go to 220
  301 iter=iter+1
  icount=icount+1
  if (jp > ns) go to 330
  if (jp > n0) go to 320
!
  lmin=ita(jp)
  lmax=ita(jp+1)-1
  if (lmin <= lmax) go to 305
  ind=4
  go to 220
  305 amax=zero
  do 306 ll=lmin,lmax
  306 amax=max ( abs(ta(ll)),amax)
!
  310 rerr1=rerrmx*amax
  do 313 i=1,m
  dsum=dzero
  do 311 ll=lmin,lmax
  l=jta(ll)
  311 dsum=dsum+dble(bi(i,l)*ta(ll))
  y(i)=dsum
  if (abs(y(i)) >= 1.e-3) go to 313
  bmax=zero
  do 312 l=1,m
  312 bmax=max ( abs(bi(i,l)),bmax)
  tol=rerr1*bmax
  if (abs(y(i)) <= tol) y(i)=zero
  313 continue
  go to 350
!
  320 l=jp-n0
  do 321 i=1,m
  321 y(i)=bi(i,l)
  go to 350
!
  330 l=jp-n0
  do 331 i=1,m
  331 y(i)=-bi(i,l)
!
  350 do 352 i=1,m
  if (y(i)) 351,352,351
  351 if (nstep-2) 400,430,440
  352 continue
  r(jp)=zero
  iter=iter-1
  icount=icount-1
  go to 200
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=1 case
!
  400 npos=0
  ip=0
  eps=zero
  epsi=xmax
  do 403 i=1,m
  if (xb(i) < zero.or.y(i) <= zero) go to 403
  ratio=xb(i)/y(i)
  if (ratio-epsi) 401,402,403
  401 epsi=ratio
  npos=1
  index(1)=i
  go to 403
  402 npos=npos+1
  index(npos)=i
  403 continue
  if (npos==0) go to 420
  if (epsi==zero) go to 460
!
  do 410 i=1,m
  if (xb(i) >= zero.or.y(i) >= zero) go to 410
  ratio=xb(i)/y(i)
  if (ratio > epsi) go to 410
  if (ratio < eps) go to 410
  eps=ratio
  ip=i
  410 continue
  if (ip/=0) go to 500
  go to 460
!
  420 do 421 i=1,m
  if (xb(i) >= zero.or.y(i) >= zero) go to 421
  ratio=xb(i)/y(i)
  if (ratio < eps) go to 421
  eps=ratio
  ip=i
  421 continue
  go to 500
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=2 case
!
  430 npos=0
  epsi=xmax
  do 433 i=1,m
  if (y(i) <= zero) go to 433
  ratio=xb(i)/y(i)
  if (ratio-epsi) 431,432,433
  431 epsi=ratio
  npos=1
  index(1)=i
  go to 433
  432 npos=npos+1
  index(npos)=i
  433 continue
  go to 450
!
!     finding the variable xb(ip) to be made nonbasic
!               for the nstep=3 case
!
  440 npos=0
  epsi=xmax
  do 445 i=1,m
  if (y(i)) 441,445,442
  441 if (ibasis(i) <= n) go to 445
  ip=i
  go to 500
  442 ratio=xb(i)/y(i)
  if (ratio-epsi) 443,444,445
  443 epsi=ratio
  npos=1
  index(1)=i
  go to 445
  444 npos=npos+1
  index(npos)=i
  445 continue
!
  450 if (npos/=0) go to 460
  if (icount >= 5) go to 100
  ind=4
  go to 220
!
!              tie breaking procedure
!
  460 ip=index(1)
  if (npos==1) go to 500
  ip = 0
  bmin=xmax
  cmin=xmax
  do 464 ii=1,npos
  i=index(ii)
  l=ibasis(i)
  if (l > n0) go to 461
  if (c(l) <= zero) cmin=amin1(zero,cmin)
  if (c(l) > cmin) go to 464
  imin=i
  cmin=c(l)
  go to 464
  461 if (l <= n) go to 462
  ip=i
  go to 500
  462 lrow=l-n0
  s=b0(lrow)
  if (lrow > numle) go to 463
  if (s > bmin) go to 464
  ip=i
  bmin=s
  go to 464
  463 s=-s
  bmin=amin1(zero,bmin)
  if (s > bmin) go to 464
  ip=i
  bmin=s
  464 continue
  if (cmin <= zero.or.ip==0) ip=imin
!
!               transformation of xb
!
  500 if (xb(ip)==zero) go to 510
  const=xb(ip)/y(ip)
  do 501 i=1,m
  s=xb(i)
  xb(i)=xb(i)-const*y(i)
  if (xb(i) >= zero) go to 501
  if (s >= zero.or.xb(i) >= rerrmx*s) xb(i)=zero
  501 continue
  xb(ip)=const
!
!               transformation of bi
!
  510 do 512 j=1,m
  if (bi(ip,j)==zero) go to 512
  const=bi(ip,j)/y(ip)
  do 511 i=1,m
  511 bi(i,j)=bi(i,j)-const*y(i)
  bi(ip,j)=const
  512 continue
!
!             updating ibasis and basis
!
  iout=ibasis(ip)
  ibasis(ip)=jp
  basis(iout)=0
  basis(jp)=1
  if (iout > n) num=num-1
!
!        check the accuracy of bi and reset rerr
!
  if (rerr > 1.e-3) go to 530
  k=0
  do 521 j=1,m
  kj=ibasis(j)
  if (kj > n0) go to 521
  sum=zero
  lmin=ita(kj)
  lmax=ita(kj+1)-1
  do 520 ll=lmin,lmax
  l=jta(ll)
  520 sum=sum+bi(j,l)*ta(ll)
  rerr=max ( rerr,abs(one-sum))
  k=k+1
  if (k >= mcheck) go to 522
  521 continue
  522 if (rerr <= 1.e-3) go to 600
!
!        the accuracy criteria are not satisfied
!
  530 if (icount < 5) go to 600
  bflag=1
  go to 100
!
  580 if (iter==0) go to 12
  if (bflag==0) go to 590
  bflag=0
  do 581 ip=1,m
  if (jp==ibasis(ip)) go to 582
  581 continue
  582 ibasis(ip)=iout
  basis(jp)=0
  basis(iout)=1
  if (iout > n) num=num+1
  go to 100
!
  590 ind=3
  go to 220
!
!       set up the r array for the nstep=1 case
!
  600 if (nstep-2) 601,630,700
  601 do 602 j=1,m
  if (xb(j)) 610,602,602
  602 continue
  go to 630
!
  610 nstep=1
  m0=0
  do 612 l=1,m
  if (xb(l)) 611,612,612
  611 m0=m0+1
  index(m0)=l
  612 continue
!
  do 623 j=1,m
  dsump=dzero
  dsumn=dzero
  do 622 ll=1,m0
  l=index(ll)
  if (bi(l,j)) 620,622,621
  620 dsumn=dsumn+dble(bi(l,j))
  go to 622
  621 dsump=dsump+dble(bi(l,j))
  622 continue
  y(j)=dsump+dsumn
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(y(j)) <= tol) y(j)=zero
  623 continue
  go to 650
!
!       set up the r array for the nstep=2 case
!
  630 if (n==num) go to 680
  nstep=2
  m0=0
  do 631 l=1,m
  if (ibasis(l) <= n) go to 631
  m0=m0+1
  index(m0)=l
  631 continue
!
  do 643 j=1,m
  dsump=dzero
  dsumn=dzero
  do 642 ll=1,m0
  l=index(ll)
  if (bi(l,j)) 640,642,641
  640 dsumn=dsumn+dble(bi(l,j))
  go to 642
  641 dsump=dsump+dble(bi(l,j))
  642 continue
  y(j)=-(dsump+dsumn)
  s=dsump
  t=dsumn
  tol=rerrmx*max ( s,-t)
  if (abs(y(j)) <= tol) y(j)=zero
  643 continue
!
  650 do 652 j=1,n0
  sum=zero
  if (basis(j)/=0) go to 652
  lmin=ita(j)
  lmax=ita(j+1)-1
  if (lmin > lmax) go to 652
  do 651 ll=lmin,lmax
  l=jta(ll)
  651 sum=sum+y(l)*ta(ll)
  652 r(j)=sum
!
  660 if (n0==ns) go to 670
  jmin=n0+1
  do 661 j=jmin,ns
  r(j)=zero
  if (basis(j)/=0) go to 661
  jj=j-n0
  r(j)=y(jj)
  661 continue
!
  670 if (ns==n) go to 200
  jmin=ns+1
  do 671 j=jmin,n
  r(j)=zero
  if (basis(j)/=0) go to 671
  jj=j-n0
  r(j)=-y(jj)
  671 continue
  go to 200
!
!      set up a new r array for the nstep=3 case
!
  680 nstep=3
  do 682 j=1,m
  dsum=dzero
  do 681 l=1,m
  il=ibasis(l)
  if (il <= n0) dsum=dsum+dble(c(il)*bi(l,j))
  681 continue
  682 y(j)=dsum
!
  do 691 j=1,n0
  r(j)=zero
  if (basis(j)/=0) go to 691
  dsum=-c(j)
  lmin=ita(j)
  lmax=ita(j+1)-1
  r(j)=-c(j)
  if (lmin > lmax) go to 691
  do 690 ll=lmin,lmax
  l=jta(ll)
  690 dsum=dsum+dble(y(l)*ta(ll))
  r(j)=dsum
  if (r(j) >= zero) go to 691
  tol=rerrmx*abs(c(j))
  if (abs(r(j)) <= tol) r(j)=zero
  691 continue
  go to 660
!
!       update the r array for the nstep=3 case
!
  700 const=r(jp)
  do 703 j=1,n0
  if (basis(j)==0) go to 701
  r(j)=zero
  go to 703
  701 sum=zero
  lmin=ita(j)
  lmax=ita(j+1)-1
  if (lmin > lmax) go to 703
  do 702 ll=lmin,lmax
  l=jta(ll)
  702 sum=sum+bi(ip,l)*ta(ll)
  r(j)=r(j)-const*sum
  if (r(j) >= zero) go to 703
  tol=rerrmx*abs(c(j))
  if (abs(r(j)) <= tol) r(j)=zero
  703 continue
!
  710 if (n0==ns) go to 720
  jmin=n0+1
  do 712 j=jmin,ns
  if (basis(j)==0) go to 711
  r(j)=zero
  go to 712
  711 jj=j-n0
  r(j)=r(j)-const*bi(ip,jj)
  712 continue
!
  720 if (ns==n) go to 200
  jmin=ns+1
  do 722 j=jmin,n
  if (basis(j)==0) go to 721
  r(j)=zero
  go to 722
  721 jj=j-n0
  r(j)=r(j)+const*bi(ip,jj)
  722 continue
  go to 200
!
!
!        refine xb and store the result in y
!
  800 do 801 i=1,m
  r(i)=zero
  801 y(i)=zero
!
  do 831 j=1,m
  kj=ibasis(j)
  if (kj <= n0) go to 810
  if (kj <= ns) go to 820
  if (kj <= n) go to 830
  go to 820
!
  810 lmin=ita(kj)
  lmax=ita(kj+1)-1
  do 811 ll=lmin,lmax
  l=jta(ll)
  dt=dble(r(l))+dble(y(l))
  dt=dt+dble(ta(ll)*xb(j))
  r(l)=dt
  811 y(l)=dt-dble(r(l))
  go to 831
!
  820 l=kj-n0
  dt=dble(r(l))+dble(y(l))
  dt=dt+dble(xb(j))
  r(l)=dt
  y(l)=dt-dble(r(l))
  go to 831
!
  830 l=kj-n0
  dt=dble(r(l))+dble(y(l))
  dt=dt-dble(xb(j))
  r(l)=dt
  y(l)=dt-dble(r(l))
  831 continue
!
  do 840 i=1,m
  dt=dble(r(i))+dble(y(i))
  840 r(i)=dble(b0(i))-dt
!
  850 rerr1=amin1(rerrmx,rerr)
  do 858 i=1,m
  if (xb(i)) 851,857,852
  851 dsump=dzero
  dsumn=xb(i)
  go to 853
  852 dsump=xb(i)
  dsumn=dzero
  853 do 856 l=1,m
  dt=bi(i,l)*r(l)
  if (dt) 854,856,855
  854 dsumn=dsumn+dt
  go to 856
  855 dsump=dsump+dt
  856 continue
  y(i)=dsump+dsumn
  if (xb(i) > zero.and.y(i) < zero) go to 857
  if (xb(i) < zero.and.y(i) > zero) go to 857
  s=dsump
  t=dsumn
  tol=rerr1*max ( s,-t)
  if (abs(y(i)) > tol) go to 858
  857 y(i)=zero
  858 continue
  if (nstep-2) 860,870,880
!
!          check the refinement (nstep=1)
!
  860 do 861 i=1,m
  if (y(i) >= zero) go to 861
  if (y(i) < -rerrmx) go to 240
  y(i)=zero
  861 xb(i)=y(i)
  go to 630
!
!          check the refinement (nstep=2)
!
  870 do 871 i=1,m
  if (ibasis(i) <= n) go to 871
  if (y(i) > rerrmx) go to 240
  y(i)=zero
  871 xb(i)=y(i)
  go to 680
!
!               compute z  (nstep=3)
!
  880 dsum=dzero
  do 881 i=1,m
  ki=ibasis(i)
  if (ki > n0) go to 881
  dsum=dsum+dble(c(ki)*y(i))
  881 xb(i)=y(i)
  z=dsum
  go to 220
end
subroutine sspsl(ap,n,kpvt,b)
!
!*******************************************************************************
!
!! SSPSL solves the real symmetric system a * x = b
!     using the factors computed by sspfa.
!
!     on entry
!
!        ap      real(n*(n+1)/2)
!                the output from sspfa.
!
!        n       integer
!                the order of the matrix  a .
!
!        kpvt    integer(n)
!                the pivot vector from sspfa.
!
!        b       real(n)
!                the right hand side vector.
!
!     on return
!
!        b       the solution vector  x .
!
!     error condition
!
!        a division by zero may occur if  sspco  has set rcond == 0.0
!        or  sspfa  has set info /= 0  .
!
!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!           call sspfa(ap,n,kpvt,info)
!           if (info /= 0) go to ...
!           do 10 j = 1, p
!              call sspsl(ap,n,kpvt,c(1,j))
!        10 continue
!
!     linpack. this version dated 08/14/78 .
!     james bunch, univ. calif. san diego, argonne nat. lab.
!
!     subroutines and functions
!
!     blas saxpy,sdot
!     fortran iabs
!
!     internal variables.
!
  integer n,kpvt(*)
  real ap(*),b(*)
!
  real ak,akm1,bk,bkm1,sdot,denom,temp
  integer ik,ikm1,ikp1,k,kk,km1k,km1km1,kp
!
!     loop backward applying the transformations and
!     d inverse to b.
!
  k = n
  ik = (n*(n - 1))/2
   10 if (k == 0) go to 80
     kk = ik + k
     if (kpvt(k) < 0) go to 40
!
!           1 x 1 pivot block.
!
        if (k == 1) go to 30
           kp = kpvt(k)
           if (kp == k) go to 20
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
   20          continue
!
!              apply the transformation.
!
           call saxpy(k-1,b(k),ap(ik+1),1,b(1),1)
   30       continue
!
!           apply d inverse.
!
        b(k) = b(k)/ap(kk)
        k = k - 1
        ik = ik - k
     go to 70
   40    continue
!
!           2 x 2 pivot block.
!
        ikm1 = ik - (k - 1)
        if (k == 2) go to 60
           kp = iabs(kpvt(k))
           if (kp == k - 1) go to 50
!
!                 interchange.
!
              temp = b(k-1)
              b(k-1) = b(kp)
              b(kp) = temp
   50          continue
!
!              apply the transformation.
!
           call saxpy(k-2,b(k),ap(ik+1),1,b(1),1)
           call saxpy(k-2,b(k-1),ap(ikm1+1),1,b(1),1)
   60       continue
!
!           apply d inverse.
!
        km1k = ik + k - 1
        kk = ik + k
        ak = ap(kk)/ap(km1k)
        km1km1 = ikm1 + k - 1
        akm1 = ap(km1km1)/ap(km1k)
        bk = b(k)/ap(km1k)
        bkm1 = b(k-1)/ap(km1k)
        denom = ak*akm1 - 1.0e0
        b(k) = (akm1*bk - bkm1)/denom
        b(k-1) = (ak*bkm1 - bk)/denom
        k = k - 2
        ik = ik - (k + 1) - k
   70    continue
  go to 10
   80 continue
!
!     loop forward applying the transformations.
!
  k = 1
  ik = 0
   90 if (k > n) go to 160
     if (kpvt(k) < 0) go to 120
!
!           1 x 1 pivot block.
!
        if (k == 1) go to 110
!
!              apply the transformation.
!
           b(k) = b(k) + sdot(k-1,ap(ik+1),1,b(1),1)
           kp = kpvt(k)
           if (kp == k) go to 100
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
  100          continue
  110       continue
        ik = ik + k
        k = k + 1
     go to 150
  120    continue
!
!           2 x 2 pivot block.
!
        if (k == 1) go to 140
!
!              apply the transformation.
!
           b(k) = b(k) + sdot(k-1,ap(ik+1),1,b(1),1)
           ikp1 = ik + k
           b(k+1) = b(k+1) + sdot(k-1,ap(ikp1+1),1,b(1),1)
           kp = iabs(kpvt(k))
           if (kp == k) go to 130
!
!                 interchange.
!
              temp = b(k)
              b(k) = b(kp)
              b(kp) = temp
  130          continue
  140       continue
        ik = ik + k + k + 1
        k = k + 2
  150    continue
  go to 90
  160 continue
  return
end
subroutine ssubt (a,ia,ja,b,ib,jb,c,ic,jc,m,n,num,wk,ierr)
!
!*******************************************************************************
!
!! SSUBT: subtraction of sparse real matrices
!
  real a(*), b(*), c(*), wk(n), t
  integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*)
!
  do 10 j = 1,n
     wk(j) = 0.0
   10 continue
!
!                  compute the i-th row of c
!
  ip = 1
  do 42 i = 1,m
     ic(i) = ip
     mina = ia(i)
     maxa = ia(i+1) - 1
     if (mina > maxa) go to 30
     do 20 l = mina,maxa
        j = ja(l)
        wk(j) = a(l)
   20    continue
!
   30    minb = ib(i)
     maxb = ib(i+1) - 1
     if (minb > maxb) go to 40
     do 31 l = minb,maxb
        j = jb(l)
        t = wk(j) - b(l)
        wk(j) = 0.0
        if (t == 0.0) go to 31
        if (ip > num) go to 50
        c(ip) = t
        jc(ip) = j
        ip = ip + 1
   31    continue
!
   40    if (mina > maxa) go to 42
     do 41 l = mina,maxa
        j = ja(l)
        if (wk(j) == 0.0) go to 41
        if (ip > num) go to 50
        c(ip) = wk(j)
        wk(j) = 0.0
        jc(ip) = j
        ip = ip + 1
   41    continue
   42 continue
  ic(m + 1) = ip
  ierr = 0
  return
!
!                        error return
!
   50 ierr = i
  return
end
subroutine ssvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
!
!*******************************************************************************
!
!! SSVDC computes the singular value decomposition of a rectangular matrix.
!
!
!  ssvdc is a subroutine to reduce a real nxp matrix x by
!     orthogonal transformations u and v to diagonal form.  the
!     diagonal elements s(i) are the singular values of x.  the
!     columns of u are the corresponding left singular vectors,
!     and the columns of v the right singular vectors.
!
!     on entry
!
!         x         real(ldx,p), where ldx >= n.
!                   x contains the matrix whose singular value
!                   decomposition is to be computed.  x is
!                   destroyed by ssvdc.
!
!         ldx       integer.
!                   ldx is the leading dimension of the array x.
!
!         n         integer.
!                   n is the number of rows of the matrix x.
!
!         p         integer.
!                   p is the number of columns of the matrix x.
!
!         ldu       integer.
!                   ldu is the leading dimension of the array u.
!                   (see below).
!
!         ldv       integer.
!                   ldv is the leading dimension of the array v.
!                   (see below).
!
!         work      real(n).
!                   work is a scratch array.
!
!         job       integer.
!                   job controls the computation of the singular
!                   vectors.  it has the decimal expansion ab
!                   with the following meaning
!
!                        a==0    do not compute the left singular
!                                  vectors.
!                        a==1    return the n left singular vectors
!                                  in u.
!                        a >= 2    return the first min(n,p) singular
!                                  vectors in u.
!                        b==0    do not compute the right singular
!                                  vectors.
!                        b==1    return the right singular vectors
!                                  in v.
!
!     on return
!
!         s         real(mm), where mm=min(n+1,p).
!                   the first min(n,p) entries of s contain the
!                   singular values of x arranged in descending
!                   order of magnitude.
!
!         e         real(p).
!                   e ordinarily contains zeros.  however see the
!                   discussion of info for exceptions.
!
!         u         real(ldu,k), where ldu >= n.  if joba==1 then
!                                   k==n, if joba >= 2 then
!                                   k==min(n,p).
!                   u contains the matrix of left singular vectors.
!                   u is not referenced if joba==0.  if n <= p
!                   or if joba==2, then u may be identified with x
!                   in the subroutine call.
!
!         v         real(ldv,p), where ldv >= p.
!                   v contains the matrix of right singular vectors.
!                   v is not referenced if job==0.  if p <= n,
!                   then v may be identified with x in the
!                   subroutine call.
!
!         info      integer.
!                   the singular values (and their corresponding
!                   singular vectors) s(info+1),s(info+2),...,s(m)
!                   are correct (here m=min(n,p)).  thus if
!                   info==0, all the singular values and their
!                   vectors are correct.  in any event, the matrix
!                   b = trans(u)*x*v is the bidiagonal matrix
!                   with the elements of s on its diagonal and the
!                   elements of e on its super-diagonal (trans(u)
!                   is the transpose of u).  thus the singular
!                   values of x and b are the same.
!
!     linpack. this version dated 03/19/79 .
!     g.w. stewart, university of maryland, argonne national lab.
!
!     ***** uses the following functions and subprograms.
!
!     external srot
!     blas saxpy,sdot,sscal,sswap,snrm2,srotg
!     fortran abs,amax1,max0,min0,mod,sqrt
!
!     internal variables
!
  integer ldx,n,p,ldu,ldv,job,info
  real x(ldx,*),s(*),e(*),u(ldu,*),v(ldv,*),work(*)
!
  integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, &
          mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
  real sdot,t
  real b,c,cs,el,emm1,f,g,snrm2,scale,shift,sl,sm,sn,smm1,t1,test, &
       ztest
  logical wantu,wantv
!
!
!     set the maximum number of iterations.
!
  maxit = 30
!
!     determine what is to be computed.
!
  wantu = .false.
  wantv = .false.
  jobu = mod(job,100)/10
  ncu = n
  if (jobu > 1) ncu = min (n,p)
  if (jobu /= 0) wantu = .true.
  if (mod(job,10) /= 0) wantv = .true.
!
!     reduce x to bidiagonal form, storing the diagonal elements
!     in s and the super-diagonal elements in e.
!
  info = 0
  nct = min (n-1,p)
  nrt = max (0,min (p-2,n))
  lu = max (nct,nrt)
  if (lu < 1) go to 170
  do 160 l = 1, lu
     lp1 = l + 1
     if (l > nct) go to 20
!
!           compute the transformation for the l-th column and
!           place the l-th diagonal in s(l).
!
        s(l) = snrm2(n-l+1,x(l,l),1)
        if (s(l) == 0.0e0) go to 10
           if (x(l,l) /= 0.0e0) s(l) = sign(s(l),x(l,l))
           call sscal(n-l+1,1.0e0/s(l),x(l,l),1)
           x(l,l) = 1.0e0 + x(l,l)
   10       continue
        s(l) = -s(l)
   20    continue
     if (p < lp1) go to 50
     do 40 j = lp1, p
        if (l > nct) go to 30
        if (s(l) == 0.0e0) go to 30
!
!              apply the transformation.
!
           t = -sdot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
           call saxpy(n-l+1,t,x(l,l),1,x(l,j),1)
   30       continue
!
!           place the l-th row of x into  e for the
!           subsequent calculation of the row transformation.
!
        e(j) = x(l,j)
   40    continue
   50    continue
     if (.not.wantu .or. l > nct) go to 70
!
!           place the transformation in u for subsequent back
!           multiplication.
!
        do 60 i = l, n
           u(i,l) = x(i,l)
   60       continue
   70    continue
     if (l > nrt) go to 150
!
!           compute the l-th row transformation and place the
!           l-th super-diagonal in e(l).
!
        e(l) = snrm2(p-l,e(lp1),1)
        if (e(l) == 0.0e0) go to 80
           if (e(lp1) /= 0.0e0) e(l) = sign(e(l),e(lp1))
           call sscal(p-l,1.0e0/e(l),e(lp1),1)
           e(lp1) = 1.0e0 + e(lp1)
   80       continue
        e(l) = -e(l)
        if (lp1 > n .or. e(l) == 0.0e0) go to 120
!
!              apply the transformation.
!
           do 90 i = lp1, n
              work(i) = 0.0e0
   90          continue
           do 100 j = lp1, p
              call saxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
  100          continue
           do 110 j = lp1, p
              call saxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1)
  110          continue
  120       continue
        if (.not.wantv) go to 140
!
!              place the transformation in v for subsequent
!              back multiplication.
!
           do 130 i = lp1, p
              v(i,l) = e(i)
  130          continue
  140       continue
  150    continue
  160 continue
  170 continue
!
!     set up the final bidiagonal matrix of order m.
!
  m = min (p,n+1)
  nctp1 = nct + 1
  nrtp1 = nrt + 1
  if (nct < p) s(nctp1) = x(nctp1,nctp1)
  if (n < m) s(m) = 0.0e0
  if (nrtp1 < m) e(nrtp1) = x(nrtp1,m)
  e(m) = 0.0e0
!
!     if required, generate u.
!
  if (.not.wantu) go to 300
     if (ncu < nctp1) go to 200
     do 190 j = nctp1, ncu
        do 180 i = 1, n
           u(i,j) = 0.0e0
  180       continue
        u(j,j) = 1.0e0
  190    continue
  200    continue
     if (nct < 1) go to 290
     do 280 ll = 1, nct
        l = nct - ll + 1
        if (s(l) == 0.0e0) go to 250
           lp1 = l + 1
           if (ncu < lp1) go to 220
           do 210 j = lp1, ncu
              t = -sdot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
              call saxpy(n-l+1,t,u(l,l),1,u(l,j),1)
  210          continue
  220          continue
           call sscal(n-l+1,-1.0e0,u(l,l),1)
           u(l,l) = 1.0e0 + u(l,l)
           lm1 = l - 1
           if (lm1 < 1) go to 240
           do 230 i = 1, lm1
              u(i,l) = 0.0e0
  230          continue
  240          continue
        go to 270
  250       continue
           do 260 i = 1, n
              u(i,l) = 0.0e0
  260          continue
           u(l,l) = 1.0e0
  270       continue
  280    continue
  290    continue
  300 continue
!
!     if it is required, generate v.
!
  if (.not.wantv) go to 350
     do 340 ll = 1, p
        l = p - ll + 1
        lp1 = l + 1
        if (l > nrt) go to 320
        if (e(l) == 0.0e0) go to 320
           do 310 j = lp1, p
              t = -sdot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
              call saxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
  310          continue
  320       continue
        do 330 i = 1, p
           v(i,l) = 0.0e0
  330       continue
        v(l,l) = 1.0e0
  340    continue
  350 continue
!
!     main iteration loop for the singular values.
!
  mm = m
  iter = 0
  360 continue
!
!        quit if all the singular values have been found.
!
!     ...exit
     if (m == 0) go to 620
!
!        if too many iterations have been performed, set
!        flag and return.
!
     if (iter < maxit) go to 370
        info = m
!     ......exit
        go to 620
  370    continue
!
!        this section of the program inspects for
!        negligible elements in the s and e arrays.  on
!        completion the variables kase and l are set as follows.
!
!           kase = 1     if s(m) and e(l-1) are negligible and l < m
!           kase = 2     if s(l) is negligible and l < m
!           kase = 3     if e(l-1) is negligible, l < m, and
!                        s(l), ..., s(m) are not negligible (qr step).
!           kase = 4     if e(m-1) is negligible (convergence).
!
     do 390 ll = 1, m
        l = m - ll
!        ...exit
        if (l == 0) go to 400
        test = abs(s(l)) + abs(s(l+1))
        ztest = test + abs(e(l))
        if (ztest /= test) go to 380
           e(l) = 0.0e0
!        ......exit
           go to 400
  380       continue
  390    continue
  400    continue
     if (l /= m - 1) go to 410
        kase = 4
     go to 480
  410    continue
        lp1 = l + 1
        mp1 = m + 1
        do 430 lls = lp1, mp1
           ls = m - lls + lp1
!           ...exit
           if (ls == l) go to 440
           test = 0.0e0
           if (ls /= m) test = test + abs(e(ls))
           if (ls /= l + 1) test = test + abs(e(ls-1))
           ztest = test + abs(s(ls))
           if (ztest /= test) go to 420
              s(ls) = 0.0e0
!           ......exit
              go to 440
  420          continue
  430       continue
  440       continue
        if (ls /= l) go to 450
           kase = 3
        go to 470
  450       continue
        if (ls /= m) go to 460
           kase = 1
        go to 470
  460       continue
           kase = 2
           l = ls
  470       continue
  480    continue
     l = l + 1
!
!        perform the task indicated by kase.
!
     go to (490,520,540,570), kase
!
!        deflate negligible s(m).
!
  490    continue
        mm1 = m - 1
        f = e(m-1)
        e(m-1) = 0.0e0
        do 510 kk = l, mm1
           k = mm1 - kk + l
           t1 = s(k)
           call srotg(t1,f,cs,sn)
           s(k) = t1
           if (k == l) go to 500
              f = -sn*e(k-1)
              e(k-1) = cs*e(k-1)
  500          continue
           if (wantv) call srot(p,v(1,k),1,v(1,m),1,cs,sn)
  510       continue
     go to 610
!
!        split at negligible s(l).
!
  520    continue
        f = e(l-1)
        e(l-1) = 0.0e0
        do 530 k = l, m
           t1 = s(k)
           call srotg(t1,f,cs,sn)
           s(k) = t1
           f = -sn*e(k)
           e(k) = cs*e(k)
           if (wantu) call srot(n,u(1,k),1,u(1,l-1),1,cs,sn)
  530       continue
     go to 610
!
!        perform one qr step.
!
  540    continue
!
!           calculate the shift.
!
        scale = max ( abs(s(m)),abs(s(m-1)),abs(e(m-1)),abs(s(l)), &
                      abs(e(l)))
        sm = s(m)/scale
        smm1 = s(m-1)/scale
        emm1 = e(m-1)/scale
        sl = s(l)/scale
        el = e(l)/scale
        b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0e0
        c = (sm*emm1)**2
        shift = 0.0e0
        if (b == 0.0e0 .and. c == 0.0e0) go to 550
           shift = sqrt(b**2+c)
           if (b < 0.0e0) shift = -shift
           shift = c/(b + shift)
  550       continue
        f = (sl + sm)*(sl - sm) - shift
        g = sl*el
!
!           chase zeros.
!
        mm1 = m - 1
        do 560 k = l, mm1
           call srotg(f,g,cs,sn)
           if (k /= l) e(k-1) = f
           f = cs*s(k) + sn*e(k)
           e(k) = cs*e(k) - sn*s(k)
           g = sn*s(k+1)
           s(k+1) = cs*s(k+1)
           if (wantv) call srot(p,v(1,k),1,v(1,k+1),1,cs,sn)
           call srotg(f,g,cs,sn)
           s(k) = f
           f = cs*e(k) + sn*s(k+1)
           s(k+1) = -sn*e(k) + cs*s(k+1)
           g = sn*e(k+1)
           e(k+1) = cs*e(k+1)
           if (wantu .and. k < n) &
              call srot(n,u(1,k),1,u(1,k+1),1,cs,sn)
  560       continue
        e(m-1) = f
        iter = iter + 1
     go to 610
!
!        convergence.
!
  570    continue
!
!           make the singular value  positive.
!
        if (s(l) >= 0.0e0) go to 580
           s(l) = -s(l)
           if (wantv) call sscal(p,-1.0e0,v(1,l),1)
  580       continue
!
!           order the singular value.
!
  590       if (l == mm) go to 600
!           ...exit
           if (s(l) >= s(l+1)) go to 600
           t = s(l)
           s(l) = s(l+1)
           s(l+1) = t
           if (wantv .and. l < p) &
              call sswap(p,v(1,l),1,v(1,l+1),1)
           if (wantu .and. l < n) &
              call sswap(n,u(1,l),1,u(1,l+1),1)
           l = l + 1
        go to 590
  600       continue
        iter = 0
        m = m - 1
  610    continue
  go to 360
  620 continue
  return
end
subroutine sswap ( n, x, incx, y, incy )
!
!*******************************************************************************
!
!! SSWAP interchanges two vectors.
!
!
!  Modified:
!
!    08 April 1999
!
!  Reference:
!
!    Lawson, Hanson, Kincaid, Krogh,
!    Basic Linear Algebra Subprograms for Fortran Usage,
!    Algorithm 539,
!    ACM Transactions on Mathematical Software,
!    Volume 5, Number 3, September 1979, pages 308-323.
!
!  Parameters:
!
!    Input, integer N, the number of entries in the vectors.
!
!    Input/output, real X(*), one of the vectors to swap.
!
!    Input, integer INCX, the increment between successive entries of X.
!
!    Input/output, real Y(*), one of the vectors to swap.
!
!    Input, integer INCY, the increment between successive elements of Y.
!
  integer i
  integer incx
  integer incy
  integer ix
  integer iy
  integer m
  integer n
  real temp
  real x(*)
  real y(*)
!
  if ( n <= 0 ) then

  else if ( incx == 1 .and. incy == 1 ) then

    m = mod ( n, 3 )

    do i = 1, m
      temp = x(i)
      x(i) = y(i)
      y(i) = temp
    end do

    do i = m+1, n, 3

      temp = x(i)
      x(i) = y(i)
      y(i) = temp

      temp = x(i+1)
      x(i+1) = y(i+1)
      y(i+1) = temp

      temp = x(i+2)
      x(i+2) = y(i+2)
      y(i+2) = temp

    end do

  else

    if ( incx >= 0 ) then
      ix = 1
    else
      ix = ( - n + 1 ) * incx + 1
    end if

    if ( incy >= 0 ) then
      iy = 1
    else
      iy = ( - n + 1 ) * incy + 1
    end if

    do i = 1, n
      temp = x(ix)
      x(ix) = y(iy)
      y(iy) = temp
      ix = ix + incx
      iy = iy + incy
    end do

  end if

  return
end
subroutine step1(f,neqn,y,x,h,eps,wt,start, &
   hold,k,kold,crash,phi,p,yp,psi, &
   alpha,beta,sig,v,w,g,phase1,ns,nornd)
!
!*******************************************************************************
!
!! STEP1 is used by subroutine ode to take an integration step.
!
!
!   written by l. f. shampine and m. k. gordon
!
!   abstract
!
!   subroutine  step1  is normally used indirectly through subroutine
!   ode .  because  ode  suffices for most problems and is much easier
!   to use, using it should be considered before using  step1  alone.
!
!   subroutine step1 integrates a system of  neqn  first order ordinary
!   differential equations one step, normally from x to x+h, using a
!   modified divided difference form of the adams pece formulas.  local
!   extrapolation is used to improve absolute stability and accuracy.
!   the code adjusts its order and step size to control the local error
!   per unit step in a generalized sense.  special devices are included
!   to control roundoff error and to detect when the user is requesting
!   too much accuracy.
!
!   this code is completely explained and documented in the text,
!   computer solution of ordinary differential equations,  the initial
!   value problem  by l. f. shampine and m. k. gordon.
!
!
!   the parameters represent...
!      f -- subroutine to evaluate derivatives
!      neqn -- number of equations to be integrated
!      y(*) -- solution vector at x
!      x -- independent variable
!      h -- appropriate step size for next step.  normally determined by
!           code
!      eps -- local error tolerance
!      wt(*) -- vector of weights for error criterion
!      start -- logical variable set .true. for first step,  .false.
!           otherwise
!      hold -- step size used for last successful step
!      k -- appropriate order for next step (determined by code)
!      kold -- order used for last successful step
!      crash -- logical variable set .true. when no step can be taken,
!           .false. otherwise.
!      yp(*) -- derivative of solution vector at  x  after successful
!           step
!   the arrays  phi, psi  are required for the interpolation subroutine
!   intrp .  the array  p  is internal to the code.  the remaining nine
!   variables and arrays are included in the call list only to eliminate
!   local retention of variables between calls.
!
!   input to step1
!
!      first call --
!
!   the user must provide storage in his calling program for all arrays
!   in the call list, namely
!
!     dimension y(neqn),wt(neqn),phi(neqn,16),p(neqn),yp(neqn),psi(12),
!    1  alpha(12),beta(12),sig(13),v(12),w(12),g(13)
!
!   the user must also declare  start ,  crash ,  phase1  and  nornd
!   logical variables and  f  an external subroutine, supply the
!   subroutine  f(x,y,yp)  to evaluate
!      dy(i)/dx = yp(i) = f(x,y(1),y(2),...,y(neqn))
!   and initialize only the following parameters...
!      neqn -- number of equations to be integrated
!      y(*) -- vector of initial values of dependent variables
!      x -- initial value of the independent variable
!      h -- nominal step size indicating direction of integration
!           and maximum size of step.  must be variable
!      eps -- local error tolerance per step.  must be variable
!      wt(*) -- vector of non-zero weights for error criterion
!      start -- .true.
!
!   step1  requires that the l2 norm of the vector with components
!   local error(l)/wt(l)  be less than  eps  for a successful step.  the
!   array  wt  allows the user to specify an error test appropriate
!   for his problem.  for example,
!      wt(l) = 1.0  specifies absolute error,
!            = abs(y(l))  error relative to the most recent value of the
!                 l-th component of the solution,
!            = abs(yp(l))  error relative to the most recent value of
!                 the l-th component of the derivative,
!            = max ( wt(l),abs(y(l)))  error relative to the largest
!                 magnitude of l-th component obtained so far,
!            = abs(y(l))*relerr/eps + abserr/eps  specifies a mixed
!                 relative-absolute test where  relerr  is relative
!                 error,  abserr  is absolute error and  eps =
!                 max ( relerr,abserr) .
!
!      subsequent calls --
!
!   subroutine  step1  is designed so that all information needed to
!   continue the integration, including the step size  h  and the order
!   k , is returned with each step.  with the exception of the step
!   size, the error tolerance, and the weights, none of the parameters
!   should be altered.  the array  wt  must be updated after each step
!   to maintain relative error tests like those above.  normally the
!   integration is continued just beyond the desired endpoint and the
!   solution interpolated there with subroutine  intrp .  if it is
!   impossible to integrate beyond the endpoint, the step size may be
!   reduced to hit the endpoint since the code will not take a step
!   larger than the  h  input.  changing the direction of integration,
!   i.e., the sign of  h , requires the user set  start = .true. before
!   calling  step1  again.  this is the only situation in which  start
!   should be altered.
!
!   output from step1
!
!      successful step --
!
!   the subroutine returns after each successful step with  start  and
!   crash  set .false. .  x  represents the independent variable
!   advanced one step of length  hold  from its value on input and  y
!   the solution vector at the new value of  x .  all other parameters
!   represent information corresponding to the new  x  needed to
!   continue the integration.
!
!      unsuccessful step --
!
!   when the error tolerance is too small for the machine precision,
!   the subroutine returns without taking a step and  crash = .true. .
!   an appropriate step size and error tolerance for continuing are
!   estimated and all other information is restored as upon input
!   before returning.  to continue with the larger tolerance, the user
!   just calls the code again.  a restart is neither required nor
!   desirable.
!
  logical start,crash,phase1,nornd
  dimension y(neqn),wt(neqn),phi(neqn,16),p(neqn),yp(neqn),psi(12), &
    alpha(12),beta(12),sig(13),v(12),w(12),g(13)
  dimension two(13),gstr(13)
  external f
!
  data two(1)/2.0/, two(2)/4.0/, two(3)/8.0/, two(4)/16.0/, &
       two(5)/32.0/, two(6)/64.0/, two(7)/128.0/, two(8)/256.0/, &
       two(9)/512.0/, two(10)/1024.0/, two(11)/2048.0/, &
       two(12)/4096.0/, two(13)/8192.0/
  data gstr(1)/0.500/, gstr(2)/0.0833/, gstr(3)/0.0417/, &
       gstr(4)/0.0264/, gstr(5)/0.0188/, gstr(6)/0.0143/, &
       gstr(7)/0.0114/, gstr(8)/0.00936/, gstr(9)/0.00789/, &
       gstr(10)/0.00679/, gstr(11)/0.00592/, gstr(12)/0.00524/, &
       gstr(13)/0.00468/
!
  u = epsilon ( u )
  twou = 2.0*u
  fouru = 4.0*u
!
!       ***     begin block 0     ***
!
!   check if step size or error tolerance is too small for machine
!   precision.  if first step, initialize phi array and estimate a
!   starting step size.
!
!                   ***
!
!   if step size is too small, determine an acceptable one
!
  crash = .true.
  if(abs(h) >= fouru*abs(x)) go to 5
  h = sign(fouru*abs(x),h)
  return
 5    p5eps = 0.5*eps
!
!   if error tolerance is too small, increase it to an acceptable value
!
  round = 0.0
  do 10 l = 1,neqn
 10     round = round + (y(l)/wt(l))**2
  round = twou*sqrt(round)
  if(p5eps >= round) go to 15
  eps = 2.0*round*(1.0 + fouru)
  return
 15   crash = .false.
  g(1) = 1.0
  g(2) = 0.5
  sig(1) = 1.0
  if(.not.start) go to 99
!
!   initialize.  compute appropriate step size for first step
!
  call f(x,y,yp)
  sum = 0.0
  do 20 l = 1,neqn
    phi(l,1) = yp(l)
    phi(l,2) = 0.0
 20     sum = sum + (yp(l)/wt(l))**2
  sum = sqrt(sum)
  absh = abs(h)
  if(eps < 16.0*sum*h*h) absh = 0.25*sqrt(eps/sum)
  h = sign(max ( absh,fouru*abs(x)),h)
  hold = 0.0
  k = 1
  kold = 0
  start = .false.
  phase1 = .true.
  nornd = .true.
  if(p5eps > 100.0*round) go to 99
  nornd = .false.
  do 25 l = 1,neqn
 25     phi(l,15) = 0.0
 99   ifail = 0
!
!       ***     end block 0     ***
!
!       ***     begin block 1     ***
!
!   compute coefficients of formulas for this step.  avoid computing
!   those quantities not changed when step size is not changed.
!
!                   ***
!
 100  kp1 = k+1
  kp2 = k+2
  km1 = k-1
  km2 = k-2
!
!   ns is the number of steps taken with size h, including the current
!   one.  when k < ns, no coefficients change
!
  if(h /= hold) ns = 0
  if (ns <= kold) ns = ns+1
  nsp1 = ns+1
  if (k < ns) go to 199
!
!   compute those components of alpha(*),beta(*),psi(*),sig(*) which
!   are changed
!
  beta(ns) = 1.0
  realns = ns
  alpha(ns) = 1.0/realns
  temp1 = h*realns
  sig(nsp1) = 1.0
  if(k < nsp1) go to 110
  do 105 i = nsp1,k
    im1 = i-1
    temp2 = psi(im1)
    psi(im1) = temp1
    beta(i) = beta(im1)*psi(im1)/temp2
    temp1 = temp2 + h
    alpha(i) = h/temp1
    reali = i
 105    sig(i+1) = reali*alpha(i)*sig(i)
 110  psi(k) = temp1
!
!   compute coefficients g(*)
!
!   initialize v(*) and set w(*).
!
  if(ns > 1) go to 120
  do 115 iq = 1,k
    temp3 = iq*(iq+1)
    v(iq) = 1.0/temp3
 115    w(iq) = v(iq)
  go to 140
!
!   if order was raised, update diagonal part of v(*)
!
 120  if(k <= kold) go to 130
  temp4 = k*kp1
  v(k) = 1.0/temp4
  nsm2 = ns-2
  if(nsm2 < 1) go to 130
  do 125 j = 1,nsm2
    i = k-j
 125    v(i) = v(i) - alpha(j+1)*v(i+1)
!
!   update v(*) and set w(*)
!
 130  limit1 = kp1 - ns
  temp5 = alpha(ns)
  do 135 iq = 1,limit1
    v(iq) = v(iq) - temp5*v(iq+1)
 135    w(iq) = v(iq)
  g(nsp1) = w(1)
!
!   compute the g(*) in the work vector w(*)
!
 140  nsp2 = ns + 2
  if(kp1 < nsp2) go to 199
  do 150 i = nsp2,kp1
    limit2 = kp2 - i
    temp6 = alpha(i-1)
    do 145 iq = 1,limit2
 145      w(iq) = w(iq) - temp6*w(iq+1)
 150    g(i) = w(1)
 199    continue
!
!       ***     end block 1     ***
!
!       ***     begin block 2     ***
!
!   predict a solution p(*), evaluate derivatives using predicted
!   solution, estimate local error at order k and errors at orders k,
!   k-1, k-2 as if constant step size were used.
!
!                   ***
!
!   change phi to phi star
!
  if(k < nsp1) go to 215
  do 210 i = nsp1,k
    temp1 = beta(i)
    do 205 l = 1,neqn
 205      phi(l,i) = temp1*phi(l,i)
 210    continue
!
!   predict solution and differences
!
 215  do 220 l = 1,neqn
    phi(l,kp2) = phi(l,kp1)
    phi(l,kp1) = 0.0
 220    p(l) = 0.0
  do 230 j = 1,k
    i = kp1 - j
    ip1 = i+1
    temp2 = g(i)
    do 225 l = 1,neqn
      p(l) = p(l) + temp2*phi(l,i)
 225      phi(l,i) = phi(l,i) + phi(l,ip1)
 230    continue
  if(nornd) go to 240
  do 235 l = 1,neqn
    tau = h*p(l) - phi(l,15)
    p(l) = y(l) + tau
 235    phi(l,16) = (p(l) - y(l)) - tau
  go to 250
 240  do 245 l = 1,neqn
 245    p(l) = y(l) + h*p(l)
 250  xold = x
  x = x + h
  absh = abs(h)
  call f(x,p,yp)
!
!   estimate errors at orders k,k-1,k-2
!
  erkm2 = 0.0
  erkm1 = 0.0
  erk = 0.0
  do 265 l = 1,neqn
    temp3 = 1.0/wt(l)
    temp4 = yp(l) - phi(l,1)
    if(km2)265,260,255
 255    erkm2 = erkm2 + ((phi(l,km1)+temp4)*temp3)**2
 260    erkm1 = erkm1 + ((phi(l,k)+temp4)*temp3)**2
 265    erk = erk + (temp4*temp3)**2
  if(km2)280,275,270
 270  erkm2 = absh*sig(km1)*gstr(km2)*sqrt(erkm2)
 275  erkm1 = absh*sig(k)*gstr(km1)*sqrt(erkm1)
 280  temp5 = absh*sqrt(erk)
  err = temp5*(g(k)-g(kp1))
  erk = temp5*sig(kp1)*gstr(k)
  knew = k
!
!   test if order should be lowered
!
  if(km2)299,290,285
 285  if(max ( erkm1,erkm2) <= erk) knew = km1
  go to 299
 290  if(erkm1 <= 0.5*erk) knew = km1
!
!   test if step successful
!
 299  if(err <= eps) go to 400
!
!       ***     end block 2     ***
!
!       ***     begin block 3     ***
!
!   the step is unsuccessful.  restore  x, phi(*,*), psi(*) .
!   if third consecutive failure, set order to one.  if step fails more
!   than three times, consider an optimal step size.  double error
!   tolerance and return if estimated step size is too small for machine
!   precision.
!                   ***
!
!   restore x, phi(*,*) and psi(*)
!
  phase1 = .false.
  x = xold
  do 310 i = 1,k
    temp1 = 1.0/beta(i)
    ip1 = i+1
    do 305 l = 1,neqn
 305      phi(l,i) = temp1*(phi(l,i) - phi(l,ip1))
 310    continue
  if(k < 2) go to 320
  do 315 i = 2,k
 315    psi(i-1) = psi(i) - h
!
!   on third failure, set order to one.  thereafter, use optimal step
!   size
!
 320  ifail = ifail + 1
  temp2 = 0.5
  if(ifail - 3) 335,330,325
 325  if(p5eps < 0.25*erk) temp2 = sqrt(p5eps/erk)
 330  knew = 1
 335  h = temp2*h
  k = knew
  if(abs(h) >= fouru*abs(x)) go to 340
  crash = .true.
  h = sign(fouru*abs(x),h)
  eps = eps + eps
  return
 340  go to 100
!
!       ***     end block 3     ***
!
!       ***     begin block 4     ***
!
!   the step is successful.  correct the predicted solution, evaluate
!   the derivatives using the corrected solution and update the
!   differences.  determine best order and step size for next step.
!
!                   ***
 400  kold = k
  hold = h
!
!   correct and evaluate
!
  temp1 = h*g(kp1)
  if(nornd) go to 410
  do 405 l = 1,neqn
    rho = temp1*(yp(l) - phi(l,1)) - phi(l,16)
    y(l) = p(l) + rho
 405    phi(l,15) = (y(l) - p(l)) - rho
  go to 420
 410  do 415 l = 1,neqn
 415    y(l) = p(l) + temp1*(yp(l) - phi(l,1))
 420  call f(x,y,yp)
!
!   update differences for next step
!
  do 425 l = 1,neqn
    phi(l,kp1) = yp(l) - phi(l,1)
 425    phi(l,kp2) = phi(l,kp1) - phi(l,kp2)
  do 435 i = 1,k
    do 430 l = 1,neqn
 430      phi(l,i) = phi(l,i) + phi(l,kp1)
 435    continue
!
!   estimate error at order k+1 unless...
!     in first phase when always raise order,
!     already decided to lower order,
!     step size not constant so estimate unreliable
!
  erkp1 = 0.0
  if(knew == km1  .or.  k == 12) phase1 = .false.
  if(phase1) go to 450
  if(knew == km1) go to 455
  if(kp1 > ns) go to 460
  do 440 l = 1,neqn
 440    erkp1 = erkp1 + (phi(l,kp2)/wt(l))**2
  erkp1 = absh*gstr(kp1)*sqrt(erkp1)
!
!   using estimated error at order k+1, determine appropriate order
!   for next step
!
  if(k > 1) go to 445
  if(erkp1 >= 0.5*erk) go to 460
  go to 450
 445  if(erkm1 <= amin1(erk,erkp1)) go to 455
  if(erkp1 >= erk  .or.  k == 12) go to 460
!
!   here erkp1 < erk  <  max ( erkm1,erkm2) else order would have
!   been lowered in block 2.  thus order is to be raised
!
!   raise order
!
 450  k = kp1
  erk = erkp1
  go to 460
!
!   lower order
!
 455  k = km1
  erk = erkm1
!
!   with new order determine appropriate step size for next step
!
 460  hnew = h + h
  if(phase1) go to 465
  if(p5eps >= erk*two(k+1)) go to 465
  hnew = h
  if(p5eps >= erk) go to 465
  temp2 = k+1
  r = (p5eps/erk)**(1.0/temp2)
  hnew = absh*max ( 0.5,amin1(0.9,r))
  hnew = sign(max ( hnew,fouru*abs(x)),h)
 465  h = hnew
  return
!
!       ***     end block 4     ***
!
end
subroutine stfode (f,neq,y,t,tout,info,rtol,atol,idid, &
                     rwork,lrw,iwork,liw,rpar,ipar,jac)
!
!*******************************************************************************
!
!! STFODE solves stiff ode's.
!
!
!***purpose
!   stfode solves initial value problems in ordinary differential
!   equations using backward differentiation formulas. it is
!   both variable order (1-5) and variable step.
!***description
!
!   this is a modification by a. h. morris (nswc) of the code
!   debdf, designed by  l. f. shampine and h. a. watts (1980).
!   debdf is documented in
!        sand79-2374 , depac - design of a user oriented package
!                              of ode solvers.
!
!   stfode is a driver for a modification of the code lsode written by
!             a. c. hindmarsh
!             lawrence livermore laboratory
!             livermore, california 94550
!
!
!** abstract **
!
!
!   subroutine stfode uses the backward differentiation formulas of
!   orders one through five to integrate a system of neq first order
!   ordinary differential equations of the form
!                         du/dx = f(x,u)
!   when the vector y(*) of initial values for u(*) at x=t is given.
!   the subroutine integrates from t to tout. it is easy to continue the
!   integration to get results at additional tout. this is the interval
!   mode of operation. it is also easy for the routine to return with
!   the solution at each intermediate step on the way to tout. this is
!   the intermediate-output mode of operation.
!
!
!
!** description of the arguments to stfode (an overview) **
!
!
!   the parameters are
!
!      f -- this is the name of a subroutine which you provide to
!             define the differential equations.
!
!      neq -- this is the number of (first order) differential
!             equations to be integrated.
!
!      t -- this is a value of the independent variable.
!
!      y(*) -- this array contains the solution components at t.
!
!      tout -- this is a point at which a solution is desired.
!
!      info(*) -- the basic task of the code is to integrate the
!             differential equations from t to tout and return an
!             answer at tout. info(*) is an integer array which is used
!             to communicate exactly how you want this task to be
!             carried out.
!
!      rtol, atol -- these quantities represent relative and absolute
!             error tolerances which you provide to indicate how
!             accurately you wish the solution to be computed. you may
!             choose them to be both scalars or else both vectors.
!
!      idid -- this scalar quantity is an indicator reporting what
!             the code did. you must monitor this integer variable to
!             decide what action to take next.
!
!      rwork(*), lrw -- rwork(*) is a real work array of length lrw
!             which provides the code with needed storage space.
!
!      iwork(*), liw -- iwork(*) is an integer work array of length liw
!             which provides the code with needed storage space.
!
!      rpar, ipar -- these are real and integer parameter arrays which
!             you can use for communication between your calling
!             program and the f subroutine (and the jac subroutine).
!
!      jac -- this is the name of a subroutine which you may choose to
!             provide for defining the jacobian matrix of partial
!             derivatives df/du.
!
!  quantities which are used as input items are
!             neq, t, y(*), tout, info(*),
!             rtol, atol, rwork(1), lrw,
!             iwork(1), iwork(2), and liw.
!
!  quantities which may be altered by the code are
!             t, y(*), info(1), rtol, atol,
!             idid, rwork(*) and iwork(*).
!
!
!** input -- what to do on the first call to stfode **
!
!
!   the first call of the code is defined to be the start of each new
!   problem. read through the descriptions of all the following items,
!   provide sufficient storage space for designated arrays, set
!   appropriate variables for the initialization of the problem, and
!   give information about how you want the problem to be solved.
!
!
!      f -- provide a subroutine of the form
!                               f(x,u,uprime,rpar,ipar)
!             to define the system of first order differential equations
!             which is to be solved. for the given values of x and the
!             vector  u(*)=(u(1),u(2),...,u(neq)) , the subroutine must
!             evaluate the neq components of the system of differential
!             equations  du/dx=f(x,u)  and store the derivatives in the
!             array uprime(*), that is,  uprime(i) = * du(i)/dx *  for
!             equations i=1,...,neq.
!
!             subroutine f must not alter x or u(*). you must declare
!             the name f in an external statement in your program that
!             calls stfode. you must dimension u and uprime in f.
!
!             rpar and ipar are real and integer parameter arrays which
!             you can use for communication between your calling program
!             and subroutine f. they are not used or altered by stfode.
!             if you do not need rpar or ipar, ignore these parameters
!             by treating them as dummy arguments. if you do choose to
!             use them, dimension them in your calling program and in f
!             as arrays of appropriate length.
!
!      neq -- set it to the number of differential equations.
!             (neq >= 1)
!
!      t -- set it to the initial point of the integration.
!             you must use a program variable for t because the code
!             changes its value.
!
!      y(*) -- set this vector to the initial values of the neq solution
!             components at the initial point. you must dimension y at
!             least neq in your calling program.
!
!      tout -- set it to the first point at which a solution
!             is desired. you can take tout = t, in which case the code
!             will evaluate the derivative of the solution at t and
!             return. integration either forward in t  (tout > t)  or
!             backward in t  (tout < t)  is permitted.
!
!             the code advances the solution from t to tout using
!             step sizes which are automatically selected so as to
!             achieve the desired accuracy. if you wish, the code will
!             return with the solution and its derivative following
!             each intermediate step (intermediate-output mode) so that
!             you can monitor them, but you still must provide tout in
!             accord with the basic aim of the code.
!
!             the first step taken by the code is a critical one
!             because it must reflect how fast the solution changes near
!             the initial point. the code automatically selects an
!             initial step size which is practically always suitable for
!             the problem. by using the fact that the code will not step
!             past tout in the first step, you could, if necessary,
!             restrict the length of the initial step size.
!
!             for some problems it may not be permissible to integrate
!             past a point tstop because a discontinuity occurs there
!             or the solution or its derivative is not defined beyond
!             tstop. when you have declared a tstop point (see info(4)
!             and rwork(1)), you have told the code not to integrate
!             past tstop. in this case any tout beyond tstop is invalid
!             input.
!
!      info(*) -- use the info array to give the code more details about
!             how you want your problem solved. this array should be
!             dimensioned of length 15 to accomodate other members of
!             depac or possible future extensions, though stfode uses
!             only the first six entries. you must respond to all of
!             the following items which are arranged as questions. the
!             simplest use of the code corresponds to answering all
!             questions as yes ,i.e. setting all entries of info to 0.
!
!        info(1) -- this parameter enables the code to initialize
!               itself. you must set it to indicate the start of every
!               new problem.
!
!            **** is this the first call for this problem ...
!                  yes -- set info(1) = 0
!                   no -- not applicable here.
!                         see below for continuation calls.  ****
!
!        info(2) -- how much accuracy you want of your solution
!               is specified by the error tolerances rtol and atol.
!               the simplest use is to take them both to be scalars.
!               to obtain more flexibility, they can both be vectors.
!               the code must be told your choice.
!
!            **** are both error tolerances rtol, atol scalars ...
!                  yes -- set info(2) = 0
!                         and input scalars for both rtol and atol
!                   no -- set info(2) = 1
!                         and input arrays for both rtol and atol ****
!
!        info(3) -- the code integrates from t in the direction
!               of tout by steps. if you wish, it will return the
!               computed solution and derivative at the next
!               intermediate step (the intermediate-output mode) or
!               tout, whichever comes first. this is a good way to
!               proceed if you want to see the behavior of the solution.
!               if you must have solutions at a great many specific
!               tout points, this code will compute them efficiently.
!
!            **** do you want the solution only at
!                 tout (and not at the next intermediate step) ...
!                  yes -- set info(3) = 0
!                   no -- set info(3) = 1 ****
!
!        info(4) -- to handle solutions at a great many specific
!               values tout efficiently, this code may integrate past
!               tout and interpolate to obtain the result at tout.
!               sometimes it is not possible to integrate beyond some
!               point tstop because the equation changes there or it is
!               not defined past tstop. then you must tell the code
!               not to go past.
!
!            **** can the integration be carried out without any
!                 restrictions on the independent variable t ...
!                  yes -- set info(4)=0
!                   no -- set info(4)=1
!                         and define the stopping point tstop by
!                         setting rwork(1)=tstop ****
!
!        info(5) -- to solve stiff problems it is necessary to use the
!               jacobian matrix of partial derivatives of the system
!               of differential equations. if you do not provide a
!               subroutine to evaluate it analytically (see the
!               description of the item jac in the call list), it will
!               be approximated by numerical differencing in this code.
!               although it is less trouble for you to have the code
!               compute partial derivatives by numerical differencing,
!               the solution will be more reliable if you provide the
!               derivatives via jac. sometimes numerical differencing
!               is cheaper than evaluating derivatives in jac and
!               sometimes it is not - this depends on your problem.
!
!               if your problem is linear, i.e. has the form
!               du/dx = f(x,u) = j(x)*u + g(x)   for some matrix j(x)
!               and vector g(x), the jacobian matrix  df/du = j(x).
!               since you must provide a subroutine to evaluate f(x,u)
!               analytically, it is little extra trouble to provide
!               subroutine jac for evaluating j(x) analytically.
!               furthermore, in such cases, numerical differencing is
!               much more expensive than analytic evaluation.
!
!            **** do you want the code to evaluate the partial
!                 derivatives automatically by numerical differences ...
!                  yes -- set info(5)=0
!                   no -- set info(5)=1
!                         and provide subroutine jac for evaluating the
!                         jacobian matrix ****
!
!        info(6) -- stfode will perform much better if the jacobian
!               matrix is banded and the code is told this. in this
!               case, the storage needed will be greatly reduced,
!               numerical differencing will be performed more cheaply,
!               and a number of important algorithms will execute much
!               faster. the differential equation is said to have
!               half-bandwidths ml (lower) and mu (upper) if equation i
!               involves only unknowns y(j) with
!                              i-ml <= j <= i+mu
!               for all i=1,2,...,neq. thus, ml and mu are the widths
!               of the lower and upper parts of the band, respectively,
!               with the main diagonal being excluded. if you do not
!               indicate that the equation has a banded jacobian,
!               the code works with a full matrix of neq**2 elements
!               (stored in the conventional way). computations with
!               banded matrices cost less time and storage than with
!               full matrices if  2*ml+mu < neq.  if you tell the
!               code that the jacobian matrix has a banded structure and
!               you want to provide subroutine jac to compute the
!               partial derivatives, then you must be careful to store
!               the elements of the jacobian matrix in the special form
!               indicated in the description of jac.
!
!            **** do you want to solve the problem using a full
!                 (dense) jacobian matrix (and not a special banded
!                 structure) ...
!                  yes -- set info(6)=0
!                   no -- set info(6)=1
!                         and provide the lower (ml) and upper (mu)
!                         bandwidths by setting
!                         iwork(1)=ml
!                         iwork(2)=mu ****
!
!      rtol, atol -- you must assign relative (rtol) and absolute (atol)
!             error tolerances to tell the code how accurately you want
!             the solution to be computed. they must be defined as
!             program variables because the code may change them. you
!             have two choices --
!                  both rtol and atol are scalars. (info(2)=0)
!                  both rtol and atol are vectors. (info(2)=1)
!             in either case all components must be non-negative.
!
!             the tolerances are used by the code in a local error test
!             at each step which requires roughly that
!                     abs(local error) <= rtol*abs(y)+atol
!             for each vector component.
!             (more specifically, a root-mean-square norm is used to
!             measure the size of vectors, and the error test uses the
!             magnitude of the solution at the beginning of the step.)
!
!             the true (global) error is the difference between the true
!             solution of the initial value problem and the computed
!             approximation. practically all present day codes,
!             including this one, control the local error at each step
!             and do not even attempt to control the global error
!             directly. roughly speaking, they produce a solution y(t)
!             which satisfies the differential equations with a
!             residual r(t),    dy(t)/dt = f(t,y(t)) + r(t)   ,
!             and, almost always, r(t) is bounded by the error
!             tolerances. usually, but not always, the true accuracy of
!             the computed y is comparable to the error tolerances. this
!             code will usually, but not always, deliver a more accurate
!             solution if you reduce the tolerances and integrate again.
!             by comparing two such solutions you can get a fairly
!             reliable idea of the true error in the solution at the
!             bigger tolerances.
!
!             setting atol=0. results in a pure relative error test on
!             that component. setting rtol=0. results in a pure absolute
!             error test on that component. a mixed test with non-zero
!             rtol and atol corresponds roughly to a relative error
!             test when the solution component is much bigger than atol
!             and to an absolute error test when the solution component
!             is smaller than the threshold atol.
!
!             proper selection of the absolute error control parameters
!             atol  requires you to have some idea of the scale of the
!             solution components. to acquire this information may mean
!             that you will have to solve the problem more than once. in
!             the absence of scale information, you should ask for some
!             relative accuracy in all the components (by setting  rtol
!             values non-zero) and perhaps impose extremely small
!             absolute error tolerances to protect against the danger of
!             a solution component becoming zero.
!
!             the code will not attempt to compute a solution at an
!             accuracy unreasonable for the machine being used. it will
!             advise you if you ask for too much accuracy and inform
!             you as to the maximum accuracy it believes possible.
!
!      rwork(*) -- dimension this real work array of length lrw in your
!             calling program.
!
!      rwork(1) -- if you have set info(4)=0, you can ignore this
!             optional input parameter. otherwise you must define a
!             stopping point tstop by setting   rwork(1) = tstop.
!             (for some problems it may not be permissible to integrate
!             past a point tstop because a discontinuity occurs there
!             or the solution or its derivative is not defined beyond
!             tstop.)
!
!      lrw -- set it to the declared length of the rwork array.
!             you must have
!                  lrw >= 250+10*neq+neq**2
!             for the full (dense) jacobian case (when info(6)=0),  or
!                  lrw >= 250+10*neq+(2*ml+mu+1)*neq
!             for the banded jacobian case (when info(6)=1).
!
!      iwork(*) -- dimension this integer work array of length liw in
!             your calling program.
!
!      iwork(1), iwork(2) -- if you have set info(6)=0, you can ignore
!             these optional input parameters. otherwise you must define
!             the half-bandwidths ml (lower) and mu (upper) of the
!             jacobian matrix by setting    iwork(1) = ml   and
!             iwork(2) = mu.  (the code will work with a full matrix
!             of neq**2 elements unless it is told that the problem has
!             a banded jacobian, in which case the code will work with
!             a matrix containing at most  (2*ml+mu+1)*neq  elements.)
!
!      liw -- set it to the declared length of the iwork array.
!             you must have liw >= 55+neq.
!
!      rpar, ipar -- these are parameter arrays, of real and integer
!             type, respectively. you can use them for communication
!             between your program that calls stfode and the  f
!             subroutine (and the jac subroutine). they are not used or
!             altered by stfode. if you do not need rpar or ipar, ignore
!             these parameters by treating them as dummy arguments. if
!             you do choose to use them, dimension them in your calling
!             program and in f (and in jac) as arrays of appropriate
!             length.
!
!      jac -- if you have set info(5)=0, you can ignore this parameter
!             by treating it as a dummy argument. (for some compilers
!             you may have to write a dummy subroutine named  jac  in
!             order to avoid problems associated with missing external
!             routine names.)  otherwise, you must provide a subroutine
!             of the form
!                          jac(x,u,pd,nrowpd,rpar,ipar)
!             to define the jacobian matrix of partial derivatives df/du
!             of the system of differential equations   du/dx = f(x,u).
!             for the given values of x and the vector
!             u(*)=(u(1),u(2),...,u(neq)), the subroutine must evaluate
!             the non-zero partial derivatives  df(i)/du(j)  for each
!             differential equation i=1,...,neq and each solution
!             component j=1,...,neq , and store these values in the
!             matrix pd. the elements of pd are set to zero before each
!             call to jac so only non-zero elements need to be defined.
!
!             subroutine jac must not alter x, u(*), or nrowpd. you must
!             declare the name jac in an external statement in your
!             program that calls stfode. nrowpd is the row dimension of
!             the pd matrix and is assigned by the code. therefore you
!             must dimension pd in jac according to
!                              dimension pd(nrowpd,1)
!             you must also dimension u in jac.
!
!             the way you must store the elements into the pd matrix
!             depends on the structure of the jacobian which you
!             indicated by info(6).
!             *** info(6)=0 -- full (dense) jacobian ***
!                 when you evaluate the (non-zero) partial derivative
!                 of equation i with respect to variable j, you must
!                 store it in pd according to
!                                pd(i,j) = * df(i)/du(j) *
!             *** info(6)=1 -- banded jacobian with ml lower and mu
!                 upper diagonal bands (refer to info(6) description of
!                 ml and mu) ***
!                 when you evaluate the (non-zero) partial derivative
!                 of equation i with respect to variable j, you must
!                 store it in pd according to
!                                irow = i - j + ml + mu + 1
!                                pd(irow,j) = * df(i)/du(j) *
!
!             rpar and ipar are real and integer parameter arrays which
!             you can use for communication between your calling
!             program and your jacobian subroutine jac. they are not
!             altered by stfode. if you do not need rpar or ipar, ignore
!             these parameters by treating them as dummy arguments. if
!             you do choose to use them, dimension them in your calling
!             program and in jac as arrays of appropriate length.
!
!
!** output -- after any return from stfode **
!
!
!   the principal aim of the code is to return a computed solution at
!   tout, although it is also possible to obtain intermediate results
!   along the way. to find out whether the code achieved its goal
!   or if the integration process was interrupted before the task was
!   completed, you must check the idid parameter.
!
!
!      t -- the solution was successfully advanced to the
!             output value of t.
!
!      y(*) -- contains the computed solution approximation at t.
!             you may also be interested in the approximate derivative
!             of the solution at t. it is contained in
!             rwork(21),...,rwork(20+neq).
!
!      idid -- reports what the code did
!
!                         *** task completed ***
!                   reported by positive values of idid
!
!             idid = 1 -- a step was successfully taken in the
!                       intermediate-output mode. the code has not
!                       yet reached tout.
!
!             idid = 2 -- the integration to tout was successfully
!                       completed (t=tout) by stepping exactly to tout.
!
!             idid = 3 -- the integration to tout was successfully
!                       completed (t=tout) by stepping past tout.
!                       y(*) is obtained by interpolation.
!
!                         *** task interrupted ***
!                   reported by negative values of idid
!
!             idid = -1 -- a large amount of work has been expended.
!                       (500 steps performed)
!
!             idid = -2 -- the error tolerances are too stringent.
!
!             idid = -3 -- the local error test cannot be satisfied
!                       since the l-th solution component is 0 and
!                       the corresponding absolute error tolerance
!                       is 0 for l = -info(1). a pure relative error
!                       test cannot be applied to this component.
!
!             idid = -4,-5  -- not applicable for this code.
!
!             idid = -6 -- stfode had repeated convergence test failures
!                       on the last attempted step.
!
!             idid = -7 -- stfode had repeated error test failures on
!                       the last attempted step.
!
!             idid = -8,..,-32  -- not applicable for this code.
!
!                         *** task terminated ***
!                 reported by the value of idid <= -33
!
!             idid = -33  -- neq < 1
!
!             idid = -34  -- rtol(k) < 0 for some k
!
!             idid = -35  -- atol(k) < 0 for some k
!
!             idid = -36  -- the code has been called with tout but
!                       the code has also been told not to integrate
!                       past the point tstop.
!
!             idid = -37  -- the code has been called with t = tout.
!                       this is not permitted on continuation calls.
!
!             idid = -38  -- the user has modified the value of t.
!                       this is not permitted on continuation calls.
!
!             idid = -39  -- by calling the code with tout, an
!                       attempt is being made to change the direction
!                       of integration without restarting.
!
!             idid = -40  -- the jacobian matrix is banded. however
!                       the bandwidths ml and mu do not satisfy the
!                       constraints  0 <= ml,mu < neq.
!
!             idid = -41  -- lrw < 250 + 10*neq + neq*neq
!
!             idid = -42  -- lrw < 250 + 10*neq + (2*ml+mu+1)*neq
!
!             idid = -43  -- liw < 55 + neq
!
!             idid = -44  -- info(1) is incorrect.
!
!      rtol, atol -- these quantities remain unchanged except when
!             idid = -2. in this case, the error tolerances have been
!             increased by the code to values which are estimated to be
!             appropriate for continuing the integration. however, the
!             reported solution at t was obtained using the input values
!             of rtol and atol.
!
!      rwork, iwork -- contain information which is usually of no
!             interest to the user but necessary for subsequent calls.
!             however, you may find use for
!
!             rwork(11)--which contains the step size h to be
!                        attempted on the next step.
!
!             rwork(12)--if the tolerances have been increased by the
!                        code (idid = -2) , they were multiplied by the
!                        value in rwork(12).
!
!             rwork(13)--which contains the current value of the
!                        independent variable, i.e. the farthest point
!                        integration has reached. this will be different
!                        from t only when interpolation has been
!                        performed (idid=3).
!
!             rwork(20+i)--which contains the approximate derivative
!                        of the solution component y(i). in stfode it is
!                        never obtained by calling subroutine f to
!                        evaluate the differential equation using t and
!                        y(*), except at the initial point of
!                        integration.
!
!
!** input -- what to do to continue the integration **
!**             (calls after the first)             **
!
!
!        this code is organized so that subsequent calls to continue the
!        integration involve little (if any) additional effort on your
!        part. you must monitor the idid parameter in order to determine
!        what to do next.
!
!        recalling that the principal task of the code is to integrate
!        from t to tout (the interval mode), usually all you will need
!        to do is specify a new tout upon reaching the current tout.
!
!        do not alter any quantity not specifically permitted below,
!        in particular do not alter neq, t, y(*), rwork(*), iwork(*) or
!        the differential equation in subroutine f. any such alteration
!        constitutes a new problem and must be treated as such, i.e.
!        you must start afresh.
!
!        you cannot change from vector to scalar error control or vice
!        versa (info(2)) but you can change the size of the entries of
!        rtol, atol. increasing a tolerance makes the equation easier
!        to integrate. decreasing a tolerance will make the equation
!        harder to integrate and should generally be avoided.
!
!        you can switch from the intermediate-output mode to the
!        interval mode (info(3)) or vice versa at any time.
!
!        if it has been necessary to prevent the integration from going
!        past a point tstop (info(4), rwork(1)), keep in mind that the
!        code will not integrate to any tout beyond the currently
!        specified tstop. once tstop has been reached you must change
!        the value of tstop or set info(4)=0. you may change info(4)
!        or tstop at any time but you must supply the value of tstop in
!        rwork(1) whenever you set info(4)=1.
!
!        do not change info(5), info(6), iwork(1), or iwork(2)
!        unless you are going to restart the code.
!
!        the parameter info(1) is used by the code to indicate the
!        beginning of a new problem and to indicate whether integration
!        is to be continued. you must input the value  info(1) = 0
!        when starting a new problem. you must input the value
!        info(1) = 1  if you wish to continue after an interrupted task
!        for which idid = -3, -6, or -7. do not set info(1) = 0 on a
!        continuation call unless you want the code to restart at the
!        current t.
!
!                         *** following a completed task ***
!         if
!             idid = 1, call the code again to continue the integration
!                     another step in the direction of tout.
!
!             idid = 2 or 3, define a new tout and call the code again.
!                     tout must be different from t. you cannot change
!                     the direction of integration without restarting.
!
!                         *** following an interrupted task ***
!         if
!             idid = -1, the code has performed 500 steps.
!                     if you want to continue, call the code again.
!
!             idid = -2, the error tolerances rtol and atol have been
!                     increased to values the code estimates appropriate
!                     for continuing. you may want to change them
!                     yourself. if you want to continue, call the code
!                     again.
!
!             idid = -3, the l-th solution component is 0 and the
!                     corresponding absolute error tolerance is 0
!                     for l = -info(1). to continue, reset the
!                     absolute tolerance to a positive value, set
!                     info(1) = 1, and call the code again.
!
!             idid = -4,-5  --- cannot occur with this code.
!
!             idid = -6, repeated convergence test failures occurred
!                     on the last attempted step. an inaccurate
!                     jacobian may be the problem. if you are absolutely
!                     certain you want to continue, restart the
!                     integration at the current t by setting  info(1)=0
!                     and call the code again.
!
!             idid = -7, repeated error test failures occurred on the
!                     last attempted step. a singularity in the
!                     solution may be present. you should re-examine the
!                     problem being solved. if you are absolutely
!                     certain you want to continue, restart the
!                     integration at the current t by setting  info(1)=0
!                     and call the code again.
!
!             idid = -8,..,-32  --- cannot occur with this code.
!
!                         *** following a terminated task ***
!         if
!             idid <= -33, an input error has been detected. after the
!                     error is corrected, restart by setting info(1) = 0
!                     and call the code again.
!
!
!
!         ***** warning *****
!
!     if stfode is to be used in an overlay situation, you must save and
!     restore certain items used internally by stfode  (values in the
!     common block debdf1). this can be accomplished as follows.
!
!     to save the necessary values upon return from stfode, simply call
!        svco(rwork(22+neq),iwork(21+neq)).
!
!     to restore the necessary values before the next call to stfode,
!     simply call    rsco(rwork(22+neq),iwork(21+neq)).
!
!
!
!***references
!   shampine l.f., watts h.a., *depac - design of a user oriented
!   package of ode solvers*, sand79-2374, sandia laboratories, 1979.
!
!
  logical intout
!
  dimension y(neq),info( *),rtol(*),atol(*),rwork(lrw),iwork(liw), &
            rpar(*),ipar(*)
!
  common /debdf1/ told, rowns(210), &
     el0, h, hmin, hmxi, hu, tn, uround, &
     iquit, init, iyh, iewt, iacor, isavf, iwm, ksteps, &
     ibegin, itol, iinteg, itstop, ijac, iband, iowns(6), &
     ier, jstart, kflag, l, meth, miter, maxord, n, nq, nst, nfe, &
     nje, nqu
!
  external f , jac
!
  idid = 0
!
  if (info(1) == 0) go to 20
  if (info(1) /= 1) go to 10
  if (iquit == 0) go to 20
   10 idid = -44
  return
!
   20 if (info(2) /= 0) info(2) = 1
  if (info(3) /= 0) info(3) = 1
  if (info(4) /= 0) info(4) = 1
  if (info(5) /= 0) info(5) = 1
  if (info(6) /= 0) info(6) = 1
!
  ilrw = neq
  if (info(6) == 0) go to 80
!
!     check bandwidth parameters
!
  ml = iwork(1)
  mu = iwork(2)
  ilrw = 2*ml + mu + 1
  if (ml >= 0  .and.  ml < neq      .and. &
      mu >= 0  .and.  mu < neq)    go to 80
  idid = -40
  return
!
!     check lrw and liw for sufficient storage allocation
!
   80 if (lrw >= 250+(10+ilrw)*neq) go to 100
!
  if (info(6) == 1) go to 90
  idid = -41
  return
!
   90 idid = -42
  return
!
  100 if (liw >= 55+neq) go to 200
  idid = -43
  return
!
!     compute the indices for the arrays to be stored in the work array
!     and restore common block data
!
  200 icomi = 21 + neq
  iinout = icomi + 33
!
  iypout = 21
  itstar = 21 + neq
  icomr = 22 + neq
!
  if (info(1) == 0) go to 250
  intout = iwork(iinout) /= (-1)
!     call rsco(rwork(icomr),iwork(icomi))
!
  250 iyh = icomr + 218
  iewt = iyh + 6*neq
  isavf = iewt + neq
  iacor = isavf + neq
  iwm = iacor + neq
  idelsn = iwm + 2+ilrw*neq
!
  ibegin = info(1)
  itol = info(2)
  iinteg = info(3)
  itstop = info(4)
  ijac = info(5)
  iband = info(6)
  rwork(itstar) = t
!
  call lsod1(f,neq,t,y,tout,rtol,atol,idid,rwork(iypout), &
            rwork(iyh),rwork(iyh),rwork(iewt),rwork(isavf), &
            rwork(iacor),rwork(iwm),iwork(1),jac,intout, &
            rwork(1),rwork(12),rwork(idelsn),rpar,ipar)
!
  iwork(iinout) = -1
  if (intout) iwork(iinout) = 1
!
!     call svco(rwork(icomr),iwork(icomi))
  rwork(11) = h
  rwork(13) = tn
  info(1) = ibegin
!
  return
end
subroutine stlsq(m,n,ta,ita,jta,damp,u,x,atol,btol,conlim, &
                   itnlim,istop,itn,acond,rnorm,xnorm,w)
!
!*******************************************************************************
!
!! STLSQ finds a solution x to a variety of systems of linear equations.
!
!     1. unsymmetric equations --    solve  a*x = b
!
!     2. linear least squares  --    solve  a*x = b
!                                    in the least-squares sense
!
!     3. damped least squares  --    solve  (   a    )*x = ( b )
!                                           ( damp*i )     ( 0 )
!                                    in the least-squares sense
!
!     where a is a matrix with m rows and n columns, b an m-vector,
!     and damp a scalar. (all quantities are real.) the matrix a is
!     a sparse matrix whose transpose is stored rowwise in the arrays
!     ta,ita,jta.
!
!     the rhs vector b is input via u, and is subsequently overwritten.
!
!
!     note. stlsq uses an iterative method to approximate the solution.
!     the number of iterations required to reach a certain accuracy
!     depends strongly on the scaling of the problem. poor scaling of
!     the rows or columns of a should therefore be avoided whenever
!     possible.
!
!     for example, in problem 1 the solution is unaltered by
!     row-scaling.  if a row of a is very small or large compared to
!     the other rows of a, the corresponding row of (a  b) should be
!     scaled up or down.
!
!     in problems 1 and 2, the solution x is easily recovered
!     following column scaling. in the absence of better information,
!     the nonzero columns of a should be scaled so that they all have
!     the same euclidean norm (e.g.  1.0).
!
!     in problem 3, there is no freedom to re-scale if damp is
!     nonzero. however, the value of damp should be assigned only
!     after attention has been paid to the scaling of a.
!
!     the parameter damp is intended to help regularize
!     ill-conditioned systems, by preventing the true solution from
!     being very large. another aid to regularization is provided by
!     the parameter acond, which may be used to terminate iterations
!     before the computed solution becomes very large.
!
!
!     notation
!
!
!     the following quantities are used in discussing the subroutine
!     parameters...
!
!     abar   =  (   a    ),          bbar  =  ( b )
!               ( damp*i )                    ( 0 )
!
!     r      =  b  -  a*x,           rbar  =  bbar  -  abar*x
!
!     rnorm  =  sqrt( norm(r)**2  +  damp**2 * norm(x)**2 )
!            =  norm( rbar )
!
!     relpr  =  the smallest floating point number for which
!               1 + relpr > 1.
!
!     stlsq  minimizes the function rnorm with respect to x.
!
!
!     parameters
!
!
!     m       input      the number of rows in a.
!
!     n       input      the number of columns in a.
!
!     ta,ita  input      the transpose of the matrix a is stored
!      jta               rowwise in sparse form.
!
!     damp    input      the damping parameter for problem 3 above.
!                        (damp  should be 0.0 for problems 1 and 2.)
!                        if the system  a*x = b  is incompatible, values
!                        of damp in the range 0 to sqrt(relpr)*norm(a)
!                        will probably have a negligible effect.
!                        larger values of damp will tend to decrease
!                        the norm of x and to reduce the number of
!                        iterations required by stlsq.
!
!                        the work per iteration and the storage needed
!                        by stlsq are the same for all values of damp.
!
!     u(m)    input      the rhs vector b. be aware that u is
!                        over-written by stlsq.
!
!     x(n)    output     returns the computed solution x.
!
!     atol    input      an estimate of the relative error in the data
!                        defining the matrix a. for example,
!                        if a is accurate to about 6 digits, set
!                        atol = 1.0e-6 .
!
!     btol    input      an estimate of the relative error in the data
!                        defining the rhs vector b. for example,
!                        if b is accurate to about 6 digits, set
!                        btol = 1.0e-6 .
!
!     conlim  input      an upper limit on cond(abar), the apparent
!                        condition number of the matrix abar.
!                        iterations will be terminated if a computed
!                        estimate of cond(abar) exceeds conlim.
!                        this is intended to prevent certain small or
!                        zero singular values of a or abar from
!                        coming into effect and causing unwanted growth
!                        in the computed solution.
!
!                        conlim and damp may be used separately or
!                        together to regularize ill-conditioned systems.
!
!                        normally, conlim should be in the range
!                        1000  to  1/relpr.
!                        suggested value --
!                        conlim = 1/(100*relpr)  for compatible systems,
!                        conlim = 1/(10*sqrt(relpr))  for least squares.
!
!             note. if the user is not concerned about the parameters
!             atol, btol, and conlim, any or all of them may be set
!             to zero. the effect will be the same as the values
!             relpr, relpr, and  1/relpr  respectively.
!
!     itnlim  input      an upper limit on the number of iterations.
!                        suggested value --
!                        itnlim = n/2     for well conditioned systems,
!                        itnlim = 4*n     otherwise.
!
!     istop   output     an integer giving the reason for termination...
!
!                0       x = 0  is the exact solution.
!                        no iterations were performed.
!
!                1       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is sufficiently
!                        small, given the values of atol and btol.
!
!                2       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is sufficiently accurate,
!                        given the value of atol.
!
!                3       an estimate of cond(abar) has exceeded
!                        conlim. the system  a*x = b  appears to be
!                        ill-conditioned.
!
!                4       the equations  a*x = b  are probably
!                        compatible. norm(a*x - b) is as small as
!                        seems reasonable on this machine.
!
!                5       the system  a*x = b  is probably not
!                        compatible. a least-squares solution has
!                        been obtained which is as accurate as seems
!                        reasonable on this machine.
!
!                6       cond(abar) seems to be so large that there is
!                        not much point in doing further iterations,
!                        given the precision of this machine.
!
!                7       the iteration limit itnlim was reached.
!
!
!     itn     output     the number of iterations that were performed.
!
!     acond   output     an estimate of cond(abar), the condition
!                        number of abar.
!
!     rnorm   output     an estimate of the final value of norm(rbar),
!                        the function being minimized (see notation
!                        above). this will be small if  a*x = b  has
!                        a solution.
!
!     xnorm   output     an estimate of the norm of the final
!                        solution vector x.
!
!     w(2*n)             workspace
!
!     anorm   local      an estimate of the frobenius norm of abar.
!                        this is the square root of the sum of squares
!                        of the elements of abar.
!                        if damp is small and if the columns of a
!                        have all been scaled to have length  1.0,
!                        anorm should increase to roughly sqrt(n).
!
!     arnorm  local      an estimate of the final value of
!                        norm( abar(transpose)*rbar ), the norm of
!                        the residual for the usual normal equations.
!                        this should be small in all cases. (arnorm
!                        will often be smaller than the true value
!                        computed from the output vector x.)
!
!
!     subroutines and functions used
!
!
!                normlz,mvprd1,mtprd1
!     blas       scopy,snrm2,sscal  (see lawson et al. below)
!                (snrm2 is used only in normlz)
!     fortran    abs,sqrt
!
!
!     references
!
!
!     paige, c.c. and saunders, m.a.  lsqr, an algorithm for sparse
!        linear equations and sparse least squares.
!        acm transactions on mathematical software 8, 1 (march 1982).
!
!     lawson, c.l., hanson, r.j., kincaid, d.r. and krogh, f.t.
!        basic linear algebra subprograms for fortran usage.
!        acm transactions on mathematical software 5, 3 (sept 1979),
!        308-323 and 324-325.
!
  integer m,n,itnlim,istop
  integer ita(*),jta(*)
  real    ta(*),damp,u(m),x(n),atol,btol,conlim, &
          acond,rnorm,xnorm,w(*)
!
!
!     local variables
!
  integer    i,itn,nconv,nstop
  real       alfa,anorm,arnorm,bbnorm,beta,bnorm, &
             cs,cs1,cs2,ctol,dampsq,ddnorm,delta, &
             gamma,gambar,one,phi,phibar,psi, &
             res1,res2,rho,rhobar,rhbar1,rhbar2,rhs,rtol, &
             sn,sn1,sn2,t,tau,test1,test2,test3, &
             theta,t1,t2,t3,xxnorm,z,zbar,zero
!
!
!     initialize.
!
  zero   = 0.0
  one    = 1.0
  ctol   = zero
  if (conlim > zero) ctol = one/conlim
  dampsq = damp**2
  anorm  = zero
  acond  = zero
  bbnorm = zero
  ddnorm = zero
  res2   = zero
  xnorm  = zero
  xxnorm = zero
  cs2    = -one
  sn2    = zero
  z      = zero
  itn    = 0
  istop  = 0
  nstop  = 0
!
  do 10 i = 1, n
     w(i) = zero
     x(i) = zero
   10 continue
!
!     set up the first vectors for the bidiagonalization.
!     these satisfy   beta*u = b,   alfa*w = a(transpose)*u.
!
  call normlz(m,u,beta)
  call mvprd1(n,m,ta,ita,jta,u,w)
  call normlz(n,w,alfa)
  call scopy (n,w,1,w(n+1),1)
!
  rhobar = alfa
  phibar = beta
  bnorm  = beta
  rnorm  = beta
  arnorm = alfa*beta
  if (arnorm <= zero) go to 800
!
!
!     main iteration loop.
!
  100 itn = itn + 1
!
!     perform the next step of the bidiagonalization to obtain the
!     next  beta, u, alfa, w.  these satisfy the relations
!                beta*u  =  a*w  -  alfa*u,
!                alfa*w  =  a(transpose)*u  -  beta*w.
!
  call sscal (m,(-alfa),u,1)
  call mtprd1(n,m,ta,ita,jta,w,u)
  call normlz(m,u,beta)
  bbnorm = bbnorm + alfa**2 + beta**2 + dampsq
  call sscal (n,(-beta),w,1)
  call mvprd1(n,m,ta,ita,jta,u,w)
  call normlz(n,w,alfa)
!
!
!     use a plane rotation to eliminate the damping parameter.
!     this alters the diagonal (rhobar) of the lower-bidiagonal matrix.
!
  rhbar2 = rhobar**2 + dampsq
  rhbar1 = sqrt(rhbar2)
  cs1    = rhobar/rhbar1
  sn1    = damp/rhbar1
  psi    = sn1*phibar
  phibar = cs1*phibar
!
!
!     use a plane rotation to eliminate the subdiagonal element (beta)
!     of the lower-bidiagonal matrix, giving an upper-bidiagonal matrix.
!
  rho    = sqrt(rhbar2 + beta**2)
  cs     = rhbar1/rho
  sn     = beta/rho
  theta  =  sn*alfa
  rhobar = -cs*alfa
  phi    =  cs*phibar
  phibar =  sn*phibar
  tau    =  sn*phi
!
!
!     update x and w(n+1),...,w(2*n)
!
  t1 =    phi/rho
  t2 = -theta/rho
  t3 =    one/rho
!
  do 200 i = 1, n
     npi   = n + i
     t     = w(npi)
     x(i)  = t1*t + x(i)
     w(npi)= t2*t + w(i)
     t     =(t3*t)**2
     ddnorm= t + ddnorm
  200 continue
!
!
!     use a plane rotation on the right to eliminate the
!     super-diagonal element (theta) of the upper-bidiagonal matrix.
!     then use the result to estimate norm(x).
!
  delta  =  sn2*rho
  gambar = -cs2*rho
  rhs    = phi - delta*z
  zbar   = rhs/gambar
  xnorm  = sqrt(xxnorm + zbar**2)
  gamma  = sqrt(gambar**2 + theta**2)
  cs2    = gambar/gamma
  sn2    = theta/gamma
  z      = rhs/gamma
  xxnorm = xxnorm + z**2
!
!
!     test for convergence.
!     first, estimate the norm and condition of the matrix abar,
!     and the norms of rbar and abar(transpose)*rbar.
!
  anorm  = sqrt(bbnorm)
  acond  = anorm*sqrt(ddnorm)
  res1   = phibar**2
  res2   = res2 + psi**2
  rnorm  = sqrt(res1 + res2)
  arnorm = alfa*abs(tau)
!
!     now use these norms to estimate certain other quantities,
!     some of which will be small near a solution.
!
  test1  = rnorm/bnorm
  test2  = arnorm/(anorm*rnorm)
  test3  = one/acond
  t1     = test1/(one + anorm*xnorm/bnorm)
  rtol   = btol +  atol*anorm*xnorm/bnorm
!
!     the following tests guard against extremely small values of
!     atol, btol, or ctol.  (the user may have set any or all of
!     the parameters atol, btol, conlim to zero.)
!     the effect is equivalent to the normal tests using
!     atol = relpr,  btol = relpr,  conlim = 1/relpr.
!
  t3 = one + test3
  t2 = one + test2
  t1 = one + t1
  if (itn >= itnlim) istop = 7
  if (t3  <= one   ) istop = 6
  if (t2  <= one   ) istop = 5
  if (t1  <= one   ) istop = 4
!
!     allow for tolerances set by the user.
!
  if (test3 <= ctol) istop = 3
  if (test2 <= atol) istop = 2
  if (test1 <= rtol) istop = 1
!
!     stop if appropriate.
!     the convergence criteria are required to be met on  nconv
!     consecutive iterations, where  nconv  is set below.
!     suggested value --   nconv = 1, 2  or  3.
!
  if (istop == 0) nstop = 0
  if (istop == 0) go to 100
  nconv = 1
  nstop = nstop + 1
  if (nstop < nconv  .and.  itn  <  itnlim) istop = 0
  if (istop == 0) go to 100
!
!     end of iteration loop.
!
!
  800 return
end
subroutine stod  (neq, y, yh, nyh, yh1, ewt, savf, acor, &
     wm, iwm, f, jac, rpar, ipar)
!
!*******************************************************************************
!
!! STOD performs one step of the integration of an initial value problem
!  for a system of ordinary differential equations.
! note.. stod  is independent of the value of the iteration method
! indicator miter, when this is /= 0, and hence is independent
! of the type of chord method used, or the jacobian structure.
! communication with stod  is done with the following variables..
!
! y      = an array of length >= n used as the y argument in
!          all calls to f and jac.
! neq    = integer array containing problem size in neq(1), and
!          passed as the neq argument in all calls to f and jac.
! yh     = an nyh by lmax array containing the dependent variables
!          and their approximate scaled derivatives, where
!          lmax = maxord + 1.  yh(i,j+1) contains the approximate
!          j-th derivative of y(i), scaled by h**j/factorial(j)
!          (j = 0,1,...,nq).  on entry for the first step, the first
!          two columns of yh must be set from the initial values.
! nyh    = a constant integer >= n, the first dimension of yh.
! yh1    = a one-dimensional array occupying the same space as yh.
! ewt    = an array of n elements with which the estimated local
!          errors in yh are compared.
! savf   = an array of working storage, of length n.
! acor   = a work array of length n, used for the accumulated
!          corrections.  on a successful return, acor(i) contains
!          the estimated one-step local error in y(i).
! wm,iwm = real and integer work arrays associated with matrix
!          operations in chord iteration (miter /= 0).
! pjac   = name of routine to evaluate and preprocess jacobian matrix
!          if a chord method is being used.
! slvs   = name of routine to solve linear system in chord iteration.
! h      = the step size to be attempted on the next step.
!          h is altered by the error control algorithm during the
!          problem.  h can be either positive or negative, but its
!          sign must remain constant throughout the problem.
! hmin   = the minimum absolute value of the step size h to be used.
! hmxi   = inverse of the maximum absolute value of h to be used.
!          hmxi = 0.0 is allowed and corresponds to an infinite hmax.
!          hmin and hmxi may be changed at any time, but will not
!          take effect until the next change of h is considered.
! tn     = the independent variable. tn is updated on each step taken.
! jstart = an integer used for input only, with the following
!          values and meanings..
!               0  perform the first step.
!            > 0  take a new step continuing from the last.
!              -1  take the next step with a new value of h, maxord,
!                    n, meth, miter, and/or matrix parameters.
!              -2  take the next step with a new value of h,
!                    but with other inputs unchanged.
!          on return, jstart is set to 1 to facilitate continuation.
! kflag  = a completion code with the following meanings..
!               0  the step was succesful.
!              -1  the requested error could not be achieved.
!              -2  corrector convergence could not be achieved.
!          a return with kflag = -1 or -2 means either
!          abs(h) = hmin or 10 consecutive failures occurred.
!          on a return with kflag negative, the values of tn and
!          the yh array are as of the beginning of the last
!          step, and h is the last step size attempted.
! maxord = the maximum order of integration method to be allowed.
! meth/miter = the method flags.  see description in driver.
! n      = the number of first-order differential equations.
!
!***routines called  cfod,slvs,pjac,vnwrms
!
  external f, jac
!
  integer neq, nyh, iwm, i, i1, ialth, ier, iownd, iredo, iret, &
     ipup, j, jb, jstart, kflag, l, lmax, m, maxord, meo, meth, &
     miter, n, ncf, newq, nfe, nje, nq, nqnyh, nqu, nst, nstepj
  real y, yh, yh1, ewt, savf, acor, wm, &
     rownd, conit, crate, el, elco, hold, rc, rmax, tesco, &
     el0, h, hmin, hmxi, hu, tn, uround, &
     dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup, &
     r, rh, rhdn, rhsm, rhup, told, vnwrms
  dimension         y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), &
     acor(*), wm(*), iwm(*), rpar(*), ipar(*)
  common /debdf1/ rownd, conit, crate, el(13), elco(13,12), &
     hold, rc, rmax, tesco(3,12), &
     el0, h, hmin, hmxi, hu, tn, uround, iownd(7), ksteps, iod(6), &
     ialth, ipup, lmax, meo, nqnyh, nstepj, &
     ier, jstart, kflag, l, meth, miter, maxord, n, nq, nst, nfe, &
     nje, nqu
!
!
  kflag = 0
  told = tn
  ncf = 0
  if (jstart > 0) go to 200
  if (jstart == -1) go to 100
  if (jstart == -2) go to 160
!
! on the first call, the order is set to 1, and other variables are
! initialized.  rmax is the maximum ratio by which h can be increased
! in a single step.  it is initially 1.e4 to compensate for the small
! initial h, but then is normally equal to 10.  if a failure
! occurs (in corrector convergence or error test), rmax is set at 2
! for the next increase.
!
  lmax = maxord + 1
  nq = 1
  l = 2
  ialth = 2
  rmax = 10000.0e0
  rc = 0.0e0
  el0 = 1.0e0
  crate = 0.7e0
  delp = 0.0e0
  hold = h
  meo = meth
  nstepj = 0
  iret = 3
  go to 140
!
! the following block handles preliminaries needed when jstart = -1.
! ipup is set to miter to force a matrix update.
! if an order increase is about to be considered (ialth = 1),
! ialth is reset to 2 to postpone consideration one more step.
! if the caller has changed meth, cfod  is called to reset
! the coefficients of the method.
! if the caller has changed maxord to a value less than the current
! order nq, nq is reduced to maxord, and a new h chosen accordingly.
! if h is to be changed, yh must be rescaled.
! if h or meth is being changed, ialth is reset to l = nq + 1
! to prevent further changes in h for that many steps.
!
 100  ipup = miter
  lmax = maxord + 1
  if (ialth == 1) ialth = 2
  if (meth == meo) go to 110
  call cfod  (meth, elco, tesco)
  meo = meth
  if (nq > maxord) go to 120
  ialth = l
  iret = 1
  go to 150
 110  if (nq <= maxord) go to 160
 120  nq = maxord
  l = lmax
  do 125 i = 1,l
 125    el(i) = elco(i,nq)
  nqnyh = nq*nyh
  rc = rc*el(1)/el0
  el0 = el(1)
  conit = 0.5e0/real(nq+2)
  ddn = vnwrms (n, savf, ewt)/tesco(1,l)
  exdn = 1.0e0/real(l)
  rhdn = 1.0e0/(1.3e0*ddn**exdn + 0.0000013e0)
  rh = amin1(rhdn,1.0e0)
  iredo = 3
  if (h == hold) go to 170
  rh = amin1(rh,abs(h/hold))
  h = hold
  go to 175
!
! cfod  is called to get all the integration coefficients for the
! current meth.  then the el vector and related constants are reset
! whenever the order nq is changed, or at the start of the problem.
!
 140  call cfod  (meth, elco, tesco)
 150  do 155 i = 1,l
 155    el(i) = elco(i,nq)
  nqnyh = nq*nyh
  rc = rc*el(1)/el0
  el0 = el(1)
  conit = 0.5e0/real(nq+2)
  go to (160, 170, 200), iret
!
! if h is being changed, the h ratio rh is checked against
! rmax, hmin, and hmxi, and the yh array rescaled.  ialth is set to
! l = nq + 1 to prevent a change of h for that many steps, unless
! forced by a convergence or error test failure.
!
 160  if (h == hold) go to 200
  rh = h/hold
  h = hold
  iredo = 3
  go to 175
 170  rh = max ( rh,hmin/abs(h))
 175  rh = amin1(rh,rmax)
  rh = rh/max ( 1.0e0,abs(h)*hmxi*rh)
  r = 1.0e0
  do 180 j = 2,l
    r = r*rh
    do 180 i = 1,n
 180      yh(i,j) = yh(i,j)*r
  h = h*rh
  rc = rc*rh
  ialth = l
  if (iredo == 0) go to 680
!
! this section computes the predicted values by effectively
! multiplying the yh array by the pascal triangle matrix.
! rc is the ratio of new to old values of the coefficient  h*el(1).
! when rc differs from 1 by more than 30 percent, ipup is set to miter
! to force pjac to be called, if a jacobian is involved.
! in any case, pjac is called at least every 20-th step.
!
 200  if (abs(rc-1.0e0) > 0.3e0) ipup = miter
  if (nst >= nstepj+20) ipup = miter
  tn = tn + h
  i1 = nqnyh + 1
  do 215 jb = 1,nq
    i1 = i1 - nyh
    do 210 i = i1,nqnyh
      ipnyh = i + nyh
 210      yh1(i) = yh1(i) + yh1(ipnyh)
 215    continue
  ksteps = ksteps + 1
!
! up to 3 corrector iterations are taken.  a convergence test is
! made on the r.m.s. norm of each correction, weighted by the error
! weight vector ewt.  the sum of the corrections is accumulated in the
! vector acor(i).  the yh array is not altered in the corrector loop.
!
 220  m = 0
  do 230 i = 1,n
 230    y(i) = yh(i,1)
  call f (tn, y, savf, rpar, ipar)
  nfe = nfe + 1
  if (ipup <= 0) go to 250
!
! if indicated, the matrix p = i - h*el(1)*j is reevaluated and
! preprocessed before starting the corrector iteration.  ipup is set
! to 0 as an indicator that this has been done.
!
  ipup = 0
  rc = 1.0e0
  nstepj = nst
  crate = 0.7e0
  call pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac, &
            rpar, ipar)
  if (ier /= 0) go to 430
 250  do 260 i = 1,n
 260    acor(i) = 0.0e0
 270  if (miter /= 0) go to 350
!
! in the case of functional iteration, update y directly from
! the result of the last function evaluation.
!
  do 290 i = 1,n
    savf(i) = h*savf(i) - yh(i,2)
 290    y(i) = savf(i) - acor(i)
  del = vnwrms (n, y, ewt)
  do 300 i = 1,n
    y(i) = yh(i,1) + el(1)*savf(i)
 300    acor(i) = savf(i)
  go to 400
!
! in the case of the chord method, compute the corrector error,
! and solve the linear system with that as right-hand side and
! p as coefficient matrix.
!
 350  do 360 i = 1,n
 360    y(i) = h*savf(i) - (yh(i,2) + acor(i))
  call slvs (wm, iwm, y, savf)
  if (ier /= 0) go to 410
  del = vnwrms (n, y, ewt)
  do 380 i = 1,n
    acor(i) = acor(i) + y(i)
 380    y(i) = yh(i,1) + el(1)*acor(i)
!
! test for convergence.  if m > 0, an estimate of the convergence
! rate constant is stored in crate, and this is used in the test.
!
 400  if (m /= 0) crate = max ( 0.2e0*crate,del/delp)
  dcon = del*amin1(1.0e0,1.5e0*crate)/(tesco(2,nq)*conit)
  if (dcon <= 1.0e0) go to 450
  m = m + 1
  if (m == 3) go to 410
  if (m >= 2 .and. del > 2.0e0*delp) go to 410
  delp = del
  call f (tn, y, savf, rpar, ipar)
  nfe = nfe + 1
  go to 270
!
! the corrector iteration failed to converge in 3 tries.
! if miter /= 0 and the jacobian is out of date, pjac is called for
! the next try.  otherwise the yh array is retracted to its values
! before prediction, and h is reduced, if possible.  if h cannot be
! reduced or 10 failures have occurred, exit with kflag = -2.
!
 410  if (ipup == 0) go to 430
  ipup = miter
  go to 220
 430  tn = told
  ncf = ncf + 1
  rmax = 2.0e0
  i1 = nqnyh + 1
  do 445 jb = 1,nq
    i1 = i1 - nyh
    do 440 i = i1,nqnyh
      ipnyh = i + nyh
 440      yh1(i) = yh1(i) - yh1(ipnyh)
 445    continue
  if (abs(h) <= hmin*1.00001e0) go to 670
  if (ncf == 10) go to 670
  rh = 0.25e0
  ipup = miter
  iredo = 1
  go to 170
!
! the corrector has converged.  ipup is set to -1 if miter /= 0,
! to signal that the jacobian involved may need updating later.
! the local error test is made and control passes to statement 500
! if it fails.
!
 450  if (miter /= 0) ipup = -1
  if (m == 0) dsm = del/tesco(2,nq)
  if (m > 0) dsm = vnwrms (n, acor, ewt)/tesco(2,nq)
  if (dsm > 1.0e0) go to 500
!
! after a successful step, update the yh array.
! consider changing h if ialth = 1.  otherwise decrease ialth by 1.
! if ialth is then 1 and nq < maxord, then acor is saved for
! use in a possible order increase on the next step.
! if a change in h is considered, an increase or decrease in order
! by one is considered also.  a change in h is made only if it is by a
! factor of at least 1.1.  if not, ialth is set to 3 to prevent
! testing for that many steps.
!
  kflag = 0
  iredo = 0
  nst = nst + 1
  hu = h
  nqu = nq
  do 470 j = 1,l
    do 470 i = 1,n
 470      yh(i,j) = yh(i,j) + el(j)*acor(i)
  ialth = ialth - 1
  if (ialth == 0) go to 520
  if (ialth > 1) go to 690
  if (l == lmax) go to 690
  do 490 i = 1,n
 490    yh(i,lmax) = acor(i)
  go to 690
!
! the error test failed.  kflag keeps track of multiple failures.
! restore tn and the yh array to their previous values, and prepare
! to try the step again.  compute the optimum step size for this or
! one lower order.  after 2 or more failures, h is forced to decrease
! by a factor of 0.2 or less.
!
 500  kflag = kflag - 1
  tn = told
  i1 = nqnyh + 1
  do 515 jb = 1,nq
    i1 = i1 - nyh
    do 510 i = i1,nqnyh
      ipnyh = i + nyh
 510      yh1(i) = yh1(i) - yh1(ipnyh)
 515    continue
  rmax = 2.0e0
  if (abs(h) <= hmin*1.00001e0) go to 660
  if (kflag <= -3) go to 640
  iredo = 2
  rhup = 0.0e0
  go to 540
!
! regardless of the success or failure of the step, factors
! rhdn, rhsm, and rhup are computed, by which h could be multiplied
! at order nq - 1, order nq, or order nq + 1, respectively.
! in the case of failure, rhup = 0.0 to avoid an order increase.
! the largest of these is determined and the new order chosen
! accordingly.  if the order is to be increased, we compute one
! additional scaled derivative.
!
 520  rhup = 0.0e0
  if (l == lmax) go to 540
  do 530 i = 1,n
 530    savf(i) = acor(i) - yh(i,lmax)
  dup = vnwrms (n, savf, ewt)/tesco(3,nq)
  exup = 1.0e0/real(l+1)
  rhup = 1.0e0/(1.4e0*dup**exup + 0.0000014e0)
 540  exsm = 1.0e0/real(l)
  rhsm = 1.0e0/(1.2e0*dsm**exsm + 0.0000012e0)
  rhdn = 0.0e0
  if (nq == 1) go to 560
  ddn = vnwrms (n, yh(1,l), ewt)/tesco(1,nq)
  exdn = 1.0e0/real(nq)
  rhdn = 1.0e0/(1.3e0*ddn**exdn + 0.0000013e0)
 560  if (rhsm >= rhup) go to 570
  if (rhup > rhdn) go to 590
  go to 580
 570  if (rhsm < rhdn) go to 580
  newq = nq
  rh = rhsm
  go to 620
 580  newq = nq - 1
  rh = rhdn
  if (kflag < 0 .and. rh > 1.0e0) rh = 1.0e0
  go to 620
 590  newq = l
  rh = rhup
  if (rh < 1.1e0) go to 610
  r = el(l)/real(l)
  do 600 i = 1,n
 600    yh(i,newq+1) = acor(i)*r
  go to 630
 610  ialth = 3
  go to 690
 620  if ((kflag == 0) .and. (rh < 1.1e0)) go to 610
  if (kflag <= -2) rh = amin1(rh,0.2e0)
!
! if there is a change of order, reset nq, l, and the coefficients.
! in any case h is reset according to rh and the yh array is rescaled.
! then exit from 680 if the step was ok, or redo the step otherwise.
!
  if (newq == nq) go to 170
 630  nq = newq
  l = nq + 1
  iret = 2
  go to 150
!
! control reaches this section if 3 or more failures have occured.
! if 10 failures have occurred, exit with kflag = -1.
! it is assumed that the derivatives that have accumulated in the
! yh array have errors of the wrong order.  hence the first
! derivative is recomputed, and the order is set to 1.  then
! h is reduced by a factor of 10, and the step is retried,
! until it succeeds or h reaches hmin.
!
 640  if (kflag == -10) go to 660
  rh = 0.1e0
  rh = max ( hmin/abs(h),rh)
  h = h*rh
  do 645 i = 1,n
 645    y(i) = yh(i,1)
  call f (tn, y, savf, rpar, ipar)
  nfe = nfe + 1
  do 650 i = 1,n
 650    yh(i,2) = h*savf(i)
  ipup = miter
  ialth = 5
  if (nq == 1) go to 200
  nq = 1
  l = 2
  iret = 3
  go to 150
!
! all returns are made through this section.  h is saved in hold
! to allow the caller to change h on the next step.
!
 660  kflag = -1
  go to 700
 670  kflag = -2
  go to 700
 680  rmax = 10.0e0
 690  r = 1.0e0/tesco(2,nqu)
  do 695 i = 1,n
 695    acor(i) = acor(i)*r
 700  hold = h
  jstart = 1
  return
end
subroutine store2 (a, b)
!
!*******************************************************************************
!
!! STORE2: storage of single precision information into memory
!
  common /spdata/ d1, d2
  d1 = a
  d2 = b
  return
end
subroutine surf (m,n,x,y,z,iz,opt,zp,temp,sigma,ierr)
!
!*******************************************************************************
!
!! SURF determines parameters for interpolatory surface on a rectangular grid.
!
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
!                               modified by alfred h. morris
!                               Naval Surface Weapons Center,
!                                          dahlgren virginia
!
! this subroutine determines the parameters necessary to
! compute an interpolatory surface passing through a rect-
! angular grid of functional values. the surface determined
! can be represented as the tensor product of splines under
! tension. the x- and y-partial derivatives around the
! boundary and the x-y-partial derivatives at the four
! corners may be specified or omitted. for actual mapping
! of points onto the surface it is necessary to call the
! function surf2.
!
! on input--
!
!   m is the number of grid lines in the x-direction, i. e.
!   lines parallel to the y-axis (m >= 2).
!
!   n is the number of grid lines in the y-direction, i. e.
!   lines parallel to the x-axis (n >= 2).
!
!   x is an array of the m x-coordinates of the grid lines
!   in the x-direction. these should be strictly increasing.
!
!   y is an array of the n y-coordinates of the grid lines
!   in the y-direction. these should be strictly increasing.
!
!   z is an array of the m * n functional values at the grid
!   points, i. e. z(i,j) contains the functional value at
!   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
!
!   iz is the row dimension of the matrix z used in the
!   calling program (iz >= m).
!
!   opt is an option vector. if no boundary conditions are
!   to be imposed on the surface then let opt be of length 1
!   and set opt(1)=0. otherwise, see the description of surf
!   in the nswc library manual.
!
!   zp is an array of at least 3*m*n locations.
!
!   temp is an array of at least n+n+m locations which is
!   used for scratch storage.
!
!   sigma contains the tension factor. this value indicates
!   the curviness desired. if abs(sigma) is nearly zero
!   (e. g. .001) the resulting surface is approximately the
!   tensor product of cubic splines. if abs(sigma) is large
!   (e. g. 50.) the resulting surface is approximately
!   bi-linear. if sigma equals zero tensor products of
!   cubic splines result. a standard value for sigma is
!   approximately 1. in absolute value.
!
! on output--
!
!   zp contains the values of the xx-, yy-, and xxyy-partial
!   derivatives of the surface at the given nodes.
!
!   ierr contains an error flag,
!        = 0 for normal return,
!        = 1 if n is less than 2 or m is less than 2,
!        = 2 if the x-values or y-values are not strictly
!            increasing,
!        = 3 the option vector has an error.
!
! this subroutine references package modules ceez, terms,
! and snhcsh.
!
!
  integer m,n,iz,ierr
  real x(m),y(n),z(iz,n),opt(*),zp(m,n,*),temp(*),sigma
!
  integer ind(8),loc(8),num(8)
  data num(5)/1/, num(6)/1/, num(7)/1/, num(8)/1/
!
  mm1 = m-1
  mp1 = m+1
  nm1 = n-1
  np1 = n+1
  npm = n+m
  ierr = 0
  if (n <= 1 .or. m <= 1) go to 46
  if (y(n) <= y(1)) go to 47
!
! process the option vector
!
  num(1) = n
  num(2) = n
  num(3) = m
  num(4) = m
  ind(1) = 0
  ind(2) = 0
  ind(3) = 0
  ind(4) = 0
  ind(5) = 0
  ind(6) = 0
  ind(7) = 0
  ind(8) = 0
!
  l = 1
  100 key = opt(l)
  if (key) 48,110,101
  101 if (key > 8) go to 48
  ind(key) = 1
  l = l+1
  loc(key) = l
  l = l + num(key)
  go to 100
!
! denormalize tension factor in y-direction
!
  110 sigmay = abs(sigma)*real(n-1)/(y(n)-y(1))
!
! obtain y-partial derivatives along y = y(1)
!
  if (ind(3) == 0) go to 2
  l = loc(3)
  do 1 i = 1,m
    zp(i,1,1) = opt(l)
1   l = l+1
  go to 5
2 dely1 = y(2)-y(1)
  dely2 = dely1+dely1
  if (n > 2) dely2 = y(3)-y(1)
  if (dely1 <= 0. .or. dely2 <= dely1) go to 47
  call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
  do 3 i = 1,m
3   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
  if (n == 2) go to 5
  do 4 i = 1,m
4   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
!
! obtain y-partial derivatives along y = y(n)
!
5 if (ind(4) == 0) go to 7
  l = loc(4)
  do 6 i = 1,m
    npi = n+i
    temp(npi) = opt(l)
6   l = l+1
  go to 10
7 delyn = y(n)-y(nm1)
  delynm = delyn+delyn
  if (n > 2) delynm = y(n)-y(n-2)
  if (delyn <= 0. .or. delynm <= delyn) go to 47
  call ceez (-delyn,-delynm,sigmay,c1,c2,c3,n)
  do 8 i = 1,m
    npi = n+i
8   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
  if (n == 2) go to 10
  do 9 i = 1,m
    npi = n+i
9   temp(npi) = temp(npi)+c3*z(i,n-2)
   10 if (x(m) <= x(1)) go to 47
!
! denormalize tension factor in x-direction
!
  sigmax = abs(sigma)*real(m-1)/(x(m)-x(1))
!
! obtain x-partial derivatives along x = x(1)
!
  if (ind(1) == 0) go to 12
  l = loc(1)
  do 11 j = 1,n
    zp(1,j,2) = opt(l)
   11   l = l+1
  if (ind(5)+ind(7) == 2) go to 15
   12 delx1 = x(2)-x(1)
  delx2 = delx1+delx1
  if (m > 2) delx2 = x(3)-x(1)
  if (delx1 <= 0. .or. delx2 <= delx1) go to 47
  call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
  if (ind(1) == 1) go to 15
  do 13 j = 1,n
   13   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
  if (m == 2) go to 15
  do 14 j = 1,n
   14   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
!
! obtain x-y-partial derivative at (x(1),y(1))
!
   15 if (ind(5) == 0) go to 16
  l = loc(5)
  zp(1,1,3) = opt(l)
  go to 17
   16 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
  if (m > 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
!
! obtain x-y-partial derivative at (x(1),y(n))
!
   17 if (ind(7) == 0) go to 18
  l = loc(7)
  zxy1ns = opt(l)
  go to 19
   18 zxy1ns = c1*temp(n+1)+c2*temp(n+2)
  if (m > 2) zxy1ns = zxy1ns+c3*temp(n+3)
!
! obtain x-partial derivative along x = x(m)
!
   19 if (ind(2) == 0) go to 21
  l = loc(2)
  do 20 j = 1,n
    npmpj = npm+j
    temp(npmpj) = opt(l)
   20   l = l+1
   21 if (ind(6)+ind(8) == 2) go to 24
  delxm = x(m)-x(mm1)
  delxmm = delxm+delxm
  if (m > 2) delxmm = x(m)-x(m-2)
  if (delxm <= 0. .or. delxmm <= delxm) go to 47
  call ceez (-delxm,-delxmm,sigmax,c1,c2,c3,m)
  if (ind(2) == 1) go to 24
  do 22 j = 1,n
    npmpj = npm+j
   22   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
  if (m == 2) go to 24
  do 23 j = 1,n
    npmpj = npm+j
   23   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
!
! obtain x-y-partial derivative at (x(m),y(1))
!
   24 if (ind(6) == 0) go to 25
  l = loc(6)
  zp(m,1,3) = opt(l)
  go to 26
   25 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
  if (m > 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
!
! obtain x-y-partial derivative at (x(m),y(n))
!
   26 if (ind(8) == 0) go to 27
  l = loc(8)
  zxymns = opt(l)
  go to 28
   27 zxymns = c1*temp(npm)+c2*temp(npm-1)
  if (m > 2) zxymns = zxymns+c3*temp(npm-2)
!
! set up right hand sides and tridiagonal system for y-grid
! perform forward elimination
!
   28 del1 = y(2)-y(1)
  if (del1 <= 0.) go to 47
  deli = 1./del1
  do 29 i = 1,m
   29   zp(i,2,1) = deli*(z(i,2)-z(i,1))
  zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
  zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
  call terms (diag1,sdiag1,sigmay,del1)
  diagi = 1./diag1
  do 30 i = 1,m
   30   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
  zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
  zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
  temp(1) = diagi*sdiag1
  if (n == 2) go to 34
  do 33 j = 2,nm1
    jm1 = j-1
    jp1 = j+1
    npmpj = npm+j
    del2 = y(jp1)-y(j)
    if (del2 <= 0.) go to 47
    deli = 1./del2
    do 31 i = 1,m
   31     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
    zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
    zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
    call terms (diag2,sdiag2,sigmay,del2)
    diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
    do 32 i = 1,m
   32     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)- &
                          sdiag1*zp(i,jm1,1))
    zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)- &
                        sdiag1*zp(1,jm1,3))
    zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)- &
                        sdiag1*zp(m,jm1,3))
    temp(j) = diagin*sdiag2
    diag1 = diag2
   33   sdiag1 = sdiag2
   34 diagin = 1./(diag1-sdiag1*temp(nm1))
  do 35 i = 1,m
    npi = n+i
   35   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)- &
                        sdiag1*zp(i,nm1,1))
  zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)- &
                      sdiag1*zp(1,nm1,3))
  temp(n) = diagin*(zxymns-zp(m,n,3)- &
                    sdiag1*zp(m,nm1,3))
!
! perform back substitution
!
  do 37 j = 2,n
    jbak = np1-j
    jbakp1 = jbak+1
    t = temp(jbak)
    do 36 i = 1,m
   36     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
    zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   37   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
!
! set up right hand sides and tridiagonal system for x-grid
! perform forward elimination
!
  del1 = x(2)-x(1)
  if (del1 <= 0.) go to 47
  deli = 1./del1
  do 38 j = 1,n
    zp(2,j,2) = deli*(z(2,j)-z(1,j))
   38   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
  call terms (diag1,sdiag1,sigmax,del1)
  diagi = 1./diag1
  do 39 j = 1,n
    zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   39   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
  temp(n+1) = diagi*sdiag1
  if (m  == 2) go to 43
  do 42 i = 2,mm1
    im1 = i-1
    ip1 = i+1
    npi = n+i
    del2 = x(ip1)-x(i)
    if (del2 <= 0.) go to 47
    deli = 1./del2
    do 40 j = 1,n
      zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   40     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
    call terms (diag2,sdiag2,sigmax,del2)
    diagin = 1./(diag1+diag2-sdiag1*temp(npi-1))
    do 41 j = 1,n
      zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)- &
                          sdiag1*zp(im1,j,2))
   41     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)- &
                          sdiag1*zp(im1,j,3))
    temp(npi) = diagin*sdiag2
    diag1 = diag2
   42   sdiag1 = sdiag2
   43 diagin = 1./(diag1-sdiag1*temp(npm-1))
  do 44 j = 1,n
    npmpj = npm+j
    zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)- &
                        sdiag1*zp(mm1,j,2))
   44   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)- &
                        sdiag1*zp(mm1,j,3))
!
! perform back substitution
!
  do 45 i = 2,m
    ibak = mp1-i
    ibakp1 = ibak+1
    npibak = n+ibak
    t = temp(npibak)
    do 45 j = 1,n
      zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   45     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
  return
!
! too few points
!
   46 ierr = 1
  return
!
! points not strictly increasing
!
   47 ierr = 2
  return
!
! the option vector has an error
!
   48 ierr = 3
  return
end
function surf2 (xx,yy,m,n,x,y,z,iz,zp,sigma)
!
!*******************************************************************************
!
!! SURF2 evaluates an interpolating surface at a given coordinate pair.
!
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! this function interpolates a surface at a given coordinate
! pair using a bi-spline under tension. the subroutine surf1
! should be called earlier to determine certain necessary
! parameters.
!
! on input--
!
!   xx and yy contain the x- and y-coordinates of the point
!   to be mapped onto the interpolating surface.
!
!   m and n contain the number of grid lines in the x- and
!   y-directions, respectively, of the rectangular grid
!   which specified the surface.
!
!   x and y are arrays containing the x- and y-grid values,
!   respectively, each in increasing order.
!
!   z is a matrix containing the m * n functional values
!   corresponding to the grid values (i. e. z(i,j) is the
!   surface value at the point (x(i),y(j)) for i = 1,...,m
!   and j = 1,...,n).
!
!   iz contains the row dimension of the array z as declared
!   in the calling program.
!
!   zp is an array of 3*m*n locations stored with the
!   various surface derivative information determined by
!   surf1.
!
! and
!
!   sigma contains the tension factor (its sign is ignored).
!
! the parameters m, n, x, y, z, iz, zp, and sigma should be
! input unaltered from the output of surf1.
!
! on output--
!
!   surf2 contains the interpolated surface value.
!
! none of the input parameters are altered.
!
! this function references package modules intrvl and
! snhcsh.
!
  integer m,n,iz
  real xx,yy,x(m),y(n),z(iz,n),zp(m,n,*),sigma
!
!
! inline one dimensional cubic spline interpolation
!
  hermz (f1,f2,fp1,fp2) = (f2*del1+f1*del2)/dels-del1* &
                          del2*(fp2*(del1+dels)+ &
                                fp1*(del2+dels))/ &
                          (6.*dels)
!
! inline one dimensional spline under tension interpolation
!
  hermnz (f1,f2,fp1,fp2,sigmap) = (f2*del1+f1*del2)/dels &
            +(fp2*(sinhm1*del2-del1*(2.*(coshp1+1.)* &
                             sinhp2+sigmap*coshp1*del2)) &
             +fp1*(sinhm2*del1-del2*(2.*(coshp2+1.)* &
                             sinhp1+sigmap*coshp2*del1)) &
            )/(sigmap*sigmap*dels*(sinhms+sigmap*dels))
!
! denormalize tension factor in x and y direction
!
  sigmax = abs(sigma)*real(m-1)/(x(m)-x(1))
  sigmay = abs(sigma)*real(n-1)/(y(n)-y(1))
!
! determine y interval
!
  jm1 = intrvl (yy,y,n)
  j = jm1+1
!
! determine x interval
!
  im1 = intrvl (xx,x,m)
  i = im1+1
  del1 = yy-y(jm1)
  del2 = y(j)-yy
  dels = y(j)-y(jm1)
  if (sigmay /= 0.) go to 1
!
! perform four interpolations in y-direction
!
  zim1 = hermz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1), &
                                    zp(i-1,j,1))
  zi = hermz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1))
  zxxim1 = hermz(zp(i-1,j-1,2),zp(i-1,j,2), &
                  zp(i-1,j-1,3),zp(i-1,j,3))
  zxxi = hermz(zp(i,j-1,2),zp(i,j,2), &
                zp(i,j-1,3),zp(i,j,3))
  go to 2
1 delp1 = (del1+dels)/2.
  delp2 = (del2+dels)/2.
  call snhcsh (sinhm1,dummy,sigmay*del1,-1)
  call snhcsh (sinhm2,dummy,sigmay*del2,-1)
  call snhcsh (sinhms,dummy,sigmay*dels,-1)
  call snhcsh (sinhp1,dummy,sigmay*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmay*del2/2.,-1)
  call snhcsh (dummy,coshp1,sigmay*delp1,1)
  call snhcsh (dummy,coshp2,sigmay*delp2,1)
  zim1 = hermnz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1), &
                 zp(i-1,j,1),sigmay)
  zi = hermnz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1), &
               sigmay)
  zxxim1 = hermnz(zp(i-1,j-1,2),zp(i-1,j,2), &
                   zp(i-1,j-1,3),zp(i-1,j,3),sigmay)
  zxxi = hermnz(zp(i,j-1,2),zp(i,j,2), &
                 zp(i,j-1,3),zp(i,j,3),sigmay)
!
! perform final interpolation in x-direction
!
2 del1 = xx-x(im1)
  del2 = x(i)-xx
  dels = x(i)-x(im1)
  if (sigmax /= 0.) go to 3
  surf2 = hermz(zim1,zi,zxxim1,zxxi)
  return
3 delp1 = (del1+dels)/2.
  delp2 = (del2+dels)/2.
  call snhcsh (sinhm1,dummy,sigmax*del1,-1)
  call snhcsh (sinhm2,dummy,sigmax*del2,-1)
  call snhcsh (sinhms,dummy,sigmax*dels,-1)
  call snhcsh (sinhp1,dummy,sigmax*del1/2.,-1)
  call snhcsh (sinhp2,dummy,sigmax*del2/2.,-1)
  call snhcsh (dummy,coshp1,sigmax*delp1,1)
  call snhcsh (dummy,coshp2,sigmax*delp2,1)
  surf2 = hermnz(zim1,zi,zxxim1,zxxi,sigmax)
  return
end
subroutine svco (rsav, isav)
!
!*******************************************************************************
!
!! SVCO stores in rsav and isav the contents of common block debdf1,
!  which is used internally in the sfode package.
!
! rsav = real array of length 218 or more.
! isav = integer array of length 33 or more.
!
  integer isav, i, ils, lenils, lenrls
  real rsav, rls
  dimension rsav(*), isav(*)
  common /debdf1/ rls(218), ils(33)
  data lenrls/218/, lenils/33/
!
  do 10 i = 1,lenrls
 10     rsav(i) = rls(i)
  do 20 i = 1,lenils
 20     isav(i) = ils(i)
  return
end
subroutine svprd(a,n,x,y)
!
!*******************************************************************************
!
!! SVPRD: ???
!
  real a(*),x(n),y(n)
  y(1) = a(1)*x(1)
  if (n == 1) return
!
  l = 1
  do 20 k = 2,n
  km1 = k - 1
  xk = x(k)
  yk = 0.0
!
  do 10 i = 1,km1
  l = l + 1
  y(i) = y(i) + a(l)*xk
   10 yk = yk + a(l)*x(i)
!
  l = l + 1
   20 y(k) = yk + a(l)*xk
  return
end
subroutine symslv (a,c,n,na,nc,ierr)
!
!*******************************************************************************
!
!! SYMSLV solves the matrix equation transpose(a)*x + x*a = c
!     where a is in upper schur form and c is symmetric.
!
  integer n,na,nc,ierr
  real a(na,n), c(nc,n), sum, p(4), t(4,4)
  integer dk,dl,i,ia,j,k,kk,km1,l,ll,ldl
!
  l = 1
   10    dl = 1
     if (l == n) go to 20
     if (a(l+1,l) /= 0.0) dl = 2
   20    ll = l + dl - 1
!
     k = l
   30       km1 = k - 1
        dk = 1
        if (k == n) go to 35
        if (a(k+1,k) /= 0.0) dk = 2
   35       kk = k + dk - 1
        if (k == l) go to 45
!
        do 42 i = k,kk
           do 41 j = l,ll
           sum = c(i,j)
              do 40 ia = l,km1
   40             sum = sum - a(ia,i)*c(ia,j)
   41          c(i,j) = sum
   42       continue
!
   45       if (dl == 2) go to 60
        if (dk == 2 ) go to 50
        t(1,1) = a(k,k) + a(l,l)
        if (t(1,1) == 0.0) go to 200
        c(k,l) = c(k,l)/t(1,1)
        ierr = 0
        go to 90
!
   50       t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(kk,k)
        t(2,1) = a(k,kk)
        t(2,2) = a(kk,kk) + a(l,l)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        call slv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        go to 90
!
   60       if (dk == 2) go to 70
        t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(ll,l)
        t(2,1) = a(l,ll)
        t(2,2) = a(k,k) + a(ll,ll)
        p(1) = c(k,l)
        p(2) = c(k,ll)
        call slv (2, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(k,ll) = p(2)
        go to 90
!
   70       if (k /= l) go to 80
        t(1,1) = a(l,l)
        t(1,2) = a(ll,l)
        t(1,3) = 0.0
        t(2,1) = a(l,ll)
        t(2,2) = a(l,l) + a(ll,ll)
        t(2,3) = t(1,2)
        t(3,1) = 0.0
        t(3,2) = t(2,1)
        t(3,3) = a(ll,ll)
        p(1) = c(l,l)/2.0
        p(2) = c(ll,l)
        p(3) = c(ll,ll)/2.0
        call slv (3, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(l,l) = p(1)
        c(ll,l) = p(2)
        c(l,ll) = p(2)
        c(ll,ll) = p(3)
        go to 90
!
   80       t(1,1) = a(k,k) + a(l,l)
        t(1,2) = a(kk,k)
        t(1,3) = a(ll,l)
        t(1,4) = 0.0
        t(2,1) = a(k,kk)
        t(2,2) = a(kk,kk) + a(l,l)
        t(2,3) = 0.0
        t(2,4) = t(1,3)
        t(3,1) = a(l,ll)
        t(3,2) = 0.0
        t(3,3) = a(k,k) + a(ll,ll)
        t(3,4) = t(1,2)
        t(4,1) = 0.0
        t(4,2) = t(3,1)
        t(4,3) = t(2,1)
        t(4,4) = a(kk,kk) + a(ll,ll)
        p(1) = c(k,l)
        p(2) = c(kk,l)
        p(3) = c(k,ll)
        p(4) = c(kk,ll)
        call slv (4, 1, t, 4, p, 4, ierr)
        if (ierr /= 0) go to 200
        c(k,l) = p(1)
        c(kk,l) = p(2)
        c(k,ll) = p(3)
        c(kk,ll) = p(4)
!
   90    k = k + dk
     if (k <= n) go to 30
  ldl = l + dl
  if (ldl > n) return
!
  do 121 j = ldl,n
     do 100 i = l,ll
        c(i,j) = c(j,i)
  100    continue
     do 120 i = j,n
        do 110 k = l,ll
  110       c(i,j) = c(i,j) - c(i,k)*a(k,j) - a(k,i)*c(k,j)
  120    c(j,i) = c(i,j)
  121 continue
  l = ldl
  go to 10
!
!     error return
!
  200 ierr = 1
  return
end
subroutine taslv (mo,n,a,na,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! TASLV solves the real matrix equation transpose(a)*x + x*a = c
!     where c is a symmetric matrix. a is reduced to upper schur form
!     and the transformed system is solved.
!
!        mo is an input argument which specifies if the routine is
!     being called for the first time. on an initial call mo = 0 and
!     we have the following setup.
!
!        a(na,n)
!           a is a matrix of order n. it is assumed that
!           na >= n >= 1.
!
!        c(nc,n)
!           c is a symmetric matrix of order n. it is
!           assumed that nc >= n.
!
!        wk(---)
!           wk is an array of dimension n**2 + 2n that
!           is a general storage area for the routine.
!
!     ierr is a variable that reports the status of the results. when
!     the routine terminates, ierr has one of the following values...
!
!        ierr =  0  the solution was obtained and stored in c.
!        ierr =  1  the equations are inconsistent for a. the
!                   problem cannot be solved.
!        ierr = -1  a could not be reducedto upper schur form.
!                   the problem cannot be solved.
!
!     when ierr = 0, a contains the upper schur form of the matrix
!     a and wk contains the orthogonal matrix involved in the schur
!     decomposition of a. this information can be reused to solve a
!     new set of equations transpose(a)*x + x*a = c without having
!     to redecompose a. in this case, the input argument mo may be
!     set to any nonzero value. when mo /= 0, it is assumed that
!     only c has been modified. on output the solution for the new
!     set of equations is stored in c.
!
!     this subroutine is a modification by
!        Alfred Morris,
!        Naval Surface Weapons Center,
!        Dahlgren, Virginia
!     of the subroutine atxpxa written by
!        r.h. bartels and g.w. stewart
!        university of texas at austin.
!
!     reference. bartels, r.h. and stewart, g.w., algorithm 432,
!        solution of the matrix equation ax + xb = c, comm. acm
!        15 (1972), pp. 820-826.
!
  real a(na,n), c(nc,n), wk(*)
!

  iw = n*n + 1
  call taslv1 (mo,n,a,na,wk(1),n,c,nc,wk(iw),ierr)
  return
end
subroutine taslv1 (mo,n,a,na,u,nu,c,nc,wk,ierr)
!
!*******************************************************************************
!
!! TASLV1 solves the real matrix equation transpose(a)*x + x*a = c
!     where c is a symmetric matrix. a is reduced to upper schur form
!     and the transformed system is solved.
!
  real a(na,n), u(nu,n), c(nc,n), wk(*)
!
!    if required, reduce a to upper real schur form
!
  if (mo /= 0) go to 10
  call orthes (na,n,1,n,a,wk)
  call ortrn1 (n,1,n,a,na,u,nu,wk)
  call schur (n,1,n,a,na,u,nu,wk(1),wk(n+1),ierr)
  if (ierr /= 0) go to 200
!
!     transform c
!
   10 do 20 i = 1,n
     c(i,i) = c(i,i)/2.0
   20 continue
!
  do 41 i = 1,n
     do 31 j = 1,n
        wk(j) = 0.0
        do 30 k = i,n
           wk(j) = wk(j) + c(i,k)*u(k,j)
   30       continue
   31    continue
     do 40 j = 1,n
        c(i,j) = wk(j)
   40    continue
   41 continue
!
  do 61 j = 1,n
     do 51 i = 1,n
        wk(i) = 0.0
        do 50 k = 1,n
           wk(i) = wk(i) + u(k,i)*c(k,j)
   50       continue
   51    continue
     do 60 i = 1,n
        c(i,j) = wk(i)
   60    continue
   61 continue
!
  do 71 i = 1,n
     do 70 j = i,n
        c(i,j) = c(i,j) + c(j,i)
        c(j,i) = c(i,j)
   70    continue
   71 continue
!
!     solve the transformed system
!
  call symslv (a,c,n,na,nc,ierr)
  if (ierr /= 0) go to 210
!
!     transform c back to the solution
!
  do 80 i = 1,n
     c(i,i) = c(i,i)/2.0
   80 continue
!
  do 101 i = 1,n
     do 91 j = 1,n
        wk(j) = 0.0
        do 90 k = i,n
           wk(j) = wk(j) + c(i,k)*u(j,k)
   90       continue
   91    continue
     do 100 j = 1,n
        c(i,j) = wk(j)
  100    continue
  101 continue
!
  do 121 j = 1,n
     do 111 i = 1,n
        wk(i) = 0.0
        do 110 k = 1,n
           wk(i) = wk(i) + u(i,k)*c(k,j)
  110       continue
  111    continue
     do 120 i = 1,n
        c(i,j) = wk(i)
  120    continue
  121 continue
!
  do 131 i = 1,n
     do 130 j = i,n
        c(i,j) = c(i,j) + c(j,i)
        c(j,i) = c(i,j)
  130    continue
  131 continue
  return
!
!     error return
!
  200 ierr = -1
  return
  210 ierr = 1
  return
end
subroutine terms (diag,sdiag,sigma,del)
!
!*******************************************************************************
!
!! TERMS computes the diagonal and superdiagonal
! terms of the tridiagonal linear system associated with
! spline under tension interpolation.
!
!                      from the spline under tension package
!                       coded by a. k. cline and r. j. renka
!                            department of computer sciences
!                              university of texas at austin
!
! on input--
!
!   sigma contains the tension factor.
!
! and
!
!   del contains the step size.
!
! on output--
!
!               (sigma*del*cosh(sigma*del) - sinh(sigma*del)
!   diag = del*--------------------------------------------.
!                     (sigma*del)**2 * sinh(sigma*del)
!
!                   sinh(sigma*del) - sigma*del
!   sdiag = del*----------------------------------.
!                (sigma*del)**2 * sinh(sigma*del)
!
! and
!
!   sigma and del are unaltered.
!
! this subroutine references package module snhcsh.
!
  real diag,sdiag,sigma,del
!
  if (sigma /= 0.) go to 1
  diag = del/3.
  sdiag = del/6.
  return
1 sigdel = sigma*del
  call snhcsh (sinhm,coshm,sigdel,0)
  denom = del/((sinhm+sigdel)*sigdel*sigdel)
  diag = denom*(sigdel*coshm-sinhm)
  sdiag = denom*sinhm
  return
end
subroutine timestamp ( )
!
!*******************************************************************************
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  character ( len = 8 ) ampm
  integer d
  character ( len = 8 ) date
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  character ( len = 10 )  time
  integer values(8)
  integer y
  character ( len = 5 ) zone
!
  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine tip (a, n1, n2, moved, nwork, ndim)
!
!*******************************************************************************
!
!! TIP: transposition of a rectangular matrix in situ.
!
!
! by norman brenner, mit, 1/72.  cf. alg. 380, cacm, 5/70.
! transposition of the n1 by n2 matrix a amounts to
! replacing the element at vector position i (0-origin)
! with the element at position n1*i (mod n1*n2-1).
! each subcycle of this permutation is completed in order.
!
  real a(*)
  real atemp, btemp
  integer moved(nwork)
  integer ifact(8), ipower(8), nexp(8), iexp(8)
  if (n1 < 2 .or. n2 < 2) go to 200
  n12 = n1*n2
  n = n1
  m = n12 - 1
  if (n1/=n2) go to 30
! square matrices are done separately for speed
  i1min = 2
  do 20 i1max=n,m,n
    i2 = i1min + n - 1
    do 10 i1=i1min,i1max
      atemp = a(i1)
      a(i1) = a(i2)
      a(i2) = atemp
      i2 = i2 + n
   10   continue
    i1min = i1min + n + 1
   20 continue
  return
! modulus m is factored into prime powers.  eight factors
! suffice up to m = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 ndim = 0
  call infctr(m, ifact, ipower, nexp, npower)
  do 40 ip=1,npower
    iexp(ip) = 0
   40 continue
! generate every divisor of m less than m/2
  idiv = 1
  mhalf = m/2
   50 if (idiv >= mhalf) return
! the number of elements whose index is divisible by idiv
! and by no other divisor of m is the euler totient
! function, phi(m/idiv).
  ncount = m/idiv
  do 60 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 60
    ncount = (ncount/ifact(ip))*(ifact(ip)-1)
   60 continue
  if (nwork <= 0) go to 75
  do 70 i=1,nwork
    moved(i) = 0
   70 continue
   75 istart = idiv
! the starting point of a subcycle is divisible only by idiv
! and must not appear in any other subcycle.
   80 mmist = m - istart
  if (istart==idiv) go to 120
  ndim = max (ndim,istart)
  if (istart > nwork) go to 90
  if (moved(istart)/=0) go to 160
   90 isoid = istart/idiv
  do 100 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 100
    if (mod(isoid,ifact(ip))==0) go to 160
  100 continue
  if (istart <= nwork) go to 120
  itest = istart
  110 itest = mod(n*itest,m)
  if (itest < istart .or. itest > mmist) go to 160
  if (itest > istart .and. itest < mmist) go to 110
  120 atemp = a(istart+1)
  btemp = a(mmist+1)
  ia1 = istart
  130 ia2 = mod(n*ia1,m)
  mmia1 = m - ia1
  mmia2 = m - ia2
  if (ia1 <= nwork) moved(ia1) = 1
  if (mmia1 <= nwork) moved(mmia1) = 1
  ncount = ncount - 2
! move two elements, the second from the negative
! subcycle.  check first for subcycle closure.
  if (ia2==istart) go to 140
  if (mmia2==istart) go to 150
  a(ia1+1) = a(ia2+1)
  a(mmia1+1) = a(mmia2+1)
  ia1 = ia2
  go to 130
  140 a(ia1+1) = atemp
  a(mmia1+1) = btemp
  go to 160
  150 a(ia1+1) = btemp
  a(mmia1+1) = atemp
  160 istart = istart + idiv
  if (ncount > 0) go to 80
  do 180 ip=1,npower
    if (iexp(ip)==nexp(ip)) go to 170
    iexp(ip) = iexp(ip) + 1
    idiv = idiv*ifact(ip)
    go to 50
  170   iexp(ip) = 0
    idiv = idiv/ipower(ip)
  180 continue
  return
  200 if (n1/=n2) ndim = 0
  return
end
subroutine tmprod(m,n,l,a,ka,b,kb,c,kc)
!
!*******************************************************************************
!
!! TMPROD ???
!
  real a(ka,n),b(kb,l),c(kc,l)
  double precision s
  do 12 j=1,l
  do 11 i=1,n
  s = 0.d0
  do 10 k=1,m
   10 s = s + dble(a(k,i))*dble(b(k,j))
   11 c(i,j) = s
   12 continue
  return
end
subroutine toplx (a, b, x, n, g, h, ierr)
!
!*******************************************************************************
!
!! TOPLX: solution of the toeplitz system of equations
!
!               sum(j = 1,...,n) a(n+i-j)*x(j) = b(i)
!
!     for i = 1,...,n.
!
!     real a(2*n - 1)
!
  real a(*), b(n), x(n), g(n), h(n)
!
  if (a(n) == 0.0) go to 100
  ierr = 0
  x(1) = b(1)/a(n)
  if (n == 1) return
  g(1) = a(n - 1)/a(n)
  h(1) = a(n + 1)/a(n)
  mp1 = 1
!
!     compute numerator and denominator of x(m+1)
!
   10 m = mp1
  mp1 = m + 1
  xn = -b(mp1)
  xd = -a(n)
  do 20 j = 1,m
     l = mp1 - j
     npl = n + l
     xn = xn + a(npl)*x(j)
   20    xd = xd + a(npl)*g(l)
  if (xd == 0.0) go to 100
  x(mp1) = xn/xd
!
!        compute x
!
  c = x(mp1)
  do 30 j = 1,m
     l = mp1 - j
   30    x(j) = x(j) - c*g(l)
  if (mp1 == n) return
!
!     compute numerator and denominator of g(m+1) and h(m+1)
!
  l = n - mp1
  gn = -a(l)
  gd = -a(n)
  l = n + mp1
  hn = -a(l)
  do 40 j = 1,m
     l = mp1 - j
     nml = n - l
     npl = n + l
     gn = gn + a(nml)*g(j)
     gd = gd + a(nml)*h(l)
   40    hn = hn + a(npl)*h(j)
  if (gd == 0.0) go to 100
  g(mp1) = gn/gd
  h(mp1) = hn/xd
!
!     compute g and h
!
  c1 = g(mp1)
  c2 = h(mp1)
  max = mp1/2
  k = m
  do 50 j = 1,max
     gj = g(j)
     gk = g(k)
     hj = h(j)
     hk = h(k)
     g(j) = gj - c1*hk
     g(k) = gk - c1*hj
     h(j) = hj - c2*gk
     h(k) = hk - c2*gj
   50    k = k - 1
  go to 10
!
!     error return
!
  100 ierr = 1
  return
end
subroutine tpose(m,n,a,ka,b,kb)
!
!*******************************************************************************
!
!! TPOSE ???
!
  real a(ka,n),b(kb,m)
!
  do 20 j = 1,n
     do 10 i = 1,m
   10    b(j,i) = a(i,j)
   20 continue
  return
end
subroutine tql2(nm,n,d,e,z,ierr)
!
!*******************************************************************************
!
!! TQL2 is a translation of the algol procedure tql2,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a symmetric tridiagonal matrix by the ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        d contains the diagonal elements of the input matrix,
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary,
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output-
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1,
!
!        e has been destroyed,
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!
  integer i,j,k,l,m,n,ii,l1,nm,mml,ierr
  real d(n),e(n),z(nm,n)
  real b,c,f,g,h,p,r,s,machep
!
  machep = epsilon ( machep )
  ierr = 0
  if (n == 1) go to 1001
!
  do 100 i = 2, n
  100 e(i-1) = e(i)
!
  f = 0.0
  b = 0.0
  e(n) = 0.0
!
  do 240 l = 1, n
     j = 0
     h = machep * (abs(d(l)) + abs(e(l)))
     if (b < h) b = h
!  look for small sub-diagonal element.
     do 110 m = l, n
        if (abs(e(m)) <= b) go to 120
!  e(n) is always zero, so there is no exit
!                through the bottom of the loop.
  110    continue
!
  120    if (m == l) go to 220
  130    if (j == 30) go to 1000
     j = j + 1
!  form shift.
     l1 = l + 1
     g = d(l)
     p = (d(l1) - g) / (2.0 * e(l))
     r = sqrt(p*p+1.0)
     if (p < 0.0) r = -r
     d(l) = e(l) / (p + r)
     h = g - d(l)
!
     do 140 i = l1, n
  140    d(i) = d(i) - h
!
     f = f + h
!  ql transformation.
     p = d(m)
     c = 1.0
     s = 0.0
     mml = m - l
!  for i=m-1 step -1 until l do --
     do 200 ii = 1, mml
        i = m - ii
        g = c * e(i)
        h = c * p
        if (abs(p) < abs(e(i))) go to 150
        c = e(i) / p
        r = sqrt(c*c+1.0)
        e(i+1) = s * p * r
        s = c / r
        c = 1.0 / r
        go to 160
  150       c = p / e(i)
        r = sqrt(c*c+1.0)
        e(i+1) = s * e(i) * r
        s = 1.0 / r
        c = c * s
  160       p = c * d(i) - s * g
        d(i+1) = h + s * (c * g + s * d(i))
!  form vector.
        do 180 k = 1, n
           h = z(k,i+1)
           z(k,i+1) = s * z(k,i) + c * h
           z(k,i) = c * z(k,i) - s * h
  180       continue
!
  200    continue
!
     e(l) = s * p
     d(l) = c * p
     if (abs(e(l)) > b) go to 130
  220    d(l) = d(l) + f
  240 continue
!  order eigenvalues and eigenvectors.
  do 300 ii = 2, n
     i = ii - 1
     k = i
     p = d(i)
!
     do 260 j = ii, n
        if (d(j) >= p) go to 260
        k = j
        p = d(j)
  260    continue
!
     if (k == i) go to 300
     d(k) = d(i)
     d(i) = p
!
     do 280 j = 1, n
        p = z(j,i)
        z(j,i) = z(j,k)
        z(j,k) = p
  280    continue
!
  300 continue
!
  go to 1001
!  set error -- no convergence to an
!                eigenvalue after 30 iterations.
 1000 ierr = l
 1001 return
end
subroutine tqlrat(n,d,e2,ierr)
!
!*******************************************************************************
!
!! TQLRAT is a translation of the algol procedure tqlrat,
!     algorithm 464, comm. acm 16, 689(1973) by reinsch.
!
!     this subroutine finds the eigenvalues of a symmetric
!     tridiagonal matrix by the rational ql method.
!
!     on input-
!
!        n is the order of the matrix,
!
!        d contains the diagonal elements of the input matrix,
!
!        e2 contains the squares of the subdiagonal elements of the
!          input matrix in its last n-1 positions.  e2(1) is arbitrary.
!
!      on output-
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct and
!          ordered for indices 1,2,...ierr-1, but may not be
!          the smallest eigenvalues,
!
!        e2 has been destroyed,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
  integer i,j,l,m,n,ii,l1,mml,ierr
  real d(n),e2(n)
  real b,c,f,g,h,p,r,s,machep
!
  machep = epsilon ( machep )
  ierr = 0
  if (n == 1) go to 1001
!
  do 100 i = 2, n
  100 e2(i-1) = e2(i)
!
  f = 0.0
  b = 0.0
  e2(n) = 0.0
!
  do 290 l = 1, n
     j = 0
     h = machep * (abs(d(l)) + sqrt(e2(l)))
     if (b > h) go to 105
     b = h
     c = b * b
!  look for small squared sub-diagonal element.
  105    do 110 m = l, n
        if (e2(m) <= c) go to 120
!  e2(n) is always zero, so there is no exit
!                through the bottom of the loop.
  110    continue
!
  120    if (m == l) go to 210
  130    if (j == 30) go to 1000
     j = j + 1
!  form shift.
     l1 = l + 1
     s = sqrt(e2(l))
     g = d(l)
     p = (d(l1) - g) / (2.0 * s)
     r = sqrt(p*p+1.0)
     if (p < 0.0) r = -r
     d(l) = s / (p + r)
     h = g - d(l)
!
     do 140 i = l1, n
  140    d(i) = d(i) - h
!
     f = f + h
!  rational ql transformation.
     g = d(m)
     if (g == 0.0) g = b
     h = g
     s = 0.0
     mml = m - l
!  for i=m-1 step -1 until l do
     do 200 ii = 1, mml
        i = m - ii
        p = g * h
        r = p + e2(i)
        e2(i+1) = s * r
        s = e2(i) / r
        d(i+1) = h + s * (h + d(i))
        g = d(i) - e2(i) / g
        if (g == 0.0) g = b
        h = g * p / r
  200    continue
!
     e2(l) = s * g
     d(l) = h
!  guard against underflow in convergence test.
     if (h == 0.0) go to 210
     if (abs(e2(l)) <= abs(c/h)) go to 210
     e2(l) = h * e2(l)
     if (e2(l) /= 0.0) go to 130
  210    p = d(l) + f
!  order eigenvalues.
     if (l == 1) go to 250
!  for i=l step -1 until 2 do
     do 230 ii = 2, l
        i = l + 2 - ii
        if (p >= d(i-1)) go to 270
        d(i) = d(i-1)
  230    continue
!
  250    i = 1
  270    d(i) = p
  290 continue
!
  go to 1001
!   set error -- no convergence to an
!                eigenvalue after 30 iterations.
 1000 ierr = l
 1001 return
end
subroutine tqlrt0 (n,d,e2,ierr)
!
!*******************************************************************************
!
!! TQLRT0 is a modification of the eispack subroutine tqlrat.
!  the subroutine finds the eigenvalues of a symmetric
!     tridiagonal matrix by the rational ql method.
!
!     on input-
!
!        n is the order of the matrix,
!
!        d contains the diagonal elements of the input matrix,
!
!        e2 contains the                subdiagonal elements of the
!          input matrix in its last n-1 positions.  e2(1) is arbitrary.
!
!      on output-
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct and
!          ordered for indices 1,2,...ierr-1, but may not be
!          the smallest eigenvalues,
!
!        e2 has been destroyed,
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!
  integer         i          ,j          ,l          ,m          , &
                  n          ,ii         ,l1         ,mml        , &
                  ierr
  real            d(n)       ,e2(n)
  real            b          ,c          ,f          ,g          , &
                  h          ,p          ,r          ,s          , &
                  machep
!
  common /cblkt/  npp        ,k          ,machep     ,cnv        , &
                  nm         ,ncmplx     ,ik
!
  ierr = 0
  if (n == 1) go to 150
!
  do  10 i=2,n
     e2(i-1) = e2(i)*e2(i)
   10 continue
!
  f = 0.0
  b = 0.0
  e2(n) = 0.0
!
  do 120 l=1,n
     j = 0
     h = machep*(abs(d(l))+sqrt(e2(l)))
     if (b > h) go to  20
     b = h
     c = b*b
!
!  look for small squared sub-diagonal element.
!
   20    do  30 m=l,n
        if (e2(m) <= c) go to  40
!
!  e2(n) is always zero, so there is no exit
!                through the bottom of the loop.
!
   30    continue
!
   40    if (m == l) go to  80
   50    if (j == 30) go to 140
     j = j+1
!
!  form shift.
!
     l1 = l+1
     s = sqrt(e2(l))
     g = d(l)
     p = (d(l1)-g)/(2.0*s)
     r = sqrt(p*p+1.0)
     d(l) = s/(p+sign(r,p))
     h = g-d(l)
!
     do  60 i=l1,n
        d(i) = d(i)-h
   60    continue
!
     f = f+h
!
!  rational ql transformation.
!
     g = d(m)
     if (g == 0.0) g = b
     h = g
     s = 0.0
     mml = m-l
!
!  for i=m-1 step -1 until l do
!
     do  70 ii=1,mml
        i = m-ii
        p = g*h
        r = p+e2(i)
        e2(i+1) = s*r
        s = e2(i)/r
        d(i+1) = h+s*(h+d(i))
        g = d(i)-e2(i)/g
        if (g == 0.0) g = b
        h = g*p/r
   70    continue
!
     e2(l) = s*g
     d(l) = h
!
!  guard against underflowed h.
!
     if (h == 0.0) go to  80
     if (abs(e2(l)) <= abs(c/h)) go to  80
     e2(l) = h*e2(l)
     if (e2(l) /= 0.0) go to  50
   80    p = d(l)+f
!
!  order eigenvalues.
!
     if (l == 1) go to 100
!
!  for i=l step -1 until 2 do
!
     do  90 ii=2,l
        i = l+2-ii
        if (p >= d(i-1)) go to 110
        d(i) = d(i-1)
   90    continue
!
  100    i = 1
  110    d(i) = p
  120 continue
!
  if (abs(d(n)) >= abs(d(1))) go to 150
  nhalf = n/2
  do 130 i=1,nhalf
     ntop = n-i
     dhold = d(i)
     d(i) = d(ntop+1)
     d(ntop+1) = dhold
  130 continue
  go to 150
!
!  set error -- no convergence to an
!                eigenvalue after 30 iterations.
!
  140 ierr = l
  150 return
end
subroutine tred1(nm,n,a,d,e,e2)
!
!*******************************************************************************
!
!! TRED1 is a translation of the algol procedure tred1,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix
!     to a symmetric tridiagonal matrix using
!     orthogonal similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        a contains the real symmetric input matrix.  only the
!          lower triangle of the matrix need be supplied.
!
!     on output-
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction in its strict lower
!          triangle.  the full upper triangle of a is unaltered,
!
!        d contains the diagonal elements of the tridiagonal matrix,
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero,
!
!        e2 contains the squares of the corresponding elements of e.
!          e2 may coincide with e if the squares are not needed.
!
  integer i,j,k,l,n,ii,nm,jp1
  real a(nm,n),d(n),e(n),e2(n)
  real f,g,h,scale
!     real sqrt,abs
!
  do 100 i = 1, n
  100 d(i) = a(i,i)
!  for i=n step -1 until 1 do --
  do 300 ii = 1, n
     i = n + 1 - ii
     l = i - 1
     h = 0.0
     scale = 0.0
     if (l < 1) go to 130
!
!  scale row
!
     do 120 k = 1, l
  120    scale = scale + abs(a(i,k))
!
     if (scale /= 0.0) go to 140
  130    e(i) = 0.0
     e2(i) = 0.0
     go to 290
!
  140    do 150 k = 1, l
        a(i,k) = a(i,k) / scale
        h = h + a(i,k) * a(i,k)
  150    continue
!
     e2(i) = scale * scale * h
     f = a(i,l)
     g = sqrt(h)
     if (f >= 0.0) g = -g
     e(i) = scale * g
     h = h - f * g
     a(i,l) = f - g
     if (l == 1) go to 270
     f = 0.0
!
     do 240 j = 1, l
        g = 0.0
!  form element of a*u.
        do 180 k = 1, j
  180       g = g + a(j,k) * a(i,k)
!
        jp1 = j + 1
        if (l < jp1) go to 220
!
        do 200 k = jp1, l
  200       g = g + a(k,j) * a(i,k)
!  form element of p.
  220       e(j) = g / h
        f = f + e(j) * a(i,j)
  240    continue
!
     h = f / (h + h)
!  form reduced a.
     do 260 j = 1, l
        f = a(i,j)
        g = e(j) - h * f
        e(j) = g
!
        do 260 k = 1, j
           a(j,k) = a(j,k) - f * e(k) - g * a(i,k)
  260    continue
!
  270    do 280 k = 1, l
  280    a(i,k) = scale * a(i,k)
!
  290    h = d(i)
     d(i) = a(i,i)
     a(i,i) = h
  300 continue
!
  return
end
subroutine tred2(nm,n,a,d,e,z)
!
!*******************************************************************************
!
!! TRED2 is a translation of the algol procedure tred2,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix to a
!     symmetric tridiagonal matrix using and accumulating
!     orthogonal similarity transformations.
!
!     on input-
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement,
!
!        n is the order of the matrix,
!
!        a contains the real symmetric input matrix.  only the
!          lower triangle of the matrix need be supplied.
!
!     on output-
!
!        d contains the diagonal elements of the tridiagonal matrix,
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero,
!
!        z contains the orthogonal transformation matrix
!          produced in the reduction,
!
!        a and z may coincide.  if distinct, a is unaltered.
!
  integer i,j,k,l,n,ii,nm,jp1
  real a(nm,n),d(n),e(n),z(nm,n)
  real f,g,h,hh,scale
!     real sqrt,abs
!
  do 100 i = 1, n
!
     do 100 j = 1, i
        z(i,j) = a(i,j)
  100 continue
!
  if (n == 1) go to 320
!  for i=n step -1 until 2 do
  do 300 ii = 2, n
     i = n + 2 - ii
     l = i - 1
     h = 0.0
     scale = 0.0
     if (l < 2) go to 130
!  scale row.
     do 120 k = 1, l
  120    scale = scale + abs(z(i,k))
!
     if (scale /= 0.0) go to 140
  130    e(i) = z(i,l)
     go to 290
!
  140    do 150 k = 1, l
        z(i,k) = z(i,k) / scale
        h = h + z(i,k) * z(i,k)
  150    continue
!
     f = z(i,l)
     g = sqrt(h)
     if (f >= 0.0) g = -g
     e(i) = scale * g
     h = h - f * g
     z(i,l) = f - g
     f = 0.0
!
     do 240 j = 1, l
        z(j,i) = z(i,j) / h
        g = 0.0
!  form element of a*u.
        do 180 k = 1, j
  180       g = g + z(j,k) * z(i,k)
!
        jp1 = j + 1
        if (l < jp1) go to 220
!
        do 200 k = jp1, l
  200       g = g + z(k,j) * z(i,k)
!  form element of p.
  220       e(j) = g / h
        f = f + e(j) * z(i,j)
  240    continue
!
     hh = f / (h + h)
!  form reduced a.
     do 260 j = 1, l
        f = z(i,j)
        g = e(j) - hh * f
        e(j) = g
!
        do 260 k = 1, j
           z(j,k) = z(j,k) - f * e(k) - g * z(i,k)
  260    continue
!
  290    d(i) = h
  300 continue
!
  320 d(1) = 0.0
  e(1) = 0.0
!  accumulation of transformation matrices.
  do 500 i = 1, n
     l = i - 1
     if (d(i) == 0.0) go to 380
!
     do 360 j = 1, l
        g = 0.0
!
        do 340 k = 1, l
  340       g = g + z(i,k) * z(k,j)
!
        do 360 k = 1, l
           z(k,j) = z(k,j) - g * z(k,i)
  360    continue
!
  380    d(i) = z(i,i)
     z(i,i) = 1.0
     if (l < 1) go to 500
!
     do 400 j = 1, l
        z(i,j) = 0.0
        z(j,i) = 0.0
  400    continue
!
  500 continue
!
  return
end
subroutine tred3(n,nv,a,d,e,e2)
!
!*******************************************************************************
!
!! TRED3 is a translation of the algol procedure tred3,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix, stored as
!     a one-dimensional array, to a symmetric tridiagonal matrix
!     using orthogonal similarity transformations.
!
!     on input-
!
!        n is the order of the matrix,
!
!        nv must be set to the dimension of the array parameter a
!          as declared in the calling program dimension statement,
!
!        a contains the lower triangle of the real symmetric
!          input matrix, stored row-wise as a one-dimensional
!          array, in its first n*(n+1)/2 positions.
!
!     on output-
!
!        a contains information about the orthogonal
!          transformations used in the reduction,
!
!        d contains the diagonal elements of the tridiagonal matrix,
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero,
!
!        e2 contains the squares of the corresponding elements of e.
!          e2 may coincide with e if the squares are not needed.
!
  integer i,j,k,l,n,ii,iz,jk,nv
  real a(nv),d(n),e(n),e2(n)
  real f,g,h,hh,scale
!     real sqrt,abs
!
!  for i=n step -1 until 1 do --
!
  do  300 ii = 1, n
     i = n + 1 - ii
     l = i - 1
     iz = (i * l) / 2
     h = 0.0
     scale = 0.0
     if (l < 1) go to 130
!  scale row.
     do 120 k = 1, l
        iz = iz + 1
        d(k) = a(iz)
        scale = scale + abs(d(k))
  120    continue
!
     if (scale /= 0.0) go to 140
  130    e(i) = 0.0
     e2(i) = 0.0
     go to 290
!
  140    do 150 k = 1, l
        d(k) = d(k) / scale
        h = h + d(k) * d(k)
  150    continue
!
     e2(i) = scale * scale * h
     f = d(l)
     g = sqrt(h)
     if (f >= 0.0) g = -g
     e(i) = scale * g
     h = h - f * g
     d(l) = f - g
     a(iz) = scale * d(l)
     if (l == 1) go to 290
     f = 0.0
!
     do 240 j = 1, l
        g = 0.0
        jk = (j * (j-1)) / 2
!  form element of a*u.
        do 180 k = 1, l
           jk = jk + 1
           if (k > j) jk = jk + k - 2
           g = g + a(jk) * d(k)
  180       continue
!  form element of p.
        e(j) = g / h
        f = f + e(j) * d(j)
  240    continue
!
     hh = f / (h + h)
     jk = 0
!  form reduced a.
     do 260 j = 1, l
        f = d(j)
        g = e(j) - hh * f
        e(j) = g
!
        do 260 k = 1, j
           jk = jk + 1
           a(jk) = a(jk) - f * e(k) - g * d(k)
  260    continue
!
  290    d(i) = a(iz+1)
     a(iz+1) = scale * sqrt(h)
  300 continue
!
  return
end
subroutine trislv(nm, n, u, v, l, f, temp, ierr)
!
!*******************************************************************************
!
!! TRISLV backsolves a system of the form uy + vyl = f,
!  where u and v are upper triangular, and
!     l is lower triangular.
!
!
!     on entry,
!
!     nm   is the leading dimension of the matrices u, v, l and f in
!          the main program.
!
!     n    is the order of the matrices u, v, l and f.
!
!     u    contains an upper triangular matrix.  it is the left
!          coefficient of y in the first term in uy + vyl.
!
!     v    contains an upper triangular matrix.  it is the left
!          coefficient of y in the second term of uy + vyl.
!
!     l    contains a lower triangular matrix.  it is the right
!          coefficient of y in the second term of uy + vyl.
!
!     f    contains the right hand side of uy + vyl = f.
!
!     temp contains a work vector of length at least n.
!
!     on return,
!
!     f    contains the solution y.
!
!     ierr is an error return designating inconsistency of the
!          original system.
!          ierr==0 for a normal return.
!          ierr==1 if the triangular system is inconsistent.
!
!
  integer i, ierr, j, jp1, k, kk, km1, m, n, nm, nm1
  complex u(nm,n), v(nm,n), l(nm,n), f(nm,n)
  complex temp(n)
  complex denom, sum
  real s, t
!     real cabs
!     complex cmplx
  ierr = 0
  nm1 = n - 1
  do 120 kk=1,n
!  backsubstitute for row k.
    k = n - kk + 1
    if (cabs(f(k,n))/=0.0) go to 10
    f(k,n) = cmplx(0.0,0.0)
    go to 30
   10   denom = u(k,k) + v(k,k)*l(n,n)
    s = cabs(denom)
    t = 1.0 + s/cabs(f(k,n))
    if (t > 1.0) go to 20
    ierr = 1
    return
   20   f(k,n) = f(k,n)/denom
    if (n==1) return
   30   do 70 i=1,nm1
      j = n - i
      jp1 = j + 1
      sum = cmplx(0.0,0.0)
      do 40 m=jp1,n
        sum = sum + f(k,m)*l(m,j)
   40     continue
      sum = f(k,j) - v(k,k)*sum
      if (cabs(sum)/=0.0) go to 50
      f(k,j) = cmplx(0.0,0.0)
      go to 70
   50     denom = u(k,k) + v(k,k)*l(j,j)
      s = cabs(denom)
      t = 1.0 + s/cabs(sum)
      if (t > 1.0) go to 60
      ierr = 1
      return
   60     f(k,j) = sum/denom
   70   continue
!  form temp = yk-trans*l.
    if (k==1) return
    km1 = k - 1
    do 90 i=1,n
      temp(i) = cmplx(0.0,0.0)
      do 80 j=1,n
        temp(i) = temp(i) + f(k,j)*l(j,i)
   80     continue
   90   continue
!  prepare f' which is (k-1) by n.
    do 110 i=1,km1
      do 100 j=1,n
        f(i,j) = f(i,j) - u(i,k)*f(k,j) - v(i,k)*temp(j)
  100     continue
  110   continue
  120 continue
  return
end
subroutine trisp (n,a,b,c,d,u,z)
!
!*******************************************************************************
!
!! TRISP solves for a non-zero eigenvector corresponding to the zero eigenvalue
!  of the transpose of the rank
!     deficient one matrix with subdiagonal a, diagonal b, and
!     superdiagonal c , with a(1) in the (1,n) position, with
!     c(n) in the (n,1) position, and all other elements zero.
!
  dimension       a(n)       ,b(n)       ,c(n)       ,d(n)       , &
                  u(n)       ,z(n)
!
  bn = b(n)
  d(1) = a(2)/b(1)
  v = a(1)
  u(1) = c(n)/b(1)
  nm2 = n-2
  do  10 j=2,nm2
     den = b(j)-c(j-1)*d(j-1)
     d(j) = a(j+1)/den
     u(j) = -c(j-1)*u(j-1)/den
     bn = bn-v*u(j-1)
     v = -v*d(j-1)
   10 continue
  den = b(n-1)-c(n-2)*d(n-2)
  d(n-1) = (a(n)-c(n-2)*u(n-2))/den
  an = c(n-1)-v*d(n-2)
  bn = bn-v*u(n-2)
  den = bn-an*d(n-1)
!
!     set last component equal to one
!
  z(n) = 1.0
  z(n-1) = -d(n-1)
  nm1 = n-1
  do  20 j=2,nm1
     k = n-j
     z(k) = -d(k)*z(k+1)-u(k)*z(n)
   20 continue
  return
end
function trp(a,n,x,y)
!
!*******************************************************************************
!
!! TRP ???
!
  dimension x(n),y(n)
!
  nm1 = n-1
  if (a < x(2)) go to 50
  if (a >= x(nm1)) go to 40
  il = 2
  ir = nm1
!
!     bisection search
!
   10 i = (il+ir)/2
  if (i==il) go to 60
  if (a-x(i)) 20,60,30
   20 ir = i
  go to 10
   30 il = i
  go to 10
!
!     a < x(2) .or. a >= x(n-1)
!
   40 i = nm1
  go to 60
   50 i = 1
!
!     evaluation
!
   60 r = (a-x(i))/(x(i+1)-x(i))
  trp = y(i)+r*(y(i+1)-y(i))
  return
end
subroutine tslv (m0,n,a,ia,ja,b,r,c,max2,x,iwk,wk,ierr)
!
!*******************************************************************************
!
!! TSLV: solution of real sparse equations
!
!     tslv employs gaussian elimination with column interchanges to
!     solve the nxn linear system xa = b. the argument m0 specifies
!     if tslv is being called for the first time, or if it is being
!     recalled where a is the same matrix but b has been modified.
!     on an initial call to the routine (when m0=0) the lu decompo-
!     sition of a is obtained where u is a unit upper triangular
!     matrix. then the equations are solved. on subsequent calls
!     (when m0/=0) the equations are solved using the decomposition
!     obtained on the initial call to tslv.
!
!
!     input arguments when m0=0 ---
!
!     n        number of equations and unknowns.
!
!     a,ia,ja  the matrix a stored in sparse form.
!
!     b        array of n entries containing the right hand side data.
!
!     r        integer array of n entries specifying the order of
!              the rows of a.
!
!     c        integer array of n entries specifying a suggested
!              order of the columns. c is also an output argument.
!
!     max2     integer specifying the maximum number of off-diagonal
!              nonzero entries of l and u which may be stored.
!
!
!     output arguments when m0=0 ---
!
!     c        integer array of n entries specifying the order of
!              the columns that was selected by the routine.
!
!     x        real array of n entries containing the solution.
!              b and x may share the same storage area.
!
!     ierr     integer specifying the status of the results. if the
!              solution of ax = b is obtained then ierr = max(1,m)
!              where m is the total number of off-diagonal nonzero
!              entries of l and u. otherwise ierr <= 0.
!
!
!     general storage areas ---
!
!     iwk      integer array of dimension 4*n + max2 + 2.
!
!     wk       real array of dimension 2*n + max2.
!
!
!     after an initial call to tslv, the routine may be recalled with
!     m0/=0 for a new b. when m0/=0 it is assumed that n,a,ia,ja,
!     r,c,iwk,wk have not been modified. the routine retrieves the lu
!     decomposition which was obtained on the initial call to tslv
!     and solves the new equations xa = b. in this case a,ia,ja,max2,
!     and ierr are not referenced.
!
  real a(*), b(n), x(n), wk(*)
  integer ia(*), ja(*), iwk(*)
  integer r(n), c(n), y, t, p
!
!     set indices to divide temporary storage
!
  y = n + 1
  t = y + n
  p = n + 1
  it = p + n + 1
  iu = it + n + 1
  jt = iu + n
  if (m0 /= 0) go to 20
!
!     compute the inverse permutation of c
!
  ierr = 0
  if (n <= 0) return
  do 10 k = 1,n
     l = c(k)
     iwk(l) = k
   10 continue
!
!     obtain the lu decomposition of a
!
  call splu (a,ia,ja,r,c,iwk(1),n,max2,wk(1),wk(t),iwk(it),iwk(jt), &
               iwk(iu),wk(y),iwk(p),ierr)
  if (ierr < 0) return
  ierr = max (1,ierr)
!
!     solve the system of equations
!
   20 call tslv1 (n,r,c,iwk(1),wk(1),wk(t),iwk(it),iwk(jt),iwk(iu), &
                    b,x,wk(y))
  return
end
subroutine tslv1 (n,r,c,ic,d,t,it,jt,iu,b,x,y)
!
!*******************************************************************************
!
!! TSLV1 solves yu = b by forward substitution
!
  integer r(n), c(n), ic(n)
  integer it(*), jt(*), iu(n)
  real b(n), d(n), t(*), x(n), y(n)
!
  do 10 k = 1,n
     lk = c(k)
     y(k) = b(lk)
   10 continue
!
  do 21 k = 1,n
     if (y(k) == 0.0) go to 21
     jmin = iu(k)
     jmax = it(k+1) - 1
     if (jmin > jmax) go to 21
     do 20 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   20    continue
   21 continue
!
!            solve xl = y by backward substitution
!
  x(n) = y(n)/d(n)
  if (n == 1) return
!
  k = n
  y(n) = x(n)
  do 32 i = 2,n
     jmin = it(k)
     jmax = iu(k) - 1
     if (jmin > jmax) go to 31
     do 30 jj = jmin,jmax
        lj = jt(jj)
        j = ic(lj)
        y(j) = y(j) - t(jj)*y(k)
   30    continue
   31    k = k - 1
     y(k) = y(k)/d(k)
   32 continue
!
  do 40 k = 1,n
     lk = r(k)
     x(lk) = y(k)
   40 continue
  return
end
subroutine urng (ix, x, n, ierr)
!
!*******************************************************************************
!
!! URNG: uniform random number generator
!
!
!  urng uses the recursion
!
!                       ix = ix*a mod p
!
!     it is assumed that 0 < ix  <  p
!
!     written by
!        linus schrage
!        university of chicago
!     adapted by a.h. morris (nswc)
!
  integer a, b15, b16, fhi, p, xalo, xhi
  real x(n)
!
!     data a/7**5/,  b15/2**15/, b16/2**16/, p/2**31 - 1/
!
  data a/16807/, b15/32768/, b16/65536/, p/2147483647/
  data s/.465661e-09/
!
  if (n <= 0) go to 100
  if (ix <= 0 .or. ix >= p) go to 110
  ierr = 0
  do 10 l = 1,n
!
!                 get 15 high order bits of ix
!
  xhi = ix/b16
!
!           get 16 lower bits of ix and multiply with a
!
  xalo = (ix - xhi*b16)*a
!
!             get 15 high order bits of the product
!
  leftlo = xalo/b16
!
!               form the 31 highest bits of a*ix
!
  fhi = xhi*a + leftlo
!
!           obtain the overflow past the 31st bit of a*ix
!
  k = fhi/b15
!
!             assemble all the parts and presubtract p
!                  the parentheses are essential
!
  ix = (((xalo - leftlo*b16) - p) + (fhi - k*b15)*b16) + k
!
!                      add p if necessary
!
  if (ix < 0) ix = ix + p
!
!     rescale ix, to interpret it as a value between 0 and 1.
!     the scale factor s is selected to be as near 1/p as is
!     appropriate in order that the floating value for ix = 1,
!     namely s, be roughly the same distance from 0 as (p-1)*s
!     is from 1. the current value for s assures us that x(l)
!     is less than 1 for any floating point arithmetic of 6
!     or more digits.
!
   10 x(l) = real(ix)*s
  return
!
!                         error return
!
  100 ierr = 1
  return
  110 ierr = 2
  return
end
subroutine valr2(x,y,n0,p,iop,a,ind,ko)
!
!*******************************************************************************
!
!! VALR2 ???
!
!
  dimension x(*),y(*),g(2),h(2)
  dimension e(5),e2(10),e3(15)
  dimension aph1(3),aph2(3),aph4(3)
  dimension rsq(3),a3d8(3),cst(3)
  real kom,l
!
  data pi/3.1415926535898/
  data twopi/6.28318530717958/
  data alnpi/1.14472988584940/
  data rtpi/1.77245385090552/
  data rtpii/.56418958354776/
!
  data e(1)/.885777518572895e+00/,  e(2)/-.981151952778050e+00/, &
       e(3)/.759305502082485e+00/,  e(4)/-.353644980686977e+00/, &
       e(5)/.695232092435207e-01/
  data e2(1) /.886226470016632e+00/,  e2(2) /-.999950714561036e+00/, &
       e2(3) /.885348820003892e+00/,  e2(4) /-.660611239043357e+00/, &
       e2(5) /.421821197160099e+00/,  e2(6) /-.222898055667208e+00/, &
       e2(7) /.905057384150449e-01/,  e2(8) /-.254906111884287e-01/, &
       e2(9) /.430895168984138e-02/,  e2(10)/-.323377239693247e-03/
  data e3(1) /.886226924931465e+00/,  e3(2) /-.999999899776252e+00/, &
       e3(3) /.886223733186722e+00/,  e3(4) /-.666626670510907e+00/, &
       e3(5) /.442851899328569e+00/,  e3(6) /-.265638206366025e+00/, &
       e3(7) /.145060043403014e+00/,  e3(8) /-.714909837799889e-01/, &
       e3(9) /.309199295521210e-01/,  e3(10)/-.112323532148441e-01/, &
       e3(11)/.324944543171185e-02/,  e3(12)/-.704260243309096e-03/, &
       e3(13)/.105787574480633e-03/,  e3(14)/-.971864864160461e-05/, &
       e3(15)/.408335517232165e-06/
  data aph1(1)/2.02e-7/, aph1(2)/2.08e-13/, aph1(3)/2.71e-19/
  data aph2(1)/1.22e-2/, aph2(2)/1.23e-4/, aph2(3)/1.34e-6/
  data aph4(1)/.6962e-1/, aph4(2)/.6990e-2/, aph4(3)/.7311e-3/
  data rsq(1)/6.0516/, rsq(2)/12.60605/, rsq(3)/19.201924/
  data a3d8(1)/0.28125e-4/, a3d8(2)/0.285e-7/, a3d8(3)/0.32625e-10/
  data cst(1)/.5625e-4/, cst(2)/.57e-7/, cst(3)/.6512e-10/
!
!     tau is a machine dependent tolerance. it is assumed that a
!     7 or more digit floating point arithmetic is being used.
!
  tau = 2.0 * epsilon ( tau )
  if (tau < 3.e-11) tau=max ( 5.0*tau,1.e-14)
!
  n=n0
  if (n==2.or.n < 1) go to 4021
  tausq=tau*tau
!
  p=0.0
  ind=0
  a=0.0
  kom=0.0
  k=1
  if (n/=1) go to 10
!
  w=x(2)-x(1)
  z=y(2)-y(1)
  u=x(3)-x(1)
  v=y(3)-y(1)
  xk=0.0
  psi1=v*w-u*z
  if (psi1 >= 0.0) go to 21
!
  p=-1.0
  t1=w
  w=u
  u=t1
  t1=v
  v=z
  z=t1
  go to 21
!
   10 ko=0
  x(n+1)=x(1)
  y(n+1)=y(1)
  u=x(2)-x(1)
  v=y(2)-y(1)
  xk=x(1)
  yk=y(1)
!
   20 w=x(1)-x(n)
  z=y(1)-y(n)
   21 d1sq=w*w+z*z
  if (d1sq > tausq) go to 30
  if (n==1) go to 4011
  n=n-1
  if (n==2) return
  go to 20
!
   30 d2sq=u*u+v*v
  if (d2sq > tausq) go to 40
  if (n==1) go to 4011
   31 k=k+1
  u=x(k+1)-xk
  v=y(k+1)-yk
  d2sq=u*u+v*v
  if (d2sq <= tausq) go to 31
  if (k==n-1) return
!
   40 a=xk*(y(k+1)-y(n))
  bgd1=sqrt(d1sq+d1sq)
  bgd2=sqrt(d2sq+d2sq)
!
!             processing vertex (xk,yk)
!
   50 psi1=v*w-u*z
  cee=u*w+v*z
  aj0=atan2(psi1,cee)
  kom=kom+aj0
  l=0.0
  b=.5*(x(k)*x(k)+y(k)*y(k))
  if (b > aph1(iop)) go to 60
  p1=aj0/twopi
  go to 3621
!
   60 g(1)=(w*x(k)+z*y(k))/bgd1
  g(2)=(u*x(k)+v*y(k))/bgd2
  h(1)=(-y(k)*w+x(k)*z)/bgd1
  h(2)=(-y(k)*u+x(k)*v)/bgd2
  if (abs(psi1) > bgd1*bgd2*a3d8(iop)) go to 80
  if (cee < 0.0) go to 70
  if (abs(aj0) > tau.and.g(1) < 0.0) go to 80
  p1=0.0
  go to 3621
!
   70 if (abs(psi1) <= (.5*tau*bgd1*bgd2)) ind=2
  if (psi1 < 0.0) go to 71
  p1=.5*erfc1(0,h(2))
  go to 3621
   71 p1=-.5*erfc1(0,h(1))
  go to 3621
!
   80 if (b > aph2(iop)) go to 90
  c=rtpi*(h(2)-h(1))-(g(2)*h(2)-g(1)*h(1))
  p1=(aj0-c)/twopi
  go to 3621
!
!                 computation of l
!
   90 if (g(1) < 0.0) go to 100
  if (g(2) >= 0.0) go to 130
  g(2)=-g(2)
  h(2)=-h(2)
  if (abs(h(2)) <= aph4(iop)) go to 91
  l=.5*erfc1(0,-h(2))
  go to 120
   91 l=.5+rtpii*h(2)
  go to 120
!
  100 g(1)=-g(1)
  h(1)=-h(1)
  if (g(2) < 0.0) go to 110
  if (abs(h(1)) <= aph4(iop)) go to 101
  l=.5*erfc1(0,h(1))
  go to 120
  101 l=.5-rtpii*h(1)
  go to 120
!
  110 g(2)=-g(2)
  h(2)=-h(2)
  if (abs(h(1)) <= aph4(iop)) go to 112
  if (abs(h(2)) <= aph4(iop)) go to 111
  l=.5*(erfc1(0,h(1))-erfc1(0,h(2)))
  go to 130
  111 l=rtpii*h(2)-.5*erf(h(1))
  go to 130
  112 if (abs(h(2)) <= aph4(iop)) go to 113
  l=.5*erf(h(2))-rtpii*h(1)
  go to 130
  113 l=rtpii*(h(2)-h(1))
  go to 130
!
  120 psi1=-psi1
  if (psi1 <= 0.0) go to 121
  l=l-1.0
  aj0=aj0+pi
  go to 130
  121 aj0=aj0-pi
!
!                 series evaluation
!
  130 if (b >= rsq(iop)) go to 171
  cape=aj0
  caph=.5*aj0
  m=1
  f=0.0
  aj1=h(2)-h(1)
  circm=aj1
  if (iop-2) 140,150,160
!
  140 sum=e(m)*aj1
  141 m=m+1
  h(1)=h(1)*g(1)
  h(2)=h(2)*g(2)
  t=h(2)-h(1)
  f=f+b
  capv=(f*cape+t)/m
  sum=sum+e(m)*capv
  if (m >= 5) go to 170
  cape=circm
  circm=capv
  go to 141
!
  150 sum=e2(m)*aj1
  151 m=m+1
  h(1)=h(1)*g(1)
  h(2)=h(2)*g(2)
  t=h(2)-h(1)
  f=f+b
  capv=(f*cape+t)/m
  sum=sum+e2(m)*capv
  if (m >= 10) go to 170
  cape=circm
  circm=capv
  go to 151
!
  160 sum=e3(m)*aj1
  161 m=m+1
  h(1)=h(1)*g(1)
  h(2)=h(2)*g(2)
  t=h(2)-h(1)
  f=f+b
  capv=(f*cape+t)/m
  sum=sum+e3(m)*capv
  if (m >= 15) go to 170
  cape=circm
  circm=capv
  go to 161
!
  170 p1=l+exp(-(b+alnpi))*(caph-sum)
  go to 3621
  171 p1=l
!
!               standard termination
!
 3621 if (k/=n) go to 3651
  if (n/=1) go to 3631
  p=abs(p+abs(p1))
  return
!
 3631 p=p-p1
  kom=kom/twopi
  a=.5*a
  if (kom < 0.0) go to 3641
  ko=int(kom+.125)
  go to 3645
 3641 ko=int(kom-.125)
 3645 p=p+real(ko)
  return
!
!              set up the next vertex
!
 3651 w=u
  z=v
  bgd1=bgd2
  xk=x(k+1)
  yk=y(k+1)
  ykm1=y(k)
 3661 k=k+1
  u=x(k+1)-xk
  v=y(k+1)-yk
  d2sq=u*u+v*v
  if (d2sq <= tausq) go to 3661
  bgd2=sqrt(d2sq+d2sq)
  p=p-p1
  a=a+xk*(y(k+1)-ykm1)
  go to 50
!
!                  error return
!
 4011 ind=1
  p=5.0
  return
 4021 ind=3
  return
end
function vnorm(v,ncomp)
!
!*******************************************************************************
!
!! VNORM computes the maximum norm of the vector v(*) of length ncomp and
!     return the result as vnorm
!
  dimension v(ncomp)
  real vnorm
!
  vnorm=0.0
  do 10 k=1,ncomp
   10   vnorm=max ( vnorm,abs(v(k)))
  return
end
function vnwrms (n, v, w)
!
!*******************************************************************************
!
!! VNWRMS computes the weighted root-mean-square norm
! of the vector of length n contained in the array v, with weights
! contained in the array w of length n..
!   vnwrms = sqrt( (1/n) * sum( v(i)/w(i) )**2 )
!
  integer n, i
  real v
  real vnwrms
  real w, sum
  dimension v(n), w(n)
!
  sum = 0.0e0
  do 10 i = 1,n
 10     sum = sum + (v(i)/w(i))**2
  vnwrms = sqrt(sum/real(n))
  return
end
subroutine vrshft(l3,zr,zi,conv,nn,pr,pi,hr,hi,qpr,qpi,qhr,qhi, &
                    sr,si,tr,ti,pvr,pvi,are,mre,eta,infin)
!
!*******************************************************************************
!
!! VRSHFT carries out the third stage iteration.
!
!     l3 - limit of steps in stage 3.
!     zr,zi - on entry contain the initial iterate. if the
!             iteration converges zr,zi contain the final
!             iterate on exit.
!     conv  - the value is .true. if the iteration converges.
!
  double precision sr,si,tr,ti,pvr,pvi,are,mre,eta,infin, &
               pr(nn),pi(nn),qpr(nn),qpi(nn),hr(nn),hi(nn), &
               qhr(nn),qhi(nn)
  double precision zr,zi,mp,ms,omp,relstp,r1,r2,tp,errev,dcpabs
  logical conv,b,bool
!
  conv = .false.
  b = .false.
  sr = zr
  si = zi
  n = nn - 1
!
!     main loop for stage 3.
!
  do 60 i = 1,l3
!
!     evaluate p at s and test for convergence.
!
     call polyev(nn,sr,si,pr,pi,qpr,qpi,pvr,pvi)
     mp = dcpabs(pvr,pvi)
     ms = dcpabs(sr,si)
     if (mp > 20.d0*errev(nn,qpr,qpi,ms,mp,are,mre)) &
        go to 10
!
!     polynomial value is smaller than a bound on the error
!     in evaluating p. terminate the iteration.
!
        conv = .true.
        zr = sr
        zi = si
        return
!
   10    if (i == 1) go to 40
     if (b .or. mp < omp .or. relstp >= 0.05d0) &
        go to 30
!
!     iteration has stalled. probably a cluster of zeros. do 5 fixed
!     shift steps into the cluster to force one zero to dominate.
!
     tp = relstp
     b = .true.
     if (relstp < eta) tp = eta
     r1 = dsqrt(tp)
     r2 = sr*(1.d0 + r1) - si*r1
     si = sr*r1 + si*(1.d0 + r1)
     sr = r2
     call polyev(nn,sr,si,pr,pi,qpr,qpi,pvr,pvi)
     do 20 j = 1,5
        call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
        call nexth(bool,n,tr,ti,hr,hi,qpr,qpi,qhr,qhi)
   20    continue
     omp = infin
     go to 50
!
!     exit if the polynomial value increases significantly.
!
   30    if (0.1d0*mp > omp) return
!
!     calculate the next iterate.
!
   40    omp = mp
!
   50    call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
     call nexth(bool,n,tr,ti,hr,hi,qpr,qpi,qhr,qhi)
     call calct(bool,n,sr,si,tr,ti,pvr,pvi,are,hr,hi,qhr,qhi)
     if (bool) go to 60
     relstp = dcpabs(tr,ti)/dcpabs(sr,si)
     sr = sr + tr
     si = si + ti
   60 continue
  return
end
subroutine wandt ( wv, tv, n, a, b )

!*******************************************************************************
!
!! WANDT returns weights and abscissas for gauss-legendre quadrature.
!
!  Discussion:
!
!    integration weights and nodes are to be calculated and stored in
!    wv and tv, respectively. n is assumed to be a power of two. if
!    2 <= n <= 256, then gaussian quadrature is used. if n  > 
!    256, then the interval (a,b) is divided n/256 times and the 256
!    point formula is applied to each subinterval.
!
!  Modified:
!
!    25 April 2006
!
!  Parameters:
!
!    Output, real WV(N), TV(N), the weights and abscissas for 
!    Gauss-Legendre quadrature.
!
!    Input, integer N, the order of the quadrature rule.  Normally,
!    N is a power of 2 satisfying 1 <= N <= 256.
!
!    Input, real A, B, the left and right endpoints of the interval.
!
  real t(255)
  real tv(n)
  real w(255)
  real wv(n)

  data t(1),t(2),t(3),t(4),t(5),t(6),t(7),t(8),t(9),t(10),t(11), &
       t(12),t(13),t(14),t(15)/.577350269189626e0, &
    .861136311594053e0,.339981043584856e0,.960289856497536e0, &
    .796666477413627e0,.525532409916329e0,.183434642495650e0, &
    .989400934991650e0,.944575023073233e0,.865631202387832e0, &
    .755404408355003e0,.617876244402644e0,.458016777657227e0, &
    .281603550779259e0,.950125098376374e-1/
  data t(16),t(17),t(18),t(19),t(20),t(21),t(22),t(23),t(24),t(25), &
       t(26),t(27),t(28),t(29),t(30),t(31)/.997263861849482e0, &
    .985611511545268e0,.964762255587506e0,.934906075937740e0, &
    .896321155766052e0,.849367613732570e0,.794483795967942e0, &
    .732182118740290e0,.663044266930215e0,.587715757240762e0, &
    .506899908932229e0,.421351276130635e0,.331868602282128e0, &
    .239287362252137e0,.144471961582796e0,.483076656877383e-1/
  data t(32),t(33),t(34),t(35),t(36),t(37),t(38),t(39),t(40),t(41), &
       t(42),t(43),t(44),t(45),t(46),t(47)/.999305041735772e0, &
    .996340116771955e0,.991013371476744e0,.983336253884626e0, &
    .973326827789911e0,.961008799652054e0,.946411374858403e0, &
    .929569172131940e0,.910522137078503e0,.889315445995114e0, &
    .865999398154093e0,.840629296252580e0,.813265315122798e0, &
    .783972358943341e0,.752819907260532e0,.719881850171611e0/
  data t(48),t(49),t(50),t(51),t(52),t(53),t(54),t(55),t(56),t(57), &
       t(58),t(59),t(60),t(61),t(62),t(63)/.685236313054233e0, &
    .648965471254657e0,.611155355172393e0,.571895646202634e0, &
    .531279464019895e0,.489403145707053e0,.446366017253464e0, &
    .402270157963992e0,.357220158337668e0,.311322871990211e0, &
    .264687162208767e0,.217423643740007e0,.169644420423993e0, &
    .121462819296121e0,.729931217877990e-1,.243502926634244e-1/
  data t(64),t(65),t(66),t(67),t(68),t(69),t(70),t(71),t(72),t(73), &
       t(74),t(75),t(76),t(77),t(78),t(79)/.999824887947132e0, &
    .999077459977376e0,.997733248625514e0,.995792758534981e0, &
    .993257112900213e0,.990127818491734e0,.986406742724586e0, &
    .982096108435719e0,.977198491463907e0,.971716818747137e0, &
    .965654366431965e0,.959014757853700e0,.951801961341264e0, &
    .944020287830220e0,.935674388277916e0,.926769250878948e0/
  data t(80),t(81),t(82),t(83),t(84),t(85),t(86),t(87),t(88),t(89), &
       t(90),t(91),t(92),t(93),t(94),t(95),t(96),t(97)/ &
    .917310198080961e0,.907302883401757e0,.896753288049158e0, &
    .885667717345397e0,.874052796958032e0,.861915468939548e0, &
    .849262987577969e0,.836102915060907e0,.822443116955644e0, &
    .808291757507914e0,.793657294762193e0,.778548475506412e0, &
    .762974330044095e0,.746944166797062e0,.730467566741909e0, &
    .713554377683587e0,.696214708369514e0,.678458922447719e0/
  data t(98),t(99),t(100),t(101),t(102),t(103),t(104),t(105),t(106), &
       t(107),t(108),t(109),t(110),t(111),t(112),t(113),t(114)/ &
    .660297632272646e0,.641741692562308e0,.622802193910585e0, &
    .603490456158549e0,.583818021628763e0,.563796648226618e0, &
    .543438302412810e0,.522755152051175e0,.501759559136144e0, &
    .480464072404172e0,.458881419833552e0,.437024501037104e0, &
    .414906379552275e0,.392540275033267e0,.369939555349859e0, &
    .347117728597636e0,.324088435024413e0/
  data t(115),t(116),t(117),t(118),t(119),t(120),t(121),t(122), &
       t(123),t(124),t(125),t(126),t(127)/.300865438877677e0, &
    .277462620177904e0,.253893966422694e0,.230173564226660e0, &
    .206315590902079e0,.182334305985337e0,.158244042714225e0, &
    .134059199461188e0,.109794231127644e0, &
    .854636405045155e-1,.610819696041396e-1,.366637909687335e-1, &
    .122236989606158e-1/
  data t(128),t(129),t(130),t(131),t(132),t(133),t(134),t(135), &
       t(136),t(137),t(138),t(139),t(140),t(141),t(142)/ &
    .999956050018992e0,.999768437409263e0,.999430937466261e0, &
    .998943525843409e0,.998306266473006e0,.997519252756721e0, &
    .996582602023382e0,.995496454481096e0,.994260972922410e0, &
    .992876342608822e0,.991342771207583e0,.989660488745065e0, &
    .987829747564861e0,.985850822286126e0,.983724009760315e0/
  data t(143),t(144),t(145),t(146),t(147),t(148),t(149),t(150), &
       t(151),t(152),t(153),t(154),t(155),t(156),t(157)/ &
    .981449629025464e0,.979028021257622e0,.976459549719234e0, &
    .973744599704370e0,.970883578480743e0,.967876915228489e0, &
    .964725060975706e0,.961428488530732e0,.957987692411178e0, &
    .954403188769716e0,.950675515316628e0,.946805231239127e0, &
    .942792917117462e0,.938639174837814e0, .934344627502003e0/
  data t(158),t(159),t(160),t(161),t(162),t(163),t(164),t(165), &
       t(166),t(167),t(168),t(169),t(170),t(171),t(172)/ &
    .929909919334006e0,.925335715583316e0,.920622702425146e0, &
    .915771586857490e0,.910783096595065e0,.905657979960145e0, &
    .900397005770304e0,.895000963223085e0,.889470661777611e0, &
    .883806931033158e0,.878010620604707e0,.872082599995488e0, &
    .866023758466555e0,.859835004903376e0,.853517267679503e0/
  data t(173),t(174),t(175),t(176),t(177),t(178),t(179),t(180), &
       t(181),t(182),t(183),t(184),t(185),t(186),t(187)/ &
    .847071494517296e0,.840498652345763e0,.833799727155505e0, &
    .826975723850813e0,.820027666098917e0,.812956596176432e0, &
    .805763574812999e0,.798449681032171e0,.791016011989546e0, &
    .783463682808184e0,.775793826411326e0,.768007593352446e0, &
    .760106151642655e0,.752090686575492e0,.743962400549112e0/
  data t(188),t(189),t(190),t(191),t(192),t(193),t(194),t(195), &
       t(196),t(197),t(198),t(199),t(200),t(201),t(202)/ &
    .735722512885918e0,.727372259649652e0,.718912893459971e0, &
    .710345683304543e0,.701671914348685e0,.692892887742577e0, &
    .684009920426076e0,.675024344931163e0,.665937509182049e0, &
    .656750776292973e0,.647465524363725e0,.638083146272911e0, &
    .628605049469015e0,.619032655759261e0,.609367401096334e0/
  data t(203),t(204),t(205),t(206),t(207),t(208),t(209),t(210), &
       t(211),t(212),t(213),t(214),t(215),t(216),t(217)/ &
    .599610735362968e0,.589764122154454e0,.579829038559083e0, &
    .569806974936569e0,.559699434694481e0,.549507934062719e0, &
    .539234001866059e0,.528879179294822e0,.518445019673674e0, &
    .507933088228616e0,.497344961852181e0,.486682228866890e0, &
    .475946488786983e0,.465139352078479e0,.454262439917590e0/
  data t(218),t(219),t(220),t(221),t(222),t(223),t(224),t(225), &
       t(226),t(227),t(228),t(229),t(230),t(231),t(232)/ &
    .443317383947527e0,.432305826033741e0,.421229418017624e0, &
    .410089821468717e0,.398888707435459e0,.387627756194516e0, &
    .376308656998716e0,.364933107823654e0,.353502815112970e0, &
    .342019493522372e0,.330484865662417e0,.318900661840106e0, &
    .307268619799319e0,.295590484460136e0,.283868007657082e0/
  data t(233),t(234),t(235),t(236),t(237),t(238),t(239),t(240), &
       t(241),t(242),t(243),t(244),t(245),t(246),t(247)/ &
    .272102947876337e0,.260297069991943e0,.248452145001057e0, &
    .236569949758284e0,.224652266709132e0,.212700883622626e0, &
    .200717593323127e0,.188704193421389e0,.176662486044902e0, &
    .164594277567554e0,.152501378338656e0,.140385602411376e0, &
    .128248767270607e0,.116092693560333e0,.103919204810509e0/
  data   t(248),t(249),t(250),t(251),t(252),t(253),t(254),t(255)/ &
    .917301271635196e-1,.795272891002330e-1,.673125211657164e-1, &
    .550876556946340e-1,.428545265363791e-1,.306149687799790e-1, &
    .183708184788137e-1,.612391237518953e-2/
  data w(1),w(2),w(3),w(4),w(5),w(6),w(7),w(8),w(9),w(10),w(11), &
       w(12),w(13),w(14),w(15)/1.0e0,.347854845137454e0, &
    .652145154862546e0,.101228536290376e0,.222381034453374e0, &
    .313706645877887e0,.362683783378362e0,.271524594117541e-1, &
    .622535239386479e-1,.951585116824928e-1,.124628971255534e0, &
    .149595988816577e0,.169156519395003e0,.182603415044924e0, &
    .189450610455068e0/
  data w(16),w(17),w(18),w(19),w(20),w(21),w(22),w(23),w(24),w(25), &
       w(26),w(27),w(28),w(29),w(30),w(31)/.701861000947010e-2, &
    .162743947309057e-1,.253920653092621e-1,.342738629130214e-1, &
    .428358980222267e-1,.509980592623762e-1,.586840934785355e-1, &
    .658222227763618e-1,.723457941088485e-1,.781938957870703e-1, &
    .833119242269468e-1,.876520930044038e-1,.911738786957639e-1, &
    .938443990808046e-1,.956387200792749e-1,.965400885147278e-1/
  data w(32),w(33),w(34),w(35),w(36),w(37),w(38),w(39),w(40),w(41), &
       w(42),w(43),w(44),w(45),w(46),w(47)/.178328072169643e-2, &
    .414703326056247e-2,.650445796897836e-2,.884675982636395e-2, &
    .111681394601311e-1,.134630478967186e-1,.157260304760247e-1, &
    .179517157756973e-1,.201348231535302e-1,.222701738083833e-1, &
    .243527025687109e-1,.263774697150547e-1,.283396726142595e-1, &
    .302346570724025e-1,.320579283548516e-1,.338051618371416e-1/
  data w(48),w(49),w(50),w(51),w(52),w(53),w(54),w(55),w(56),w(57), &
       w(58),w(59),w(60),w(61),w(62),w(63)/ .354722132568824e-1, &
    .370551285402400e-1,.385501531786156e-1,.399537411327203e-1, &
    .412625632426235e-1,.424735151236536e-1,.435837245293235e-1, &
    .445905581637566e-1,.454916279274181e-1, .462847965813144e-1, &
   .469681828162100e-1,.475401657148303e-1,.479993885964583e-1, &
    .483447622348030e-1,.485754674415034e-1,.486909570091397e-1/
  data w(64),w(65),w(66),w(67),w(68),w(69),w(70),w(71),w(72),w(73), &
       w(74),w(75),w(76),w(77),w(78),w(79)/ .449380960292090e-3, &
    .104581267934035e-2,.164250301866903e-2,.223828843096262e-2, &
    .283275147145799e-2,.342552604091022e-2,.401625498373864e-2, &
    .460458425670296e-2,.519016183267633e-2,.577263754286570e-2, &
    .635166316170719e-2,.692689256689881e-2,.749798192563473e-2, &
    .806458989048606e-2,.862637779861675e-2,.918300987166087e-2/
  data w(80),w(81),w(82),w(83),w(84),w(85),w(86),w(87),w(88), &
   w(89),w(90),w(91),w(92),w(93),w(94),w(95)/.973415341500681e-2, &
    .102794790158322e-1,.108186607395031e-1,.113513763240804e-1, &
    .118773073727403e-1,.123961395439509e-1,.129075627392673e-1, &
    .134112712886163e-1,.139069641329520e-1,.143943450041668e-1, &
    .148731226021473e-1,.153430107688651e-1,.158037286593993e-1, &
    .162550009097852e-1,.166965578015892e-1,.171281354231114e-1/
  data w(96),w(97),w(98),w(99),w(100),w(101),w(102),w(103),w(104), &
       w(105),w(106),w(107),w(108),w(109),w(110),w(111),w(112)/ &
    .175494758271177e-1,.179603271850087e-1,.183604439373313e-1, &
    .187495869405447e-1,.191275236099509e-1,.194940280587066e-1, &
    .198488812328309e-1,.201918710421300e-1,.205227924869601e-1, &
    .208414477807511e-1,.211476464682213e-1,.214412055392085e-1, &
    .217219495380521e-1,.219897106684605e-1,.222443288937998e-1, &
    .224856520327450e-1,.227135358502365e-1/
  data w(113),w(114),w(115),w(116),w(117),w(118),w(119),w(120), &
       w(121),w(122),w(123),w(124),w(125),w(126),w(127)/ &
    .229278441436868e-1,.231284488243870e-1,.233152299940628e-1, &
    .234880760165359e-1,.236468835844476e-1,.237915577810034e-1, &
    .239220121367035e-1,.240381686810241e-1,.241399579890193e-1, &
    .242273192228152e-1,.243002001679719e-1,.243585572646906e-1, &
    .244023556338496e-1,.244315690978500e-1,.244461801962625e-1/
  data w(128),w(129),w(130),w(131),w(132),w(133),w(134),w(135), &
       w(136),w(137),w(138),w(139),w(140),w(141),w(142)/ &
    .112789017822272e-3,.262534944296446e-3,.412463254426176e-3, &
    .562348954031410e-3,.712154163473321e-3,.861853701420089e-3, &
    .101142439320844e-2,.116084355756772e-2,.131008868190250e-2, &
    .145913733331073e-2,.160796713074933e-2,.175655573633073e-2, &
    .190488085349972e-2,.205292022796614e-2,.220065164983991e-2/
  data w(143),w(144),w(145),w(146),w(147),w(148),w(149),w(150), &
       w(151),w(152),w(153),w(154),w(155),w(156),w(157)/ &
    .234805295632731e-2,.249510203470371e-2,.264177682542749e-2, &
    .278805532532771e-2,.293391559082972e-2,.307933574119934e-2, &
    .322429396179420e-2,.336876850731555e-2,.351273770505631e-2, &
    .365617995814250e-2,.379907374876626e-2,.394139764140883e-2, &
    .408313028605267e-2,.422425042138154e-2,.436473687796806e-2/
  data w(158),w(159),w(160),w(161),w(162),w(163),w(164),w(165), &
       w(166),w(167),w(168),w(169),w(170),w(171),w(172)/ &
    .450456858144790e-2,.464372455568006e-2,.478218392589269e-2, &
    .491992592181387e-2,.505692988078684e-2,.519317525086928e-2, &
    .532864159391593e-2,.546330858864431e-2,.559715603368291e-2, &
    .573016385060144e-2,.586231208692265e-2,.599358091911534e-2, &
    .612395065556793e-2,.625340173954240e-2,.638191475210788e-2/
  data w(173),w(174),w(175),w(176),w(177),w(178),w(179),w(180), &
       w(181),w(182),w(183),w(184),w(185),w(186),w(187)/ &
    .650947041505366e-2,.663604959378107e-2,.676163330017380e-2, &
    .688620269544632e-2,.700973909296982e-2,.713222396107539e-2, &
    .725363892583391e-2,.737396577381235e-2,.749318645480588e-2, &
    .761128308454566e-2,.772823794738156e-2,.784403349893971e-2, &
    .795865236875435e-2,.807207736287350e-2,.818429146643827e-2/
  data w(188),w(189),w(190),w(191),w(192),w(193),w(194),w(195), &
       w(196),w(197),w(198),w(199),w(200),w(201),w(202)/ &
    .829527784623523e-2,.840501985322154e-2,.851350102502249e-2, &
    .862070508840101e-2,.872661596169881e-2,.883121775724875e-2, &
    .893449478375821e-2,.903643154866287e-2,.913701276045081e-2, &
    .923622333095630e-2,.933404837762327e-2,.943047322573775e-2, &
    .952548341062928e-2,.961906467984073e-2,.971120299526628e-2/
  data w(203),w(204),w(205),w(206),w(207),w(208),w(209),w(210), &
       w(211),w(212),w(213),w(214),w(215),w(216),w(217)/ &
    .980188453525733e-2,.989109569669583e-2,.997882309703491e-2, &
    .100650535763064e-1,.101497741990949e-1,.102329722564782e-1, &
    .103146352679340e-1,.103947509832117e-1,.104733073841704e-1, &
    .105502926865815e-1,.106256953418966e-1,.106995040389798e-1, &
    .107717077058046e-1,.108422955111148e-1,.109112568660490e-1/
  data w(218),w(219),w(220),w(221),w(222),w(223),w(224),w(225), &
       w(226),w(227),w(228),w(229),w(230),w(231),w(232)/ &
    .109785814257296e-1,.110442590908139e-1,.111082800090098e-1, &
    .111706345765534e-1,.112313134396497e-1,.112903074958755e-1, &
    .113476078955455e-1,.114032060430392e-1,.114570935980906e-1, &
    .115092624770395e-1,.115597048540436e-1,.116084131622531e-1, &
    .116553800949452e-1,.117005986066207e-1,.117440619140606e-1/
  data w(233),w(234),w(235),w(236),w(237),w(238),w(239),w(240), &
       w(241),w(242),w(243),w(244),w(245),w(246),w(247)/ &
    .117857634973434e-1,.118256971008240e-1,.118638567340711e-1, &
    .119002366727665e-1,.119348314595636e-1,.119676359049059e-1, &
    .119986450878058e-1,.120278543565826e-1,.120552593295601e-1, &
    .120808558957245e-1,.121046402153405e-1,.121266087205273e-1, &
    .121467581157945e-1,.121650853785355e-1,.121815877594818e-1/
  data w(248),w(249),w(250),w(251),w(252),w(253),w(254),w(255)/ &
    .121962627831147e-1,.122091082480372e-1,.122201222273040e-1, &
    .122293030687103e-1,.122366493950402e-1,.122421601042728e-1, &
    .122458343697479e-1,.122476716402898e-1/

  loop=max (1,n/256)
  floop=loop
  h=(b-a)/floop
  scale=h/2.0
  m=min (128,n/2)
  mt=2*m
  nplace=m-1

  do l = 1, loop
    fl = l
    al = a+(fl-1.0)*h
    bl = a+fl*h
    k = 256*(l-1)
    do i = 1, m
      npi = nplace+i
      s = t(npi)
      r = w(npi)*scale
      i1 = k+i
      i2 = k+mt+1-i

      tv(i1) = ( ( 1.0 + s ) * al &
               + ( 1.0 - s ) * bl ) / 2.0

      tv(i2) = ( ( 1.0 - s ) * al &
               + ( 1.0 + s ) * bl ) / 2.0

      wv(i1) = r
      wv(i2) = r

    end do
  end do

  return
end
subroutine wnlit(w, mdw, m, n, l, ipivot, itype, h, scale, rnorm, &
   idope, dope, done)

!*******************************************************************************
!
!! WNLIT is a companion subprogram to wnnls( ).
!
!
!     the documentation for wnnls( ) has more complete
!     usage instructions.
!
!     note  the m by (n+1) matrix w( , ) contains the rt. hand side
!           b as the (n+1)st col.
!
!
!     triangularize l1 by l1 subsystem, where l1=min(m,l), with
!     col interchanges.
!     revised oct. 1, 1989
!
  real w(mdw,*), h(*), scale(*), dope(*), sparam(5)
  integer itype(*), ipivot(*), idope(*)
  integer isamax
  integer max3
  logical indep, done, recalc
  data tenm3 /1.e-3/, zero /0.e0/, one /1.e0/
!
  me = idope(1)
  mep1 = idope(2)
  krank = idope(3)
  krp1 = idope(4)
  nsoln = idope(5)
  niv = idope(6)
  niv1 = idope(7)
  l1 = idope(8)
!
  alsq = dope(1)
  eanorm = dope(2)
  fac = dope(3)
  tau = dope(4)
  np1 = n + 1
  lb = min (m-1,l)
  recalc = .true.
  rnorm = zero
  krank = 0
!     we set factor=1.e0 so that the heavy weight alamda will be
!     included in the test for col independence.
  factor = 1.e0
  i = 1
  ip1 = 2
  lend = l
   10 if (.not.(i <= lb)) go to 150
  if (.not.(i <= me)) go to 130
!
!     set ir to point to the i-th row.
  ir = i
  mend = m
  assign 20 to igo996
  go to 460
!
!     update-col-ss-and-find-pivot-col
   20 assign 30 to igo993
  go to 560
!
!     perform-col-interchange
!
!     set ic to point to i-th col.
   30 ic = i
  assign 40 to igo990
  go to 520
!
!     test-indep-of-incoming-col
   40 if (.not.(indep)) go to 110
!
!     eliminate i-th col below diag. using mod. givens transformations
!     applied to (a b).
  j = m
  do 100 jj=ip1,m
    jm1 = j - 1
    jp = jm1
    if (.not.(jj==m)) go to 70
    if (.not.(i < mep1)) go to 80
    j = mep1
    jp = i
    t = scale(jp)*w(jp,i)**2*tau**2
    if (.not.(t > scale(j)*w(j,i)**2)) go to 130
    go to 80
   70   if (.not.(j==mep1)) go to 80
    j = jm1
    jm1 = j - 1
    jp = jm1
   80   if (.not.(w(j,i)/=zero)) go to 90
    call srotmg(scale(jp), scale(j), w(jp,i), w(j,i), sparam)
    w(j,i) = zero
    call srotm(np1-i, w(jp,ip1), mdw, w(j,ip1), mdw, sparam)
   90   j = jm1
  100 continue
  go to 140
  110 continue
  if (.not.(lend > i)) go to 130
!
!     col i is dependent. swap with col lend.
  max3 = lend
!
!     perform-col-interchange
  assign 120 to igo993
  go to 560
  120 continue
  lend = lend - 1
!
!     find col in remaining set with largest ss.
  max3 = isamax(lend-i+1,h(i),1) + i - 1
  hbar = h(max3)
  go to 30
  130 continue
  krank = i - 1
  go to 160
  140 i = ip1
  ip1 = ip1 + 1
  go to 10
  150 krank = l1
  160 continue
  krp1 = krank + 1
  if (.not.(krank < me)) go to 290
  factor = alsq
  do 170 i=krp1,me
    if (l > 0) w(i,1) = zero
    call scopy(l, w(i,1), 0, w(i,1), mdw)
  170 continue
!
!     determine the rank of the remaining equality constraint
!     equations by eliminating within the block of constrained
!     variables.  remove any redundant constraints.
!
  ir = krp1
  if (.not.(l < n)) go to 245
  lp1 = l + 1
  recalc = .true.
  lb = min (l+me-krank,n)
  i = lp1
  ip1 = i + 1
  180 if (.not.(i <= lb)) go to 280
  ir = krank + i - l
  lend = n
  mend = me
  assign 190 to igo996
  go to 460
!
!     update-col-ss-and-find-pivot-col
  190 assign 200 to igo993
  go to 560
!
!     perform-col-interchange
!
!     eliminate elements in the i-th col.
  200 j = me
  210 if (.not.(j > ir)) go to 230
  jm1 = j - 1
  if (.not.(w(j,i)/=zero)) go to 220
  call srotmg(scale(jm1), scale(j), w(jm1,i), w(j,i), sparam)
  w(j,i) = zero
  call srotm(np1-i, w(jm1,ip1), mdw, w(j,ip1), mdw, sparam)
  220 j = jm1
  go to 210
!
!     set ic=i=col being eliminated
  230 ic = i
  assign 240 to igo990
  go to 520
!
!     test-indep-of-incoming-col
  240 if (indep) go to 270
!
!     remove any redundant or dependent equality constraints.
  245 continue
  jj = ir
  250 if (.not.(ir <= me)) go to 260
  w(ir,1) = zero
  call scopy(n, w(ir,1), 0, w(ir,1), mdw)
  rnorm = rnorm + (scale(ir)*w(ir,np1)/alsq)*w(ir,np1)
  w(ir,np1) = zero
  scale(ir) = one
!     reclassify the zeroed row as a least squares equation.
  itype(ir) = 1
  ir = ir + 1
  go to 250
!
!     reduce me to reflect any discovered dependent equality
!     constraints.
  260 continue
  me = jj - 1
  mep1 = me + 1
  go to 300
  270 i = ip1
  ip1 = ip1 + 1
  go to 180
  280 continue
  290 continue
  300 continue
  if (.not.(krank < l1)) go to 420
!
!     try to determine the variables krank+1 through l1 from the
!     least squares equations.  continue the triangularization with
!     pivot element w(mep1,i).
!
  recalc = .true.
!
!     set factor=alsq to remove effect of heavy weight from
!     test for col independence.
  factor = alsq
  kk = krp1
  i = kk
  ip1 = i + 1
  310 if (.not.(i <= l1)) go to 410
!
!     set ir to point to the mep1-st row.
  ir = mep1
  lend = l
  mend = m
  assign 320 to igo996
  go to 460
!
!     update-col-ss-and-find-pivot-col
  320 assign 330 to igo993
  go to 560
!
!     perform-col-interchange
!
!     eliminate i-th col below the ir-th element.
  330 irp1 = ir + 1
  if (.not.(irp1 <= m)) go to 355
  j = m
  do 350 jj=irp1,m
    jm1 = j - 1
    if (.not.(w(j,i)/=zero)) go to 340
    call srotmg(scale(jm1), scale(j), w(jm1,i), w(j,i), sparam)
    w(j,i) = zero
    call srotm(np1-i, w(jm1,ip1), mdw, w(j,ip1), mdw, sparam)
  340   j = jm1
  350 continue
  355 continue
!
!     test if new pivot element is near zero. if so, the col is
!     dependent.
  t = scale(ir)*w(ir,i)**2
  indep = t > tau**2*eanorm**2
  if (.not.indep) go to 380
!
!     col test passed. now must pass row norm test to be classified
!     as independent.
  rn = zero
  do 370 i1=ir,m
    do 360 j1=ip1,n
      rn = max ( rn,scale(i1)*w(i1,j1)**2)
  360   continue
  370 continue
  indep = t > tau**2*rn
!
!     if independent, swap the ir-th and krp1-st rows to maintain the
!     triangular form.  update the rank indicator krank and the
!     equality constraint pointer me.
  380 if (.not.(indep)) go to 390
  call sswap(np1, w(krp1,1), mdw, w(ir,1), mdw)
  call sswap(1, scale(krp1), 1, scale(ir), 1)
!     reclassify the least sq. equation as an equality constraint and
!     rescale it.
  itype(ir) = 0
  t = sqrt(scale(krp1))
  call sscal(np1, t, w(krp1,1), mdw)
  scale(krp1) = alsq
  me = mep1
  mep1 = me + 1
  krank = krp1
  krp1 = krank + 1
  go to 400
  390 go to 430
  400 i = ip1
  ip1 = ip1 + 1
  go to 310
  410 continue
  420 continue
  430 continue
!
!     if pseudorank is less than l, apply householder trans.
!     from right.
  if (.not.(krank < l)) go to 450
  do 440 i=1,krank
    j = krp1 - i
    call h12(1, j, krp1, l, w(j,1), mdw, h(j), w, mdw, 1, j-1)
  440 continue
  450 niv = krank + nsoln - l
  niv1 = niv + 1
  if (l==n) done = .true.
!
!  end of initial triangularization.
  idope(1) = me
  idope(2) = mep1
  idope(3) = krank
  idope(4) = krp1
  idope(5) = nsoln
  idope(6) = niv
  idope(7) = niv1
  idope(8) = l1
  return
  460 continue
!
!     to update-col-ss-and-find-pivot-col
!
!     the col ss vector will be updated at each step. when
!     numerically necessary, these values will be recomputed.
!
  if (.not.(ir/=1 .and. (.not.recalc))) go to 480
!     update col ss =sum of squares.
  do 470 j=i,lend
    h(j) = h(j) - scale(ir-1)*w(ir-1,j)**2
  470 continue
!
!     test for numerical accuracy.
  max3 = isamax(lend-i+1,h(i),1) + i - 1
  recalc = hbar + tenm3*h(max3)==hbar
!
!     if required, recalculate col ss, using rows ir through mend.
  480 if (.not.(recalc)) go to 510
  do 500 j=i,lend
    h(j) = zero
    do 490 k=ir,mend
      h(j) = h(j) + scale(k)*w(k,j)**2
  490   continue
  500 continue
!
!     find col with largest ss.
  max3 = isamax(lend-i+1,h(i),1) + i - 1
  hbar = h(max3)
  510 go to 600
  520 continue
!
!     to test-indep-of-incoming-col
!
!     test the col ic to determine if it is linearly independent
!     of the cols already in the basis.  in the init tri
!     step, we usually want the heavy weight alamda to
!     be included in the test for independence.  in this case the
!     value of factor will have been set to 1.e0 before this
!     procedure is invoked.  in the potentially rank deficient
!     problem, the value of factor will have been
!     set to alsq=alamda**2 to remove the effect of the heavy weight
!     from the test for independence.
!
!     write new col as partitioned vector
!             (a1)  number of components in soln so far = niv
!             (a2)  m-niv components
!     and compute  sn = inverse weighted length of a1
!                  rn = inverse weighted length of a2
!     call the col independent when rn > tau*sn
  sn = zero
  rn = zero
  do 550 j=1,mend
    t = scale(j)
    if (j <= me) t = t/factor
    t = t*w(j,ic)**2
    if (.not.(j < ir)) go to 530
    sn = sn + t
    go to 540
  530   rn = rn + t
  540   continue
  550 continue
  indep = rn > tau**2*sn
  go to 590
  560 continue
!
!     to perform-col-interchange
!
  if (.not.(max3/=i)) go to 570
!     exchange elements of permuted index vector and perform col
!     interchanges.
  itemp = ipivot(i)
  ipivot(i) = ipivot(max3)
  ipivot(max3) = itemp
  call sswap(m, w(1,max3), 1, w(1,i), 1)
  t = h(max3)
  h(max3) = h(i)
  h(i) = t
  570 go to igo993, (30, 200, 330, 120)
  590 go to igo990, (40, 240)
  600 go to igo996, (20, 190, 320)
end
subroutine wnlsm(w, mdw, mme, ma, n, l, prgopt, x, rnorm, mode, &
   ipivot, itype, wd, h, scale, z, temp, d)
!
!*******************************************************************************
!
!! WNLSM is a companion subprogram to wnnls( ).
!
!
!     the documentation for wnnls( ) has more complete
!     usage instructions.
!
!     written by karen h. haskell, sandia laboratories,
!     with the help of r.j. hanson, sandia laboratories.
!
!     in addition to the parameters discussed in the prologue to
!     subroutine wnnls, the following work arrays are used in
!     subroutine wnlsm  (they are passed through the calling
!     sequence from wnnls for purposes of variable dimensioning).
!     their contents will in general be of no interest to the user.
!
!         ipivot(*)
!            an array of length n.  upon completion it contains the
!         pivoting information for the cols of w(*,*).
!
!         itype(*)
!            an array of length m which is used to keep track
!         of the classification of the equations.  itype(i)=0
!         denotes equation i as an equality constraint.
!         itype(i)=1 denotes equation i as a least squares
!         equation.
!
!         wd(*)
!            an array of length n.  upon completion it contains the
!         dual solution vector.
!
!         h(*)
!            an array of length n.  upon completion it contains the
!         pivot scalars of the householder transformations performed
!         in the case krank < l.
!
!         scale(*)
!            an array of length m which is used by the subroutine
!         to store the diagonal matrix of weights.
!         these are used to apply the modified givens
!         transformations.
!
!         z(*),temp(*)
!            working arrays of length n.
!
!         d(*)
!            an array of length n that contains the
!         column scaling for the matrix (e).
!                                       (a)
!
!
  real w(mdw,*), x(*), wd(*), h(*), scale(*), dope(4)
  real z(*), temp(*), prgopt(*), d(*), sparam(5)
  integer ipivot(*), itype(*), idope(8)
  logical hitcon, feasbl, done, pos
  data zero /0.e0/, one /1.e0/, two /2.e0/
!
!     initialize-variables
!
  go to 180
!
!     perform initial triangularization in the submatrix
!     corresponding to the unconstrained variables using
!     the procedure initially-triangularize.
!
   10 go to 280
!
!     perform wnnls algorithm using the following steps.
!
!     until(done)
!
!        compute-search-direction-and-feasible-point
!
!        when (hitcon) add-constraints
!
!        else perform-multiplier-test-and-drop-a-constraint
!
!        fin
!
!     compute-final-solution
!
   20 if (done) go to 80
  go to 300
!
!     compute-search-direction-and-feasible-point
!
   30 if (.not.(hitcon)) go to 50
  go to 370
!
!     when (hitcon) add-constraints
!
   50 go to 640
!
!     else perform-multiplier-test-and-drop-a-constraint
!
   80 go to 1000
!
!     compute-final-solution
!
  100 continue
!
!     to process-option-vector
  fac = 1.e-4
!
!     the nominal tolerance used in the code,
  tau = sqrt(srelpr)
!
!     the nominal blow-up factor used in the code.
  blowup = tau
!
!     the nominal column scaling used in the code is
!     the identity scaling.
  d(1) = one
  call scopy(n, d, 0, d, 1)
!
!     define bound for number of options to change.
  nopt = 1000
!
!     define bound for positive value of link.
  nlink = 100000
  ntimes = 0
  last = 1
  link = prgopt(1)
  if (.not.(link <= 0 .or. link > nlink)) go to 110
  mode = 2
  return
  110 if (.not.(link > 1)) go to 160
  ntimes = ntimes + 1
  if (.not.(ntimes > nopt)) go to 120
  mode = 2
  return
  120 key = prgopt(last+1)
  if (.not.(key==6 .and. prgopt(last+2)/=zero)) go to 140
  do 130 j=1,n
    t = snrm2(m,w(1,j),1)
    if (t/=zero) t = one/t
    d(j) = t
  130 continue
  140 if (key==7) call scopy(n, prgopt(last+2), 1, d, 1)
  if (key==8) tau = max ( srelpr,prgopt(last+2))
  if (key==9) blowup = max ( srelpr,prgopt(last+2))
  next = prgopt(link)
  if (.not.(next <= 0 .or. next > nlink)) go to 150
  mode = 2
  return
  150 last = link
  link = next
  go to 110
  160 do 170 j=1,n
    call sscal(m, d(j), w(1,j), 1)
  170 continue
  go to 220
!
!     to initialize-variables
!
!     srelpr is the precision for the machine being used.
!
  180 srelpr = epsilon ( srelpr )
!
  m = ma + mme
  me = mme
  mep1 = me + 1
  go to 100
!
!     process-option-vector
  220 done = .false.
  iter = 0
  itmax = 3*(n-l)
  mode = 0
  lp1 = l + 1
  nsoln = l
  nsp1 = nsoln + 1
  np1 = n + 1
  nm1 = n - 1
  l1 = min (m,l)
!
!     compute scale factor to apply to equal. constraint equas.
  do 230 j=1,n
    wd(j) = sasum(m,w(1,j),1)
  230 continue
  imax = isamax(n,wd,1)
  eanorm = wd(imax)
  bnorm = sasum(m,w(1,np1),1)
  alamda = eanorm/(srelpr*fac)
!
!     define scaling diag matrix for mod givens usage and
!     classify equation types.
  alsq = alamda**2
  do 260 i=1,m
!
!     when equ i is heavily weighted itype(i)=0, else itype(i)=1.
    if (.not.(i <= me)) go to 240
    t = alsq
    itemp = 0
    go to 250
  240   t = one
    itemp = 1
  250   scale(i) = t
    itype(i) = itemp
  260 continue
!
!     set the soln vector x(*) to zero and the col interchange
!     matrix to the identity.
  x(1) = zero
  call scopy(n, x, 0, x, 1)
  do 270 i=1,n
    ipivot(i) = i
  270 continue
  go to 10
  280 continue
!
!     to initially-triangularize
!
!     set first l comps. of dual vector to zero because
!     these correspond to the unconstrained variables.
  if (.not.(l > 0)) go to 290
  wd(1) = zero
  call scopy(l, wd, 0, wd, 1)
!
!     the arrays idope(*) and dope(*) are used to pass
!     information to wnlit().  this was done to avoid
!     a long calling sequence or the use of common.
  290 idope(1) = me
  idope(2) = mep1
  idope(3) = 0
  idope(4) = 1
  idope(5) = nsoln
  idope(6) = 0
  idope(7) = 1
  idope(8) = l1
!
  dope(1) = alsq
  dope(2) = eanorm
  dope(3) = fac
  dope(4) = tau
  call wnlit(w, mdw, m, n, l, ipivot, itype, h, scale, rnorm, &
   idope, dope, done)
  me = idope(1)
  mep1 = idope(2)
  krank = idope(3)
  krp1 = idope(4)
  nsoln = idope(5)
  niv = idope(6)
  niv1 = idope(7)
  l1 = idope(8)
  go to 20
  300 continue
!
!     to compute-search-direction-and-feasible-point
!
!     solve the triangular system of currently non-active
!     variables and store the solution in z(*).
!
!     solve-system
  assign 310 to igo958
  go to 1110
!
!     increment iteration counter and check against max. number
!     of iterations.
  310 iter = iter + 1
  if (.not.(iter > itmax)) go to 320
  mode = 1
  done = .true.
!
!     check to see if any constraints have become active.
!     if so, calculate an interpolation factor so that all
!     active constraints are removed from the basis.
  320 alpha = two
  hitcon = .false.
  if (.not.(l < nsoln)) go to 360
  do 350 j=lp1,nsoln
    zz = z(j)
    if (.not.(zz <= zero)) go to 350
    t = x(j)/(x(j)-zz)
    if (.not.(t < alpha)) go to 330
    alpha = t
    jcon = j
  330   hitcon = .true.
  350 continue
  360 go to 30
  370 continue
!
!     to add-constraints
!
!     use computed alpha to interpolate between last
!     feasible solution x(*) and current unconstrained
!     (and infeasible) solution z(*).
  if (.not.(lp1 <= nsoln)) go to 390
  do 380 j=lp1,nsoln
    x(j) = x(j) + alpha*(z(j)-x(j))
  380 continue
  390 feasbl = .false.
  go to 410
  400 if (feasbl) go to 20
!
!     remove col jcon and shift cols jcon+1 through n to the
!     left. swap col jcon into the n-th position.  this achieves
!     upper hessenberg form for the nonactive constraints and
!     leaves an upper hessenberg matrix to retriangularize.
  410 do 420 i=1,m
    t = w(i,jcon)
    call scopy(n-jcon, w(i,jcon+1), mdw, w(i,jcon), mdw)
    w(i,n) = t
  420 continue
!
!     update permuted index vector to reflect this shift and swap.
  itemp = ipivot(jcon)
  if (.not.(jcon < n)) go to 440
  do 430 i=jcon,nm1
    ipivot(i) = ipivot(i+1)
  430 continue
  440 ipivot(n) = itemp
!
!     similarly repermute x(*) vector.
  call scopy(n-jcon, x(jcon+1), 1, x(jcon), 1)
  x(n) = zero
  nsp1 = nsoln
  nsoln = nsoln - 1
  niv1 = niv
  niv = niv - 1
!
!     retriangularize upper hessenberg matrix after adding constraints.
  j = jcon
  i = krank + jcon - l
  450 if (.not.(j <= nsoln)) go to 570
  if (.not.(itype(i)==0 .and. itype(i+1)==0)) go to 470
  assign 460 to igo938
  go to 620
!
!     (itype(i)==0 .and. itype(i+1)==0) zero-ip1-to-i-in-col-j
  460 go to 560
  470 if (.not.(itype(i)==1 .and. itype(i+1)==1)) go to 490
  assign 480 to igo938
  go to 620
!
!     (itype(i)==1 .and. itype(i+1)==1) zero-ip1-to-i-in-col-j
  480 go to 560
  490 if (.not.(itype(i)==1 .and. itype(i+1)==0)) go to 510
  call sswap(np1, w(i,1), mdw, w(i+1,1), mdw)
  call sswap(1, scale(i), 1, scale(i+1), 1)
  itemp = itype(i+1)
  itype(i+1) = itype(i)
  itype(i) = itemp
!
!     swapped row was formerly a pivot elt., so it will
!     be large enough to perform elim.
  assign 500 to igo938
  go to 620
!
!     zero-ip1-to-i-in-col-j
  500 go to 560
  510 if (.not.(itype(i)==0 .and. itype(i+1)==1)) go to 550
  t = scale(i)*w(i,j)**2/alsq
  if (.not.(t > tau**2*eanorm**2)) go to 530
  assign 520 to igo938
  go to 620
  520 go to 540
  530 call sswap(np1, w(i,1), mdw, w(i+1,1), mdw)
  call sswap(1, scale(i), 1, scale(i+1), 1)
  itemp = itype(i+1)
  itype(i+1) = itype(i)
  itype(i) = itemp
  w(i+1,j) = zero
  540 continue
  550 continue
  560 i = i + 1
  j = j + 1
  go to 450
!
!     see if the remaining coeffs in the soln set are feasible.  they
!     should be because of the way alpha was determined.  if any are
!     infeasible it is due to roundoff error.  any that are non-
!     positive will be set to zero and removed from the soln set.
  570 if (.not.(lp1 <= nsoln)) go to 590
  do 580 jcon=lp1,nsoln
    if (x(jcon) <= zero) go to 600
  580 continue
  590 feasbl = .true.
  600 continue
  go to 400
  620 continue
!
!     to zero-ip1-to-i-in-col-j
  if (.not.(w(i+1,j)/=zero)) go to 630
  call srotmg(scale(i), scale(i+1), w(i,j), w(i+1,j), sparam)
  w(i+1,j) = zero
  call srotm(np1-j, w(i,j+1), mdw, w(i+1,j+1), mdw, sparam)
  630 go to 1290
!
!     to perform-multiplier-test-and-drop-a-constraint
!
  640 call scopy(nsoln, z, 1, x, 1)
  if (.not.(nsoln < n)) go to 650
  x(nsp1) = zero
  call scopy(n-nsoln, x(nsp1), 0, x(nsp1), 1)
  650 i = niv1
  660 if (.not.(i <= me)) go to 690
!
!     reclassify least squares eqations as equalities as
!     necessary.
  if (.not.(itype(i)==0)) go to 670
  i = i + 1
  go to 680
  670 call sswap(np1, w(i,1), mdw, w(me,1), mdw)
  call sswap(1, scale(i), 1, scale(me), 1)
  itemp = itype(i)
  itype(i) = itype(me)
  itype(me) = itemp
  mep1 = me
  me = me - 1
  680 go to 660
!
!     form inner product vector wd(*) of dual coeffs.
  690 if (.not.(nsp1 <= n)) go to 730
  do 720 j=nsp1,n
    sm = zero
    if (.not.(nsoln < m)) go to 710
    do 700 i=nsp1,m
      sm = sm + scale(i)*w(i,j)*w(i,np1)
  700   continue
  710   wd(j) = sm
  720 continue
  730 go to 750
  740 if (pos .or. done) go to 970
!
!     find j such that wd(j)=wmax is maximum.  this determines
!     that the incoming col j will reduce the residual vector
!     and be positive.
  750 wmax = zero
  iwmax = nsp1
  if (.not.(nsp1 <= n)) go to 780
  do 770 j=nsp1,n
    if (.not.(wd(j) > wmax)) go to 760
    wmax = wd(j)
    iwmax = j
  760   continue
  770 continue
  780 if (.not.(wmax <= zero)) go to 790
  done = .true.
  go to 960
!
!     set dual coeff to zero for incoming col.
  790 wd(iwmax) = zero
!
!     wmax > zero, so okay to move col iwmax to soln set.
!     perform transformation to retriangularize, and test
!     for near linear dependence.
!     swap col iwmax into nsoln-th position to maintain upper
!     hessenberg form of adjacent cols, and add new col to
!     triangular decomposition.
  nsoln = nsp1
  nsp1 = nsoln + 1
  niv = niv1
  niv1 = niv + 1
  if (.not.(nsoln/=iwmax)) go to 800
  call sswap(m, w(1,nsoln), 1, w(1,iwmax), 1)
  wd(iwmax) = wd(nsoln)
  wd(nsoln) = zero
  itemp = ipivot(nsoln)
  ipivot(nsoln) = ipivot(iwmax)
  ipivot(iwmax) = itemp
!
!     reduce col nsoln so that the matrix of nonactive
!     constraints variables is triangular.
  800 j = m
  810 if (.not.(j > niv)) go to 870
  jm1 = j - 1
  jp = jm1
!
!     when operating near the me line, test to see if the pivot elt.
!     is near zero.  if so, use the largest elt. above it as the pivot.
!     this is to maintain the sharp interface between weighted and
!     non-weighted rows in all cases.
  if (.not.(j==mep1)) go to 850
  imax = me
  amax = scale(me)*w(me,nsoln)**2
  820 if (.not.(jp >= niv)) go to 840
  t = scale(jp)*w(jp,nsoln)**2
  if (.not.(t > amax)) go to 830
  imax = jp
  amax = t
  830 jp = jp - 1
  go to 820
  840 jp = imax
  850 if (.not.(w(j,nsoln)/=zero)) go to 860
  call srotmg(scale(jp), scale(j), w(jp,nsoln), w(j,nsoln), sparam)
  w(j,nsoln) = zero
  call srotm(np1-nsoln, w(jp,nsp1), mdw, w(j,nsp1), mdw, sparam)
  860 j = jm1
  go to 810
!
!     solve for z(nsoln)=proposed new value for x(nsoln).
!     test if this is nonpositive or too large.
!     if this was true or if the pivot term was zero reject
!     the col as dependent.
  870 if (.not.(w(niv,nsoln)/=zero)) go to 890
  isol = niv
  assign 880 to igo897
  go to 980
!
!     test-proposed-new-component
  880 go to 940
  890 if (.not.(niv <= me .and. w(mep1,nsoln)/=zero)) go to 920
!
!     try to add row mep1 as an additional equality constraint.
!     check size of proposed new soln component.
!     reject it if it is too large.
  isol = mep1
  assign 900 to igo897
  go to 980
!
!     test-proposed-new-component
  900 if (.not.(pos)) go to 910
!
!     swap rows mep1 and niv, and scale factors for these rows.
  call sswap(np1, w(mep1,1), mdw, w(niv,1), mdw)
  call sswap(1, scale(mep1), 1, scale(niv), 1)
  itemp = itype(mep1)
  itype(mep1) = itype(niv)
  itype(niv) = itemp
  me = mep1
  mep1 = me + 1
  910 go to 930
  920 pos = .false.
  930 continue
  940 if (pos) go to 950
  nsp1 = nsoln
  nsoln = nsoln - 1
  niv1 = niv
  niv = niv - 1
  950 continue
  960 go to 740
  970 go to 20
  980 continue
!
!     to test-proposed-new-component
  z2 = w(isol,np1)/w(isol,nsoln)
  z(nsoln) = z2
  pos = z2 > zero
  if (.not.(z2*eanorm >= bnorm .and. pos)) go to 990
  pos = .not.(blowup*z2*eanorm >= bnorm)
  990 go to 1280
 1000 continue
!     to compute-final-solution
!
!     solve system, store results in x(*).
!
  assign 1010 to igo958
  go to 1110
!     solve-system
 1010 call scopy(nsoln, z, 1, x, 1)
!
!     apply householder transformations to x(*) if krank < l
  if (.not.(0 < krank .and. krank < l)) go to 1030
  do 1020 i=1,krank
    call h12(2, i, krp1, l, w(i,1), mdw, h(i), x, 1, 1, 1)
 1020 continue
!
!     fill in trailing zeroes for constrained variables not in soln.
 1030 if (.not.(nsoln < n)) go to 1040
  x(nsp1) = zero
  call scopy(n-nsoln, x(nsp1), 0, x(nsp1), 1)
!
!     repermute soln vector to natural order.
 1040 do 1070 i=1,n
    j = i
 1050   if (ipivot(j)==i) go to 1060
    j = j + 1
    go to 1050
 1060   ipivot(j) = ipivot(i)
    ipivot(i) = j
    call sswap(1, x(j), 1, x(i), 1)
 1070 continue
!
!     rescale the soln using the col scaling.
  do 1080 j=1,n
    x(j) = x(j)*d(j)
 1080 continue
  if (.not.(niv < m)) go to 1100
  do 1090 i=niv1,m
    t = w(i,np1)
    if (i <= me) t = t/alamda
    t = (scale(i)*t)*t
    rnorm = rnorm + t
 1090 continue
 1100 rnorm = sqrt(rnorm)
  return
!
!     to solve-system
!
 1110 continue
  if (.not.(done)) go to 1120
  isol = 1
  go to 1130
 1120 isol = lp1
 1130 if (.not.(nsoln >= isol)) go to 1270
!
!     copy rt. hand side into temp vector to use overwriting method.
  call scopy(niv, w(1,np1), 1, temp, 1)
  do 1180 jj=isol,nsoln
    j = nsoln - jj + isol
    if (.not.(j > krank)) go to 1140
    i = niv - jj + isol
    go to 1150
 1140   i = j
 1150   if (.not.(j > krank .and. j <= l)) go to 1160
    z(j) = zero
    go to 1170
 1160   z(j) = temp(i)/w(i,j)
    call saxpy(i-1, -z(j), w(1,j), 1, temp, 1)
 1170   continue
 1180 continue
!
 1270 go to igo958, (310, 1010)
 1280 go to igo897, (880, 900)
 1290 go to igo938, (460, 480, 500, 520)
end
subroutine wnnls(w, mdw, me, ma, n, l, prgopt, x, rnorm, mode, &
   iwork, work)
!
!*******************************************************************************
!
!! WNNLS solves a linearly constrained least squares problem.
!
!
!  suppose there are given matrices e and a of
!     respective dimensions me by n and ma by n, and vectors f
!     and b of respective lengths me and ma.  this subroutine
!     solves the problem
!
!               ex = f, (equations to be exactly satisfied)
!
!               ax = b, (equations to be approximately satisfied,
!                        in the least squares sense)
!
!               subject to components l+1,...,n nonnegative
!
!     any values me >= 0, ma >= 0 and 0 <=  l  <= n are permitted.
!
!     the problem is reposed as problem wnnls
!
!               (wt*e)x = (wt*f)
!               (   a)    (   b), (least squares)
!               subject to components l+1,...,n nonnegative.
!
!     the subprogram chooses the heavy weight (or penalty parameter) wt.
!
!     the parameters for wnnls are
!
!     input..
!
!     w(*,*),mdw,  the array w(*,*) is double subscripted with first
!     me,ma,n,l    dimensioning parameter equal to mdw.  for this
!                  discussion let us call m = me + ma.  then mdw
!                  must satisfy mdw >= m.  the condition mdw < m
!                  is an error.
!
!                  the array w(*,*) contains the matrices and vectors
!
!                       (e  f)
!                       (a  b)
!
!                  in rows and columns 1,...,m and 1,...,n+1
!                  respectively.  columns 1,...,l correspond to
!                  unconstrained variables x(1),...,x(l).  the
!                  remaining variables are constrained to be
!                  nonnegative.  the condition l < 0 .or. l > n is
!                  an error.
!
!     prgopt(*)    this array is the option vector.
!                  if the user is satisfied with the nominal
!                  subprogram features set
!
!                  prgopt(1)=1 (or prgopt(1)=1.0)
!
!                  otherwise prgopt(*) is a linked list consisting of
!                  groups of data of the following form
!
!                  link
!                  key
!                  data set
!
!                  the parameters link and key are each one word.
!                  the data set can be comprised of several words.
!                  the number of items depends on the value of key.
!                  the value of link points to the first
!                  entry of the next group of data within
!                  prgopt(*).  the exception is when there are
!                  no more options to change.  in that
!                  case link=1 and the values key and data set
!                  are not referenced. the general layout of
!                  prgopt(*) is as follows.
!
!               ...prgopt(1)=link1 (link to first entry of next group)
!               .  prgopt(2)=key1 (key to the option change)
!               .  prgopt(3)=data value (data value for this change)
!               .       .
!               .       .
!               .       .
!               ...prgopt(link1)=link2 (link to the first entry of
!               .                       next group)
!               .  prgopt(link1+1)=key2 (key to the option change)
!               .  prgopt(link1+2)=data value
!               ...     .
!               .       .
!               .       .
!               ...prgopt(link)=1 (no more options to change)
!
!                  values of link that are nonpositive are errors.
!                  a value of link > nlink=100000 is also an error.
!                  this helps prevent using invalid but positive
!                  values of link that will probably extend
!                  beyond the program limits of prgopt(*).
!                  unrecognized values of key are ignored.  the
!                  order of the options is arbitrary and any number
!                  of options can be changed with the following
!                  restriction.  to prevent cycling in the
!                  processing of the option array a count of the
!                  number of options changed is maintained.
!                  whenever this count exceeds nopt=1000 the
!                  routine terminates.
!
!                  options..
!
!                  key=6
!                         scale the nonzero columns of the
!                  entire data matrix
!                  (e)
!                  (a)
!                  to have length one.  the data set for
!                  this option is a single value.  it must
!                  be nonzero if unit length column scaling is
!                  desired.
!
!                  key=7
!                         scale columns of the entire data matrix
!                  (e)
!                  (a)
!                  with a user-provided diagonal matrix.
!                  the data set for this option consists
!                  of the n diagonal scaling factors, one for
!                  each matrix column.
!
!                  key=8
!                         change the rank determination tolerance from
!                  the nominal value of sqrt(eps).  this quantity can
!                  be no smaller than eps, the arithmetic-
!                  storage precision.  the quantity used
!                  here is internally restricted to be at
!                  least eps.  the data set for this option
!                  is the new tolerance.
!
!                  key=9
!                         change the blow-up parameter from the
!                  nominal value of sqrt(eps).  the reciprocal of
!                  this parameter is used in rejecting solution
!                  components as too large when a variable is
!                  first brought into the active set.  too large
!                  means that the proposed component times the
!                  reciprocal of the parameteris not less than
!                  the ratio of the norms of the right-side
!                  vector and the data matrix.
!                  this parameter can be no smaller than eps,
!                  the arithmetic-storage precision.
!
!                  for example, suppose we want to provide
!                  a diagonal matrix to scale the problem
!                  matrix and change the tolerance used for
!                  determining linear dependence of dropped col
!                  vectors.  for these options the dimensions of
!                  prgopt(*) must be at least n+6.  the fortran
!                  statements defining these options would
!                  be as follows.
!
!                  prgopt(1)=n+3 (link to entry n+3 in prgopt(*))
!                  prgopt(2)=7 (user-provided scaling key)
!
!                  call scopy(n,d,1,prgopt(3),1) (copy the n
!                  scaling factors from a user array called d(*)
!                  into prgopt(3)-prgopt(n+2))
!
!                  prgopt(n+3)=n+6 (link to entry n+6 of prgopt(*))
!                  prgopt(n+4)=8 (linear dependence tolerance key)
!                  prgopt(n+5)=... (new value of the tolerance)
!
!                  prgopt(n+6)=1 (no more options to change)
!
!     output..
!
!     x(*)         an array dimensioned at least n, which will
!                  contain the n components of the solution vector
!                  on output.
!
!     rnorm        the residual norm of the solution.  the value of
!                  rnorm contains the residual vector length of the
!                  equality constraints and least squares equations.
!
!     mode         the value of mode indicates the success or failure
!                  of the subprogram.
!
!                  mode = 0  subprogram completed successfully.
!
!                       = 1  max. number of iterations (equal to
!                            3*(n-l)) exceeded. nearly all problems
!                            should complete in fewer than this
!                            number of iterations. an approximate
!                            solution and its corresponding residual
!                            vector length are in x(*) and rnorm.
!
!                       = 2  usage error occurred.  either
!                            mdw < me + ma, l  <  0, l > n,
!                            or the option vector prgopt(*) is
!                            not properly defined.
!
!     user-designated
!     working arrays..
!
!     work(*)      a working array of length at least
!                  m + 5*n.
!
!     iwork(*)     an integer-valued working array of length at least
!                  m+n.
!
!     written by karen h. haskell, sandia laboratories,
!     and r.j. hanson, sandia laboratories.
!     revised oct. 1, 1989.
!
!
!     subroutines called by wnnls( )
!
!     wnlsm         companion subroutine to wnnls( ), where
!                   most of the computation takes place.
!
!
!     references
!
!     1. solving least squares problems, by c.l. lawson
!        and r.j. hanson.  prentice-hall, inc. (1974).
!
!     2. basic linear algebra subprograms for fortran usage, by
!        c.l. lawson, r.j. hanson, d.r. kincaid, and f.t. krogh.
!        toms, v. 5, no. 3, p. 308.  also available as
!        sandia technical report no. sand77-0898.
!
!     3. an algorithm for linear least squares with equality
!        and nonnegativity constraints, by k.h. haskell and
!        r.j. hanson.  available as sandia technical report no.
!        sand77-0552, and math. programming, vol. 21, (1981), p. 98-118.
!
  real w(mdw,*), prgopt(*), x(n), work(*)
  integer iwork(*)
!
  mode = 0
  if (ma+me <= 0 .or. n <= 0) return
  if (.not.(mdw < me+ma)) go to 10
  mode = 2
  return
   10 if (0 <= l .and. l <= n) go to 20
  mode = 2
  return
!
!     the purpose of this subroutine is to break up the arrays
!     work(*) and iwork(*) into separate work arrays
!     required by the main subroutine wnlsm( ).
!
   20 l1 = n + 1
  l2 = l1 + n
  l3 = l2 + me + ma
  l4 = l3 + n
  l5 = l4 + n
!
  call wnlsm(w, mdw, me, ma, n, l, prgopt, x, rnorm, mode, iwork, &
   iwork(l1), work(1), work(l1), work(l2), work(l3), work(l4), &
   work(l5))
  return
end
subroutine wpfit(nd,np,x,y,w,a,rnorm,phi,phix,ierr)
!
!*******************************************************************************
!
!! WPFIT: weighted least squares polynomial fit
!
  real x(np),y(np),w(np),a(*),phi(2,*),phix(4,np)
  real lambda
  double precision dalpha,dsum
!
!                      error checking
!
  if (nd < 1.or.np < 2) go to 200
  nw=0
  dsum=0.d0
  do 13 k=1,np
  if (w(k)) 202,13,10
   10 nw=nw+1
  dsum=dsum+dble(w(k))
  if (nw > 1) go to 11
  xmin=x(k)
  xmax=x(k)
  go to 13
   11 if (x(k) >= xmin) go to 12
  xmin=x(k)
  go to 13
   12 if (x(k) > xmax) xmax=x(k)
   13 continue
  if (nd >= nw) go to 200
!
!                      initialization
!
  ierr=0
  nd1=nd+1
  do 20 k=1,nd1
  a(k)=0.0
  phi(1,k)=0.0
   20 phi(2,k)=0.0
!
!                set z=a+b*x where abs(z) <= 1
!
  zb=2.0/(xmax-xmin)
  za=-xmin*zb-1.0
  do 25 k=1,np
   25 phix(3,k)=za+zb*x(k)
!
!           compute the closest polynomial of degree 0
!
  lambda=dsum
  phi(1,1)=1.0/sqrt(lambda)
  dalpha=0.d0
  dsum=0.d0
  do 30 k=1,np
  phix(1,k)=phi(1,1)
  dalpha=dalpha+dble(w(k)*phix(3,k))
   30 dsum=dsum+dble(w(k)*y(k))
  alpha=sngl(dalpha)/lambda
  a(1)=sngl(dsum)/lambda
  do 31 k=1,np
   31 phix(4,k)=a(1)
!
  la=2
  lb=1
  do 90 m=1,nd
  mp1=m+1
!
!          generate lambda(m)*phi(m) and evaluate it at z
!
  if (m/=1) go to 50
  phi(2,1)=-alpha*phi(1,1)
  phi(2,2)=phi(1,1)
  do 40 k=1,np
   40 phix(2,k)=(phix(3,k)-alpha)*phi(1,1)
  go to 60
!
   50 c=0.0
  do 51 k=1,m
  phi(la,k)=dble(c)-dble(alpha*phi(lb,k))-dble(lambda*phi(la,k))
   51 c=phi(lb,k)
  phi(la,mp1)=c
  do 52 k=1,np
   52 phix(la,k)=(phix(3,k)-alpha)*phix(lb,k)-lambda*phix(la,k)
!
!                compute alpha(m) and lambda(m)
!
   60 dalpha=0.d0
  dsum=0.d0
  do 61 k=1,np
  c=w(k)*phix(la,k)*phix(la,k)
  dalpha=dalpha+dble(c*phix(3,k))
   61 dsum=dsum+dble(c)
  lambda=dsum
  alpha=sngl(dalpha)/lambda
  lambda=sqrt(lambda)
!
!              generate phi(m) and evaluate it at z
!
  do 70 k=1,mp1
   70 phi(la,k)=phi(la,k)/lambda
  do 71 k=1,np
   71 phix(la,k)=phix(la,k)/lambda
!
!        compute the closest polynomial of degree m or less
!                     and evaluate it at z
!
  dsum=0.d0
  do 80 k=1,np
   80 dsum=dsum+dble(w(k)*(y(k)-phix(4,k))*phix(la,k))
  c=dsum
  do 81 k=1,mp1
   81 a(k)=a(k)+c*phi(la,k)
  do 82 k=1,np
   82 phix(4,k)=phix(4,k)+c*phix(la,k)
!
  ls=la
  la=lb
   90 lb=ls
!
!                        compute rnorm
!
  dsum=0.d0
  do 95 k=1,np
   95 dsum=dsum+dble(w(k)*(y(k)-phix(4,k))**2)
  rnorm=sqrt(sngl(dsum))
!
!        convert the closest polynomial from a polynomial
!                  in z to a polynomial in x
!
  a(1)=a(1)+za*a(2)
  a(2)=zb*a(2)
  if (nd==1) return
  phi(1,1)=za
  phi(1,2)=zb
  do 102 m=2,nd
  mp1=m+1
  c=0.0
  do 100 k=1,m
  temp=phi(1,k)*zb
  phi(1,k)=phi(1,k)*za+c
  100 c=temp
  phi(1,mp1)=c
  do 101 k=1,m
  101 a(k)=a(k)+a(mp1)*phi(1,k)
  102 a(mp1)=a(mp1)*phi(1,mp1)
  return
!
!                        error return
!
  200 ierr=1
  return
  202 ierr=3
  return
end
subroutine xcond(fun,x,cond,num,ierr)
!
!*******************************************************************************
!
!! XCOND tests whether x lies to the right of all singularities of the complex
!     function defined by fun which lie on the real axis.
!
!     fun is a real subroutine defined by the user.  the actual name
!     for fun needs to be declared external in the driver program.
!     fun has the arguments x, y, a, and b.
!
!     x is a real number.  the logical variable cond = .true if
!     x < c, where c is the abscissa of the singularity on the
!     real axis which lies farthest to the right, and .false. if
!     x < c.
!
!     num is a variable. on output it has for its value the number
!     of evaluations of fun that were performed.
!
!     ierr is an output integer indicating the status of the
!     calculation.  it is assigned values as follows...
!          ierr = 0     the calculation was fully successful.
!          ierr = 1     the calculation of cond may not be accurate
!                       for all values of x.
!
  real eps
  dimension iwk(100), wk(400)
  logical cond
  external fun, xcondx, xcondy
!
  eps = epsilon ( eps )

  epsr = 1.0e-2
  eps1 = 100.0*eps
  eps2 = 100.0*sqrt(eps)
  aerr = 1.0e-30
  rerr = eps1
  mo = 1
  l = 100
  m = 400
  c = abs(x) + 1.0
  y = epsr
  cond = .false.
!
!     numerical integration of the imaginary part of the integrand
!     along the line y = epsr.
!
  call qagi1(xcondy,fun,y,c,x,mo,aerr,rerr,z,error,num,ierr, &
             l,m,n,iwk,wk)
  if(ierr >= 1) go to 100
!
!     determination of cond.
!
  y1 = y/2.0
  t = (xcondx(x,y,c,fun) + 4.0*xcondx(x,y1,c,fun) + &
             xcondx(x,0.0,c,fun))*epsr/6.0
  num = num + 3
  if(t*z > 0.0) return
  if(abs(t + z) > eps2*max ( abs(t), abs(z))) return
     cond = .true.
     return
!
!     error return
!
  100 ierr = 1
  return
end
function xcondx(x,y,c,fun)
!
!*******************************************************************************
!
!! XCONDX is the real part of the integrand in xcond.
!
  external fun
  call fun(x,y,a,b)
  d = (x + c)**2 + y**2
  xcondx = (a*(x + c) + b*y)/d
  return
end
function xcondy(x,y,c,fun)
!
!*******************************************************************************
!
!! XCONDY is the imaginary part of integrand in xcond.
!
  external fun
  call fun(x,y,a,b)
  z = x + c
  t = cpabs(y, z)
  t1 = y/t
  t2 = z/t
  xcondy = (t2*b - t1*a)/t
  return
end
subroutine xl1(k, l, m, n, klmd, klm2d, nklmd, n2d, &
   q, kode, toler, iter, x, res, error, cu, iu, s)
!
!*******************************************************************************
!
!! XL1 uses a modification of the simplex method of linear programming
!  to calculate an l1 solution to a k by n system of linear equations
!             ax=b
! subject to l linear equality constraints
!             cx=d
! and m linear inequality constraints
!             ex <= f.
! description of parameters
! k      number of rows of the matrix a (k >= 1).
! l      number of rows of the matrix c (l >= 0).
! m      number of rows of the matrix e (m >= 0).
! n      number of columns of the matrices a,c,e (n >= 1).
! klmd   set to at least k+l+m for adjustable dimensions.
! klm2d  set to at least k+l+m+2 for adjustable dimensions.
! nklmd  set to at least n+k+l+m for adjustable dimensions.
! n2d    set to at least n+2 for adjustable dimensions
! q      two dimensional real array with klm2d rows and
!        at least n2d columns.
!        on entry the matrices a,c and e, and the vectors
!        b,d and f must be stored in the first k+l+m rows
!        and n+1 columns of q as follows
!             a b
!         q = c d
!             e f
!        these values are destroyed by the subroutine.
! kode   a code used on entry to, and exit
!        from, the subroutine.
!        on entry, this should normally be set to 0.
!        however, if certain nonnegativity constraints
!        are to be included implicitly, rather than
!        explicitly in the constraints ex <= f, then kode
!        should be set to 1, and the nonnegativity
!        constraints included in the arrays x and
!        res (see below).
!        on exit, kode has one of the
!        following values
!             0- optimal solution found,
!             1- no feasible solution to the
!                constraints,
!             2- calculations terminated
!                prematurely due to rounding errors,
!             3- maximum number of iterations reached.
! toler  a small positive tolerance. empirical
!        evidence suggests toler = 10**(-d*2/3),
!        where d represents the number of decimal
!        digits of accuracy available. essentially,
!        the subroutine cannot distinguish between zero
!        and any quantity whose magnitude does not exceed
!        toler. in particular, it will not pivot on any
!        number whose magnitude does not exceed toler.
! iter   on entry iter must contain an upper bound on
!        the maximum number of iterations allowed.
!        a suggested value is 10*(k+l+m). on exit iter
!        gives the number of simplex iterations.
! x      one dimensional real array of size at least n2d.
!        on exit this array contains a
!        solution to the l1 problem. if kode=1
!        on entry, this array is also used to include
!        simple nonnegativity constraints on the
!        variables. the values -1, 0, or 1
!        for x(j) indicate that the j-th variable
!        is restricted to be  <= 0, unrestricted,
!        or  >= 0 respectively.
! res    one dimensional real array of size at least klmd.
!        on exit this contains the residuals b-ax
!        in the first k components, d-cx in the
!        next l components (these will be =0),and
!        f-ex in the next m components. if kode=1 on
!        entry, this array is also used to include simple
!        nonnegativity constraints on the residuals
!        b-ax. the values -1, 0, or 1 for res(i)
!        indicate that the i-th residual (1 <= i <= k) is
!        restricted to be  <= 0, unrestricted, or  >= 0
!        respectively.
! error  on exit, this gives the minimum sum of
!        absolute values of the residuals.
! cu     a two dimensional real array with two rows and
!        at least nklmd columns used for workspace.
! iu     a two dimensional integer array with two rows and
!        at least nklmd columns used for workspace.
! s      integer array of size at least klmd, used for
!        workspace.
! if your fortran compiler permits a single column of a two
! dimensional array to be passed to a one dimensional array
! through a subroutine call, considerable savings in
! execution time may be achieved through the use of the
! following subroutine, which operates on column vectors.
!     subroutine col(v1, v2, xmlt, notrow, k)
! this subroutine adds to the vector v1 a multiple of the
! vector v2 (elements 1 through k excluding notrow).
!     dimension v1(k), v2(k)
!     kend = notrow - 1
!     kstart = notrow + 1
!     if (kend < 1) go to 20
!     do 10 i=1,kend
!        v1(i) = v1(i) + xmlt*v2(i)
!  10 continue
!     if(kstart > k) go to 40
!  20 do 30 i=kstart,k
!       v1(i) = v1(i) + xmlt*v2(i)
!  30 continue
!  40 return
!   end
! see comments following statement labelled 440 for
! instructions on the implementation of this modification.
!
  double precision sum
  real q, x, z, cu, sn, zu, zv, cuv, res, xmax, xmin, &
   error, pivot, toler, tpivot
  integer i, j, k, l, m, n, s, ia, ii, in, iu, js, kk, &
   nk, n1, n2, jmn, jpn, klm, nkl, nk1, n2d, iimn, &
   iout, iter, klmd, klm1, klm2, kode, nklm, nkl1, &
   klm2d, maxit, nklmd, iphase, kforce, iineg
  dimension q(klm2d,n2d), x(n2d), res(klmd), &
   cu(2,nklmd), iu(2,nklmd), s(klmd)
!
! initialization.
!
  maxit = iter
  n1 = n + 1
  n2 = n + 2
  nk = n + k
  nk1 = nk + 1
  nkl = nk + l
  nkl1 = nkl + 1
  klm = k + l + m
  klm1 = klm + 1
  klm2 = klm + 2
  nklm = n + klm
  kforce = 1
  iter = 0
  js = 1
  ia = 0
! set up labels in q.
  do 10 j=1,n
     q(klm2,j) = j
   10 continue
  do 30 i=1,klm
     q(i,n2) = n + i
     if (q(i,n1) >= 0.) go to 30
     do 20 j=1,n2
        q(i,j) = -q(i,j)
   20    continue
   30 continue
! set up phase 1 costs.
  iphase = 2
  do 40 j=1,nklm
     cu(1,j) = 0.
     cu(2,j) = 0.
     iu(1,j) = 0
     iu(2,j) = 0
   40 continue
  if (l == 0) go to 60
  do 50 j=nk1,nkl
     cu(1,j) = 1.
     cu(2,j) = 1.
     iu(1,j) = 1
     iu(2,j) = 1
   50 continue
  iphase = 1
   60 if (m == 0) go to 80
  do 70 j=nkl1,nklm
     cu(2,j) = 1.
     iu(2,j) = 1
     jmn = j - n
     if (q(jmn,n2) < 0.) iphase = 1
   70 continue
   80 if (kode == 0) go to 150
  do 110 j=1,n
     if (x(j)) 90, 110, 100
   90    cu(1,j) = 1.
     iu(1,j) = 1
     go to 110
  100    cu(2,j) = 1.
     iu(2,j) = 1
  110 continue
  do 140 j=1,k
     jpn = j + n
     if (res(j)) 120, 140, 130
  120    cu(1,jpn) = 1.
     iu(1,jpn) = 1
     if (q(j,n2) > 0.0) iphase = 1
     go to 140
  130    cu(2,jpn) = 1.
     iu(2,jpn) = 1
     if (q(j,n2) < 0.0) iphase = 1
  140 continue
  150 if (iphase == 2) go to 500
! compute the marginal costs.
  160 do 200 j=js,n1
     sum = 0.d0
     do 190 i=1,klm
        ii = q(i,n2)
        if (ii < 0) go to 170
        z = cu(1,ii)
        go to 180
  170       iineg = -ii
        z = cu(2,iineg)
  180       sum = sum + dble(q(i,j))*dble(z)
  190    continue
     q(klm1,j) = sum
  200 continue
  do 230 j=js,n
     ii = q(klm2,j)
     if (ii < 0) go to 210
     z = cu(1,ii)
     go to 220
  210    iineg = -ii
     z = cu(2,iineg)
  220    q(klm1,j) = q(klm1,j) - z
  230 continue
! determine the vector to enter the basis.
  240 xmax = 0.
  if (js > n) go to 490
  do 280 j=js,n
     zu = q(klm1,j)
     ii = q(klm2,j)
     if (ii > 0) go to 250
     ii = -ii
     zv = zu
     zu = -zu - cu(1,ii) - cu(2,ii)
     go to 260
  250    zv = -zu - cu(1,ii) - cu(2,ii)
  260    if (kforce == 1 .and. ii > n) go to 280
     if (iu(1,ii) == 1) go to 270
     if (zu <= xmax) go to 270
     xmax = zu
     in = j
  270    if (iu(2,ii) == 1) go to 280
     if (zv <= xmax) go to 280
     xmax = zv
     in = j
  280 continue
  if (xmax <= toler) go to 490
  if (q(klm1,in) == xmax) go to 300
  do 290 i=1,klm2
     q(i,in) = -q(i,in)
  290 continue
  q(klm1,in) = xmax
! determine the vector to leave the basis.
  300 if (iphase == 1 .or. ia==0) go to 330
  xmax = 0.
  do 310 i=1,ia
     z = abs(q(i,in))
     if (z <= xmax) go to 310
     xmax = z
     iout = i
  310 continue
  if (xmax <= toler) go to 330
  do 320 j=1,n2
     z = q(ia,j)
     q(ia,j) = q(iout,j)
     q(iout,j) = z
  320 continue
  iout = ia
  ia = ia - 1
  pivot = q(iout,in)
  go to 420
  330 kk = 0
  do 340 i=1,klm
     z = q(i,in)
     if (z <= toler) go to 340
     kk = kk + 1
     res(kk) = q(i,n1)/z
     s(kk) = i
  340 continue
  350 if (kk > 0) go to 360
  kode = 2
  go to 590
  360 xmin = res(1)
  iout = s(1)
  j = 1
  if (kk == 1) go to 380
  do 370 i=2,kk
     if (res(i) >= xmin) go to 370
     j = i
     xmin = res(i)
     iout = s(i)
  370 continue
  res(j) = res(kk)
  s(j) = s(kk)
  380 kk = kk - 1
  pivot = q(iout,in)
  ii = q(iout,n2)
  if (iphase == 1) go to 400
  if (ii < 0) go to 390
  if (iu(2,ii) == 1) go to 420
  go to 400
  390 iineg = -ii
  if (iu(1,iineg) == 1) go to 420
  400 ii = iabs(ii)
  cuv = cu(1,ii) + cu(2,ii)
  if (q(klm1,in)-pivot*cuv <= toler) go to 420
! bypass intermediate vertices.
  do 410 j=js,n1
     z = q(iout,j)
     q(klm1,j) = q(klm1,j) - z*cuv
     q(iout,j) = -z
  410 continue
  q(iout,n2) = -q(iout,n2)
  go to 350
! gauss-jordan elimination.
  420 if (iter < maxit) go to 430
  kode = 3
  go to 590
  430 iter = iter + 1
  do 440 j=js,n1
     if (j/=in) q(iout,j) = q(iout,j)/pivot
  440 continue
! if permitted, use subroutine col of the description
! section and replace the following seven statements down
! to and including statement number 460 by..
!     do 460 j=js,n1
!        if(j == in) go to 460
!        z = -q(iout,j)
!        call col(q(1,j), q(1,in), z, iout, klm1)
! 460 continue
  do 460 j=js,n1
     if (j == in) go to 460
     z = -q(iout,j)
     do 450 i=1,klm1
        if (i/=iout) q(i,j) = q(i,j) + z*q(i,in)
  450    continue
  460 continue
  tpivot = -pivot
  do 470 i=1,klm1
     if (i/=iout) q(i,in) = q(i,in)/tpivot
  470 continue
  q(iout,in) = 1./pivot
  z = q(iout,n2)
  q(iout,n2) = q(klm2,in)
  q(klm2,in) = z
  ii = abs(z)
  if (iu(1,ii) == 0 .or. iu(2,ii)==0) go to 240
  do 480 i=1,klm2
     z = q(i,in)
     q(i,in) = q(i,js)
     q(i,js) = z
  480 continue
  js = js + 1
  go to 240
! test for optimality.
  490 if (kforce == 0) go to 580
  if (iphase == 1 .and. q(klm1,n1) <= toler) go to 500
  kforce = 0
  go to 240
! set up phase 2 costs.
  500 iphase = 2
  do 510 j=1,nklm
     cu(1,j) = 0.
     cu(2,j) = 0.
  510 continue
  do 520 j=n1,nk
     cu(1,j) = 1.
     cu(2,j) = 1.
  520 continue
  do 560 i=1,klm
     ii = q(i,n2)
     if (ii > 0) go to 530
     ii = -ii
     if (iu(2,ii) == 0) go to 560
     cu(2,ii) = 0.
     go to 540
  530    if (iu(1,ii) == 0) go to 560
     cu(1,ii) = 0.
  540    ia = ia + 1
     do 550 j=1,n2
        z = q(ia,j)
        q(ia,j) = q(i,j)
        q(i,j) = z
  550    continue
  560 continue
  go to 160
  570 if (q(klm1,n1) <= toler) go to 500
  kode = 1
  go to 590
  580 if (iphase == 1) go to 570
! prepare output.
  kode = 0
  590 sum = 0.d0
  do 600 j=1,n
     x(j) = 0.
  600 continue
  do 610 i=1,klm
     res(i) = 0.
  610 continue
  do 640 i=1,klm
     ii = q(i,n2)
     sn = 1.
     if (ii > 0) go to 620
     ii = -ii
     sn = -1.
  620    if (ii > n) go to 630
     x(ii) = sn*q(i,n1)
     go to 640
  630    iimn = ii - n
     res(iimn) = sn*q(i,n1)
     if (ii >= n1 .and. ii <= nk) sum = sum + &
      dble(q(i,n1))
  640 continue
  error = sum
  return
end
subroutine ychg (x, y, yold)
!
!*******************************************************************************
!
!! YCHG ???
!
  real x(*), y(*)
!
  y(1) = 0.0
  if (yold == 0.0) y(1) = 1.0
  return
end
function zeroin (f,ax,bx,aerr,rerr)
!
!*******************************************************************************
!
!! ZEROIN finds a zero of the function f(x) in the interval (ax,bx)
!
!
!  input...
!
!  f      function subprogram which evaluates f(x) for any x in the
!         closed interval (ax,bx). it is assumed that f is continuous,
!         and that f(ax) and f(bx) have different signs.
!  ax     left endpoint of the interval
!  bx     right endpoint of the interval
!  aerr   the absolute error tolerance to be satisfied
!  rerr   the relative error tolerance to be satisfied
!
!  output...
!
!         abcissa approximating a zero of f in the interval (ax,bx)
!
!
!  zeroin is a slightly modified translation of the algol procedure
!  zero given by richard brent in algorithms for minimization without
!  derivatives, prentice-hall, inc. (1973).
!
  real f,ax,bx,aerr,rerr
  external f
  real a,b,c,d,e,eps,fa,fb,fc,tol,xm,p,q,r,s,atol,rtol
!
!  compute eps, the relative machine precision
!
  eps = epsilon ( eps )
!
! initialization
!
  a = ax
  b = bx
  fa = f(a)
  fb = f(b)
  atol = 0.5*aerr
  rtol = max ( 0.5*rerr,2.0*eps)
!
! begin step
!
   10 c = a
  fc = fa
  d = b - a
  e = d
   20 if (abs(fc) >= abs(fb)) go to 40
  a = b
  b = c
  c = a
  fa = fb
  fb = fc
  fc = fa
!
! convergence test
!
   40 tol = rtol*max ( abs(b),abs(c)) + atol
  xm = 0.5*(c - b)
  if (abs(xm) <= tol) go to 90
  if (fb == 0.0) go to 90
!
! is bisection necessary
!
  if (abs(e) < tol) go to 70
  if (abs(fa) <= abs(fb)) go to 70
!
! is quadratic interpolation possible
!
  if (a /= c) go to 50
!
! linear interpolation
!
  s = fb/fc
  p = (c - b)*s
  q = 1.0 - s
  go to 60
!
! inverse quadratic interpolation
!
   50 q = fa/fc
  r = fb/fc
  s = fb/fa
  p = s*((c - b)*q*(q - r) - (b - a)*(r - 1.0))
  q = (q - 1.0)*(r - 1.0)*(s - 1.0)
!
! adjust signs
!
   60 if (p > 0.0) q = -q
  p = abs(p)
!
! is interpolation acceptable
!
  if ((2.0*p) >= (3.0*xm*q - abs(tol*q))) go to 70
  if (p >= abs(0.5*e*q)) go to 70
  e = d
  d = p/q
  go to 80
!
! bisection
!
   70 d = xm
  e = d
!
! complete step
!
   80 a = b
  fa = fb
  if (abs(d) > tol) b = b + d
  if (abs(d) <= tol) b = b + sign(tol,xm)
  fb = f(b)
  if ((fb*(fc/abs(fc))) > 0.0) go to 10
  go to 20
!
! done
!
   90 zeroin = b
  return
end
subroutine zzzjac(t,y,pd,n,rpar,ipar)
!
!*******************************************************************************
!
!! ZZZJAC is a dummy jacobian subroutine
!
  dimension y(n), pd(n,*)
  dimension rpar(*), ipar(*)
!
  t = 0.0
  return
end