subroutine abcon ( fun, c, num, ierr )

!*******************************************************************************
!
!! 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 )
!
!*******************************************************************************
!
!! ADCOMP computes the piecewise polynomial approximation on the 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 )
!
!*******************************************************************************
!
!! ADTRAN converts polynomial representation 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)
!
!*******************************************************************************
!
!! ARCEBE performs the backward elimination step in the 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)
!
!*******************************************************************************
!
!! ARCEBM performs the 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)
!
!*******************************************************************************
!
!! ARCEFM performs the forward modification step in the 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 **