! $Id: hmb.f90,v 1.2 2007/07/23 16:00:57 meyer Exp $

subroutine chkprm(iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,idmn,ierror)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this program checks the input parameters for errors

  real(rq) :: a,b,c,d

  external cofx

!     check definition of solution region

  ierror = 1
  if (a.ge.b .or. c.ge.d) return

!     check boundary switches

  ierror = 2
  if (mbdcnd.lt.0 .or. mbdcnd.gt.4) return
  ierror = 3
  if (nbdcnd.lt.0 .or. nbdcnd.gt.4) return

!     check first dimension in calling routine

  ierror = 5
  if (idmn .lt. 7) return

!     check m

  ierror = 6
  if (m.gt.(idmn-1) .or. m.lt.6) return

!     check n

  ierror = 7
  if (n .lt. 5) return

!     check iorder

  ierror = 8
  if (iorder.ne.2 .and. iorder.ne.4) return

!     check that equation is elliptic

  dlx = (b-a)/(m)
  do i=2,m
     xi = a+(i-1)*dlx
     call cofx (xi,ai,bi,ci)
     if (ai.le.0) then
        ierror=10
        return
     endif
  end do

!     no error found

  ierror = 0

  return

end subroutine chkprm

subroutine chksng(mbdcnd,nbdcnd,alpha,beta,cofx,singlr)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this subroutine checks if the pde   sepeli
!     must solve is a singular operator

  real(rq) :: alpha,beta

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  logical :: singlr

  external cofx

  singlr = .false.

!     check if the boundary conditions are
!     entirely periodic and/or mixed

  if ((mbdcnd.ne.0 .and. mbdcnd.ne.3) .or. (nbdcnd.ne.0 .and. nbdcnd .ne.3)) &
       return

!     check that mixed conditions are pure neuman

  if (mbdcnd .ne. 3) go to 10
  if (alpha.ne.0.0_rq .or. beta.ne.0.0_rq) return
10 continue

!     check that non-derivative coefficient functions
!     are zero
!
  do i=is,ms
     xi = ait+(i-1)*dlx
     call cofx (xi,ai,bi,ci)
     if (ci .ne. 0.0_rq) return
  end do

!     the operator must be singular if this point is reached

  singlr = .true.

  return

end subroutine chksng

! fishpak23  from portlib                                  11/06/79

!     this file contains four subroutines used by subroutines genbun
!     (file 15) and poistg (file 17).

subroutine cosgen(n,ijump,fnum,fden,a)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: a(*),fnum,fden

!     this subroutine computes required cosine values in ascending
!     order.  when ijump .gt. 1 the routine computes values
!
!        2*cos(j*pi/l) , j=1,2,...,l and j .ne. 0(mod n/ijump+1)
!
!     where l = ijump*(n/ijump+1).
!
!     when ijump = 1 it computes
!
!            2*cos((j-fnum)*pi/(n+fden)) ,  j=1, 2, ... ,n
!
!     where
!        fnum = 0.5, fden = 0.0,  for regular reduction values
!        fnum = 0.0, fden = 1.0, for b-r and c-r when istag = 1
!        fnum = 0.0, fden = 0.5, for b-r and c-r when istag = 2
!        fnum = 0.5, fden = 0.5, for b-r and c-r when istag = 2
!                                in poisn2 only.

  if (n .eq. 0) go to 105
  if (ijump .eq. 1) go to 103

  k3 = n/ijump+1
  k4 = k3-1
  pibyn = 3.14159265358979323_rq/(n+ijump)

  do k=1,ijump
     k1 = (k-1)*k3
     k5 = (k-1)*k4
     do i=1,k4
        x = k1+i
        k2 = k5+i
        a(k2) = -2._rq*cos(x*pibyn)
     end do
  end do

  go to 105

103 continue
  np1 = n+1
  y = 3.14159265358979323_rq/((n)+fden)

  do i=1,n
     x = (np1-i)-fnum
     a(i) = 2._rq*cos(x*y)
  end do

105 continue

  return

end subroutine cosgen

subroutine defer(cofx,idmn,usol,grhs)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this subroutine first approximates the trun1ation error given by
!     trun1(x,y)=dlx**2*tx+dly**2*ty where
!     tx=afun(x)*uxxxx/12.0+bfun(x)*uxxx/6.0 on the interior and
!     at the boundaries if periodic(here uxxx,uxxxx are the third
!     and fourth partial derivatives of u with respect to x).
!     tx is of the form afun(x)/3.0*(uxxxx/4.0+uxxx/dlx)
!     at x=a or x=b if the boundary condition there is mixed.
!     tx=0.0 along specified boundaries.  ty has symmetric form
!     in y with x,afun(x),bfun(x) replaced by y,dfun(y),efun(y).
!     the second order solution in usol is used to approximate
!     (via second order finite differencing) the trun1ation error
!     and the result is added to the right hand side in grhs
!     and then transferred to usol to be used as a new right
!     hand side when calling blktri for a fourth order solution.

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  real(rq) :: grhs(idmn,*),usol(idmn,*)

  external cofx

!     compute trun1ation error approximation over the entire mesh

  do i=is,ms
     xi = ait+(i-1)*dlx
     call cofx(xi,ai,bi,ci)
     do j=js,ns
!     compute partial derivative approximations at (xi,yj)
        call dx(usol,idmn,i,j,uxxx,uxxxx)
        call dy(usol,idmn,i,j,uyyy,uyyyy)
        tx = ai*uxxxx/12.0_rq+bi*uxxx/6.0_rq
        ty=uyyyy/12.0_rq
!     reset form of trun1ation if at boundary which is non-periodic
        if (kswx.eq.1 .or. (i.gt.1 .and. i.lt.k)) go to 10
        tx = ai/3.0_rq*(uxxxx/4.0_rq+uxxx/dlx)
10      if (kswy.eq.1 .or. (j.gt.1 .and. j.lt.l)) go to 20
        ty = (uyyyy/4.0_rq+uyyy/dly)/3.0_rq
20      grhs(i,j)=grhs(i,j)+dly**2*(dlx**2*tx+dly**2*ty)
     end do
  end do

!     reset the right hand side in usol

  do i=is,ms
     do j=js,ns
        usol(i,j) = grhs(i,j)
     end do
  end do

  return

end subroutine defer

subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: n,lr
  real(rq) :: r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n),delta

!     **********
!
!     subroutine dogleg
!
!     given an m by n matrix a, an n by n nonsingular diagonal
!     matrix d, an m-vector b, and a positive number delta, the
!     problem is to determine the convex combination x of the
!     gauss-newton and scaled gradient directions that minimizes
!     (a*x - b) in the least squares sense, subject to the
!     restriction that the euclidean norm of d*x be at most delta.
!
!     this subroutine completes the solution of the problem
!     if it is provided with the necessary information from the
!     qr factorization of a. that is, if a = q*r, where q has
!     orthogonal columns and r is an upper triangular matrix,
!     then dogleg expects the full upper triangle of r and
!     the first n components of (q transpose)*b.
!
!     the subroutine statement is
!
!       subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
!
!     where
!
!       n is a positive integer input variable set to the order of r.
!
!       r is an input array of length lr which must contain the upper
!         triangular matrix r stored by rows.
!
!       lr is a positive integer input variable not less than
!         (n*(n+1))/2.
!
!       diag is an input array of length n which must contain the
!         diagonal elements of the matrix d.
!
!       qtb is an input array of length n which must contain the first
!         n elements of the vector (q transpose)*b.
!
!       delta is a positive input variable which specifies an upper
!         bound on the euclidean norm of d*x.
!
!       x is an output array of length n which contains the desired
!         convex combination of the gauss-newton direction and the
!         scaled gradient direction.
!
!       wa1 and wa2 are work arrays of length n.
!
!     subprograms called
!
!       minpack-supplied ... enorm
!
!       fortran-supplied ... abs,amax1,amin1,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i,j,jj,jp1,k,l
  real(rq) :: alpha,bnorm,epsmch,gnorm,qnorm,sgnorm,sum,temp

!     epsmch is the machine precision.

  epsmch = errt_rq ! d1mach(3)

!     first, calculate the gauss-newton direction.

  jj = (n*(n + 1))/2 + 1
  do k = 1, n
     j = n - k + 1
     jp1 = j + 1
     jj = jj - k
     l = jj + 1
     sum = zero
     if (n .lt. jp1) go to 20
     do i = jp1, n
        sum = sum + r(l)*x(i)
        l = l + 1
     end do
20   continue
     temp = r(jj)
     if (temp .ne. zero) go to 40
     l = j
     do i = 1, j
        temp = max(temp,abs(r(l)))
        l = l + n - i
     end do
     temp = epsmch*temp
     if (temp .eq. zero) temp = epsmch
40   continue
     x(j) = (qtb(j) - sum)/temp
  end do

!     test whether the gauss-newton direction is acceptable.

  do j = 1, n
     wa1(j) = zero
     wa2(j) = diag(j)*x(j)
  end do
  qnorm = enorm(n,wa2)
  if (qnorm .le. delta) go to 140

!     the gauss-newton direction is not acceptable.
!     next, calculate the scaled gradient direction.

  l = 1
  do j = 1, n
     temp = qtb(j)
     do i = j, n
        wa1(i) = wa1(i) + r(l)*temp
        l = l + 1
     end do
     wa1(j) = wa1(j)/diag(j)
  end do

!     calculate the norm of the scaled gradient and test for
!     the special case in which the scaled gradient is zero.

  gnorm = enorm(n,wa1)
  sgnorm = zero
  alpha = delta/qnorm
  if (gnorm .eq. zero) go to 120

!     calculate the point along the scaled gradient
!     at which the quadratic is minimized.

  do j = 1, n
     wa1(j) = (wa1(j)/gnorm)/diag(j)
  end do
  l = 1
  do j = 1, n
     sum = zero
     do i = j, n
        sum = sum + r(l)*wa1(i)
        l = l + 1
     end do
     wa2(j) = sum
  end do
  temp = enorm(n,wa2)
  sgnorm = (gnorm/temp)/temp

!     test whether the scaled gradient direction is acceptable.

  alpha = zero
  if (sgnorm .ge. delta) go to 120

!     the scaled gradient direction is not acceptable.
!     finally, calculate the point along the dogleg
!     at which the quadratic is minimized.

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

120 continue

!     form appropriate convex combination of the gauss-newton
!     direction and the scaled gradient direction.

  temp = (one - alpha)*min(sgnorm,delta)
  do j = 1, n
     x(j) = temp*wa1(j) + alpha*x(j)
  end do

140 continue

  return

!     last card of subroutine dogleg.

end subroutine dogleg

subroutine dx(u,idmn,i,j,uxxx,uxxxx)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this program computes second order finite difference
!     approximations to the third and fourth x
!     partial derivatives of u at the (i,j) mesh point

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  real(rq) :: u(idmn,*),uxxx,uxxxx

  if (i.gt.2 .and. i.lt.(k-1)) go to 50
  if (i .eq. 1) go to 10
  if (i .eq. 2) go to 30
  if (i .eq. k-1) go to 60
  if (i .eq. k) go to 80

!     compute partial derivative approximations at x=a

10 if (kswx .eq. 1) go to 20

  uxxx = (-5.0_rq*u(1,j)+18.0_rq*u(2,j)-24.0_rq*u(3,j)+14.0_rq*u(4,j)- &
       3.0_rq*u(5,j))/(tdlx3)
  uxxxx = (3.0_rq*u(1,j)-14.0_rq*u(2,j)+26.0_rq*u(3,j)-24.0_rq*u(4,j)+ &
       11.0_rq*u(5,j)-2.0_rq*u(6,j))/dlx4

  return

!     periodic at x=a

20 uxxx = (-u(k-2,j)+2.0_rq*u(k-1,j)-2.0_rq*u(2,j)+u(3,j))/(tdlx3)
  uxxxx = (u(k-2,j)-4.0_rq*u(k-1,j)+6.0_rq*u(1,j)-4.0_rq*u(2,j)+u(3,j))/dlx4

  return

!     compute partial derivative approximations at x=a+dlx

30 if (kswx .eq. 1) go to 40

  uxxx = (-3.0_rq*u(1,j)+10.0_rq*u(2,j)-12.0_rq*u(3,j)+6.0_rq*u(4,j)-u(5,j))/ &
       tdlx3
  uxxxx = (2.0_rq*u(1,j)-9.0_rq*u(2,j)+16.0_rq*u(3,j)-14.0_rq*u(4,j)+ &
       6.0_rq*u(5,j)- u(6,j))/dlx4

  return

!     periodic at x=a+dlx

40 uxxx = (-u(k-1,j)+2.0_rq*u(1,j)-2.0_rq*u(3,j)+u(4,j))/(tdlx3)
  uxxxx = (u(k-1,j)-4.0_rq*u(1,j)+6.0_rq*u(2,j)-4.0_rq*u(3,j)+u(4,j))/dlx4

  return

!     compute partial derivative approximations on the interior

50 continue

  uxxx = (-u(i-2,j)+2.0_rq*u(i-1,j)-2.0_rq*u(i+1,j)+u(i+2,j))/tdlx3
  uxxxx = (u(i-2,j)-4.0_rq*u(i-1,j)+6.0_rq*u(i,j)-4.0_rq*u(i+1,j)+u(i+2,j))/ &
       dlx4

  return

!     compute partial derivative approximations at x=b-dlx

60 if (kswx .eq. 1) go to 70

  uxxx = (u(k-4,j)-6.0_rq*u(k-3,j)+12.0_rq*u(k-2,j)-10.0_rq*u(k-1,j)+ &
       3.0_rq*u(k,j))/tdlx3
  uxxxx = (-u(k-5,j)+6.0_rq*u(k-4,j)-14.0_rq*u(k-3,j)+16.0_rq*u(k-2,j)- &
       9.0_rq*u(k-1,j)+2.0_rq*u(k,j))/dlx4

  return

!     periodic at x=b-dlx

70 uxxx = (-u(k-3,j)+2.0_rq*u(k-2,j)-2.0_rq*u(1,j)+u(2,j))/tdlx3
  uxxxx = (u(k-3,j)-4.0_rq*u(k-2,j)+6.0_rq*u(k-1,j)-4.0_rq*u(1,j)+u(2,j))/ dlx4

  return

!     compute partial derivative approximations at x=b

80 uxxx = -(3.0_rq*u(k-4,j)-14.0_rq*u(k-3,j)+24.0_rq*u(k-2,j)- &
        18.0_rq*u(k-1,j)+ 5.0_rq*u(k,j))/tdlx3
  uxxxx = (-2.0_rq*u(k-5,j)+11.0_rq*u(k-4,j)-24.0_rq*u(k-3,j)+ &
       26.0_rq*u(k-2,j)- 14.0_rq*u(k-1,j)+3.0_rq*u(k,j))/dlx4

  return

end subroutine dx

subroutine dy(u,idmn,i,j,uyyy,uyyyy)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this program computes second order finite difference
!     approximations to the third and fourth y
!     partial derivatives of u at the (i,j) mesh point

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  real(rq) :: u(idmn,*),uyyy,uyyyy

  if (j.gt.2 .and. j.lt.(l-1)) go to 50
  if (j .eq. 1) go to 10
  if (j .eq. 2) go to 30
  if (j .eq. l-1) go to 60
  if (j .eq. l) go to 80

!     compute partial derivative approximations at y=c

10 if (kswy .eq. 1) go to 20

  uyyy = (-5.0_rq*u(i,1)+18.0_rq*u(i,2)-24.0_rq*u(i,3)+14.0_rq*u(i,4)- &
       3.0_rq*u(i,5))/tdly3
  uyyyy = (3.0_rq*u(i,1)-14.0_rq*u(i,2)+26.0_rq*u(i,3)-24.0_rq*u(i,4)+ &
       11.0_rq*u(i,5)-2.0_rq*u(i,6))/dly4

  return

!     periodic at x=a

20 uyyy = (-u(i,l-2)+2.0_rq*u(i,l-1)-2.0_rq*u(i,2)+u(i,3))/tdly3
  uyyyy = (u(i,l-2)-4.0_rq*u(i,l-1)+6.0_rq*u(i,1)-4.0_rq*u(i,2)+u(i,3))/dly4

  return

!     compute partial derivative approximations at y=c+dly

30 if (kswy .eq. 1) go to 40

  uyyy = (-3.0_rq*u(i,1)+10.0_rq*u(i,2)-12.0_rq*u(i,3)+6.0_rq*u(i,4)-u(i,5))/ &
       tdly3
  uyyyy = (2.0_rq*u(i,1)-9.0_rq*u(i,2)+16.0_rq*u(i,3)-14.0_rq*u(i,4)+ &
       6.0_rq*u(i,5)- u(i,6))/dly4

  return

!     periodic at y=c+dly

40 uyyy = (-u(i,l-1)+2.0_rq*u(i,1)-2.0_rq*u(i,3)+u(i,4))/tdly3
  uyyyy = (u(i,l-1)-4.0_rq*u(i,1)+6.0_rq*u(i,2)-4.0_rq*u(i,3)+u(i,4))/dly4

  return

!     compute partial derivative approximations on the interior

50 continue

  uyyy = (-u(i,j-2)+2.0_rq*u(i,j-1)-2.0_rq*u(i,j+1)+u(i,j+2))/tdly3
  uyyyy = (u(i,j-2)-4.0_rq*u(i,j-1)+6.0_rq*u(i,j)-4.0_rq*u(i,j+1)+u(i,j+2))/ &
       dly4

  return

!     compute partial derivative approximations at y=d-dly

60 if (kswy .eq. 1) go to 70

  uyyy = (u(i,l-4)-6.0_rq*u(i,l-3)+12.0_rq*u(i,l-2)-10.0_rq*u(i,l-1)+ &
       3.0_rq*u(i,l))/tdly3
  uyyyy = (-u(i,l-5)+6.0_rq*u(i,l-4)-14.0_rq*u(i,l-3)+16.0_rq*u(i,l-2)- &
       9.0_rq*u(i,l-1)+2.0_rq*u(i,l))/dly4

  return

!     periodic at y=d-dly

70 continue

  uyyy = (-u(i,l-3)+2.0_rq*u(i,l-2)-2.0_rq*u(i,1)+u(i,2))/tdly3
  uyyyy = (u(i,l-3)-4.0_rq*u(i,l-2)+6.0_rq*u(i,l-1)-4.0_rq*u(i,1)+u(i,2))/ dly4

  return

!     compute partial derivative approximations at y=d

80 uyyy = -(3.0_rq*u(i,l-4)-14.0_rq*u(i,l-3)+24.0_rq*u(i,l-2)- &
        18.0_rq*u(i,l-1)+ 5.0_rq*u(i,l))/tdly3
  uyyyy = (-2.0_rq*u(i,l-5)+11.0_rq*u(i,l-4)-24.0_rq*u(i,l-3)+ &
       26.0_rq*u(i,l-2)- 14.0_rq*u(i,l-1)+3.0_rq*u(i,l))/dly4

  return

end subroutine dy

function enorm(n,x)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: n
  real(rq) :: enorm,x(n)

!     **********
!
!     function enorm
!
!     given an n-vector x, this function calculates the
!     euclidean norm of x.
!
!     the euclidean norm is computed by accumulating the sum of
!     squares in three different sums. the sums of squares for the
!     small and large components are scaled so that no overflows
!     occur. non-destructive underflows are permitted. underflows
!     and overflows do not occur in the computation of the unscaled
!     sum of squares for the intermediate components.
!     the definitions of small, intermediate and large components
!     depend on two constants, rdwarf and rgiant. the main
!     restrictions on these constants are that rdwarf**2 not
!     underflow and rgiant**2 not overflow. the constants
!     given here are suitable for every known computer.
!
!     the function statement is
!
!       function enorm(n,x)
!
!     where
!
!       n is a positive integer input variable.
!
!       x is an input array of length n.
!
!     subprograms called
!
!       fortran-supplied ... abs,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i
  real(rq) :: agiant,floatn,rdwarf,rgiant,s1,s2,s3,xabs,x1max,x3max
  data rdwarf,rgiant /3.834d-20,1.304d19/

  s1 = zero
  s2 = zero
  s3 = zero
  x1max = zero
  x3max = zero
  floatn = n
  agiant = rgiant/floatn
  do i = 1, n
     xabs = abs(x(i))
     if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70
     if (xabs .le. rdwarf) go to 30

!              sum for large components.

     if (xabs .le. x1max) go to 10
     s1 = one + s1*(x1max/xabs)**2
     x1max = xabs
     go to 20
10   continue
     s1 = s1 + (xabs/x1max)**2
20   continue
     go to 60
30   continue

!              sum for small components.

     if (xabs .le. x3max) go to 40
     s3 = one + s3*(x3max/xabs)**2
     x3max = xabs
     go to 50
40   continue
     if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2
50   continue
60   continue
     go to 80
70   continue

!           sum for intermediate components.

     s2 = s2 + xabs**2
80   continue
  end do

!     calculation of norm.

  if (s1 .eq. zero) go to 100
  enorm = x1max*sqrt(s1+(s2/x1max)/x1max)
  go to 130
100 continue
  if (s2 .eq. zero) go to 110
  if (s2 .ge. x3max) enorm = sqrt(s2*(one+(x3max/s2)*(x3max*s3)))
  if (s2 .lt. x3max) enorm = sqrt(x3max*((s2/x3max)+(x3max*s3)))
  go to 120
110 continue
  enorm = x3max*sqrt(s3)
120 continue
130 continue

  return

end function enorm

!     last card of function enorm.

! fishpak24  from portlib                                  11/06/79

subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1,wa2,nprint)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: n,ldfjac,iflag,ml,mu
  real(rq) :: epsfcn
  real(rq) :: x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n)

!     **********
!
!     subroutine fdjac1
!
!     this subroutine computes a forward-difference approximation
!     to the n by n jacobian matrix associated with a specified
!     problem of n functions in n variables. if the jacobian has
!     a banded form, then function evaluations are saved by only
!     approximating the nonzero terms.
!
!     the subroutine statement is
!
!       subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,
!                         wa1,wa2)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(n,x,fvec,iflag)
!         integer n,iflag
!         real x(n),fvec(n)
!         ----------
!         calculate the functions at x and
!         return this vector in fvec.
!         ----------
!         return
!         end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of fdjac1.
!         in this case set iflag to a negative integer.
!
!       n is a positive integer input variable set to the number
!         of functions and variables.
!
!       x is an input array of length n.
!
!       fvec is an input array of length n which must contain the
!         functions evaluated at x.
!
!       fjac is an output n by n array which contains the
!         approximation to the jacobian matrix evaluated at x.
!
!       ldfjac is a positive integer input variable not less than n
!         which specifies the leading real of the array fjac.
!
!       iflag is an integer variable which can be used to terminate
!         the execution of fdjac1. see description of fcn.
!
!       ml is a nonnegative integer input variable which specifies
!         the number of subdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         ml to at least n - 1.
!
!       epsfcn is an input variable used in determining a suitable
!         step length for the forward-difference approximation. this
!         approximation assumes that the relative errors in the
!         functions are of the order of epsfcn. if epsfcn is less
!         than the machine precision, it is assumed that the relative
!         errors in the functions are of the order of the machine
!         precision.
!
!       mu is a nonnegative integer input variable which specifies
!         the number of superdiagonals within the band of the
!         jacobian matrix. if the jacobian is not banded, set
!         mu to at least n - 1.
!
!       wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at
!         least n, then the jacobian is considered dense, and wa2 is
!         not referenced.
!
!     subprograms called
!
!       fortran-supplied ... abs,amax1,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i,j,k,msum
  real(rq) :: eps,epsmch,h,temp

!     epsmch is the machine precision.

  epsmch = errt_rq ! d1mach(3)
  eps = sqrt(max(epsfcn,epsmch))
  msum = ml + mu + 1
  if (msum .lt. n) go to 40

!        computation of dense approximate jacobian.

  do j = 1, n
     temp = x(j)
     h = eps*abs(temp)
     if (h .eq. zero) h = eps
     x(j) = temp + h
     call fcn(n,x,wa1,iflag,nprint)
     if (iflag .lt. 0) go to 30
     x(j) = temp
     do i = 1, n
        fjac(i,j) = (wa1(i) - fvec(i))/h
     end do
  end do
30 continue
  go to 110
40 continue

!        computation of banded approximate jacobian.

  do k = 1, msum
     do j = k, n, msum
        wa2(j) = x(j)
        h = eps*abs(wa2(j))
        if (h .eq. zero) h = eps
        x(j) = wa2(j) + h
     end do
     call fcn(n,x,wa1,iflag,nprint)
     if (iflag .lt. 0) go to 100
     do j = k, n, msum
        x(j) = wa2(j)
        h = eps*abs(wa2(j))
        if (h .eq. zero) h = eps
        do i = 1, n
           fjac(i,j) = zero
           if (i .ge. j - mu .and. i .le. j + ml) &
                fjac(i,j) = (wa1(i) - fvec(i))/h
        end do
     end do
  end do

100 continue
110 continue

  return

!     last card of subroutine fdjac1.

end subroutine fdjac1

! fishpak15  from portlib                                  11/06/79

subroutine genbun(nperod,n,mperod,m,a,b,c,idimy,y,ierror,w)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: y(idimy,*)
  real(rq) :: w(*),b(*),a(*),c(*)

  ierror = 0

  if (m .le. 2) ierror = 1
  if (n .le. 2) ierror = 2
  if (idimy .lt. m) ierror = 3
  if (nperod.lt.0 .or. nperod.gt.4) ierror = 4
  if (mperod.lt.0 .or. mperod.gt.1) ierror = 5
  if (mperod .eq. 1) go to 102

  do i=2,m
     if (a(i) .ne. c(1)) go to 103
     if (c(i) .ne. c(1)) go to 103
     if (b(i) .ne. b(1)) go to 103
  end do

  go to 104

102 if (a(1).ne.0._rq .or. c(m).ne.0._rq) ierror = 7

  go to 104

103 ierror = 6

104 if (ierror .ne. 0) return

  mp1 = m+1
  iwba = mp1
  iwbb = iwba+m
  iwbc = iwbb+m
  iwb2 = iwbc+m
  iwb3 = iwb2+m
  iww1 = iwb3+m
  iww2 = iww1+m
  iww3 = iww2+m
  iwd = iww3+m
  iwtcos = iwd+m
  iwp = iwtcos+4*n

  do i=1,m
     k = iwba+i-1
     w(k) = -a(i)
     k = iwbc+i-1
     w(k) = -c(i)
     k = iwbb+i-1
     w(k) = 2._rq-b(i)
     do j=1,n
        y(i,j) = -y(i,j)
     end do
  end do

  mp = mperod+1
  np = nperod+1
  go to (114,107),mp

107 go to (108,109,110,111,123),np
108 call poisp2 (m,n,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), &
         w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), w(iwp))
  go to 112
109 call poisd2 (m,n,1,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iww1), &
         w(iwd),w(iwtcos),w(iwp))
  go to 112
110 call poisn2 (m,n,1,2,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), &
         w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), w(iwp))
  go to 112
111 call poisn2 (m,n,1,1,w(iwba),w(iwbb),w(iwbc),y,idimy,w,w(iwb2), &
         w(iwb3),w(iww1),w(iww2),w(iww3),w(iwd),w(iwtcos), w(iwp))
112 ipstor = w(iww1)
  irev = 2
  if (nperod .eq. 4) go to 124
113 go to (127,133),mp
114 continue

!     reorder unknowns when mp =0

  mh = (m+1)/2
  mhm1 = mh-1
  modd = 1
  if (mh*2 .eq. m) modd = 2
  do j=1,n
     do i=1,mhm1
        mhpi = mh+i
        mhmi = mh-i
        w(i) = y(mhmi,j)-y(mhpi,j)
        w(mhpi) = y(mhmi,j)+y(mhpi,j)
     end do
     w(mh) = 2._rq*y(mh,j)
     go to (117,116),modd
116  w(m) = 2._rq*y(m,j)
117  continue
     do i=1,m
        y(i,j) = w(i)
     end do
  end do
  k = iwbc+mhm1-1
  i = iwba+mhm1
  w(k) = 0._rq
  w(i) = 0._rq
  w(k+1) = 2._rq*w(k+1)
  go to (120,121),modd
120 continue
  k = iwbb+mhm1-1
  w(k) = w(k)-w(i-1)
  w(iwbc-1) = w(iwbc-1)+w(iwbb-1)
  go to 122
121 w(iwbb-1) = w(k+1)
122 continue
  go to 107

!     reverse columns when nperod = 4.

123 irev = 1
  nby2 = n/2
124 do j=1,nby2
     mskip = n+1-j
     do i=1,m
        a1 = y(i,j)
        y(i,j) = y(i,mskip)
        y(i,mskip) = a1
     end do
  end do
  go to (110,113),irev
127 continue
  do j=1,n
     do i=1,mhm1
        mhmi = mh-i
        mhpi = mh+i
        w(mhmi) = .5_rq*(y(mhpi,j)+y(i,j))
        w(mhpi) = .5_rq*(y(mhpi,j)-y(i,j))
     end do
     w(mh) = .5_rq*y(mh,j)
     go to (130,129),modd
129  w(m) = .5_rq*y(m,j)
130  continue
     do i=1,m
        y(i,j) = w(i)
     end do
  end do
133 continue

!     return storage requirements for w array.

  w(1) = ipstor+iwp-1

  return

end subroutine genbun

subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag,mode,&
     factor,nprint,info,nfev,fjac,ldfjac,r,lr, qtf,wa1,wa2,wa3,wa4)

  use teq_mod, only : STdoUT,t_logunit
  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr
  real(rq) :: xtol,epsfcn,factor
  real(rq) :: x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),qtf(n), &
       wa1(n),wa2(n),wa3(n),wa4(n)

  external fcn

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

  integer :: i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2
  integer :: iwa(1)
  logical :: jeval,sing_dummy
  real(rq) :: actred,delta,epsmch,fnorm,fnorm1,pnorm,prered,p1,p5, &
       p001,p0001,ratio,sum,temp,xnorm
  data p1,p5,p001,p0001/1.0d-1,5.0d-1,1.0d-3,1.0d-4/

!     epsmch is the machine precision.

  epsmch = errt_rq ! d1mach(3)

  info = 0
  iflag = 0
  nfev = 0

!     check the input parameters for errors.

  if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 .or. ml .lt. 0 .or. &
       mu .lt. 0 .or. factor .le. zero .or. ldfjac .lt. n .or. &
       lr .lt. (n*(n + 1))/2) go to 300
  if (mode .ne. 2) go to 20
  do j = 1, n
     if (diag(j) .le. zero) go to 300
  end do

20 continue

!     evaluate the function at the starting point
!     and calculate its norm.

  iflag = 1
  call fcn(n,x,fvec,iflag,nprint)
  nfev = 1
  if (iflag .lt. 0) go to 300
  fnorm = enorm(n,fvec)

!     determine the number of calls to fcn needed to compute
!     the jacobian matrix.

  msum = min(ml+mu+1,n)

!     initialize iteration counter and monitors.

  iter = 1
  ncsuc = 0
  ncfail = 0
  nslow1 = 0
  nslow2 = 0

!     beginning of the outer loop.

30 continue

  jeval = .true.

!        calculate the jacobian matrix.

  iflag = 2
  call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1,wa2,nprint)
  nfev = nfev + msum
  if (iflag .lt. 0) go to 300

!        compute the qr factorization of the jacobian.

  call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)

!        on the first iteration and if mode is 1, scale according
!        to the norms of the columns of the initial jacobian.

  if (iter .ne. 1) go to 70
  if (mode .eq. 2) go to 50
  do j = 1, n
     diag(j) = wa2(j)
     if (wa2(j) .eq. zero) diag(j) = one
  end do

50 continue

!        on the first iteration, calculate the norm of the scaled x
!        and initialize the step bound delta.

  do j = 1, n
     wa3(j) = diag(j)*x(j)
  end do

  xnorm = enorm(n,wa3)
  delta = factor*xnorm
  if (delta .eq. zero) delta = factor

   70 continue

!        form (q transpose)*fvec and store in qtf.

  do i = 1, n
     qtf(i) = fvec(i)
  end do

  do j = 1, n
     if (fjac(j,j) .eq. zero) go to 110
     sum = zero
     do i = j, n
        sum = sum + fjac(i,j)*qtf(i)
     end do
     temp = -sum/fjac(j,j)
     do i = j, n
        qtf(i) = qtf(i) + fjac(i,j)*temp
     end do
110  continue
  end do

!        copy the triangular factor of the qr factorization into r.

  sing_dummy = .false.

  do j = 1, n
     l = j
     jm1 = j - 1
     if (jm1 .lt. 1) go to 140
     do i = 1, jm1
        r(l) = fjac(i,j)
        l = l + n - i
     end do
140  continue
     r(l) = wa1(j)
     if (wa1(j) .eq. zero) sing_dummy = .true.
  end do

!        accumulate the orthogonal factor in fjac.

  call qform(n,n,fjac,ldfjac,wa1)

!        rescale if necessary.

  if (mode .eq. 2) go to 170
  do j = 1, n
     diag(j) = max(diag(j),wa2(j))
  end do

170 continue

!        beginning of the inner loop.

180 continue

!           if requested, call fcn to enable printing of iterates.

  if (nprint .le. 0) go to 190
  iflag = 0
  if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag,nprint)
  if (iflag .lt. 0) go to 300

190 continue

!           determine the direction p.

  call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)

!           store the direction p and x + p. calculate the norm of p.

  do j = 1, n
     wa1(j) = -wa1(j)
     wa2(j) = x(j) + wa1(j)
     wa3(j) = diag(j)*wa1(j)
  end do

  pnorm = enorm(n,wa3)

!           on the first iteration, adjust the initial step bound.

  if (iter .eq. 1) delta = min(delta,pnorm)

!           evaluate the function at x + p and calculate its norm.

  iflag = 1
  call fcn(n,wa2,wa4,iflag,nprint)
  nfev = nfev + 1
  if (iflag .lt. 0) go to 300
  fnorm1 = enorm(n,wa4)

!           compute the scaled actual reduction.

  actred = -one
  if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2

!           compute the scaled predicted reduction.

  l = 1

  do i = 1, n
     sum = zero
     do j = i, n
        sum = sum + r(l)*wa1(j)
        l = l + 1
     end do
     wa3(i) = qtf(i) + sum
  end do

  temp = enorm(n,wa3)
  prered = zero
  if (temp .lt. fnorm) prered = one - (temp/fnorm)**2

!           compute the ratio of the actual to the predicted
!           reduction.

  ratio = zero
  if (prered .gt. zero) ratio = actred/prered

!           update the step bound.

  if (ratio .ge. p1) go to 230
  ncsuc = 0
  ncfail = ncfail + 1
  delta = p5*delta
  go to 240
230 continue
  ncfail = 0
  ncsuc = ncsuc + 1
  if (ratio .ge. p5 .or. ncsuc .gt. 1) delta = max(delta,pnorm/p5)
  if (abs(ratio-one) .le. p1) delta = pnorm/p5
240 continue

!           test for successful iteration.

  if (ratio .lt. p0001) go to 260

!           successful iteration. update x, fvec, and their norms.

  do j = 1, n
     x(j) = wa2(j)
     wa2(j) = diag(j)*x(j)
     fvec(j) = wa4(j)
  end do

  xnorm = enorm(n,wa2)
  fnorm = fnorm1
  iter = iter + 1

260 continue

!           determine the progress of the iteration.

  nslow1 = nslow1 + 1
  if (actred .ge. p001) nslow1 = 0
  if (jeval) nslow2 = nslow2 + 1
  if (actred .ge. p1) nslow2 = 0

!           test for convergence.

  if (delta .le. xtol*xnorm .or. fnorm .le. xtol) info = 1

  if (nprint.ne.0) then

     write(STdoUT,10000) (wa1(i)/x(i)-1,i=1,n)
     if (t_logunit .ge. 0) then
        write(t_logunit,10000) (wa1(i)/x(i)-1,i=1,n)
     endif

     write(STdoUT,10001) (fvec(i),i=1,n)
     if (t_logunit .ge. 0) then
        write(t_logunit,10001) (fvec(i),i=1,n)
     endif

10000 format('X  =',6(1pg12.4))
10001 format('F  = ',6(1pg12.4))
  endif

  if (info .ne. 0) go to 300

!           tests for termination and stringent tolerances.

  if (nfev .ge. maxfev) info = 2
  if (p1*max(p1*delta,pnorm) .le. epsmch*xnorm) info = 3
  if (nslow2 .eq. 5) info = 4
  if (nslow1 .eq. 10) info = 5
  if (info .ne. 0) go to 300

!           criterion for recalculating jacobian approximation
!           by forward differences.

  if (ncfail .eq. 2) go to 290

!           calculate the rank one modification to the jacobian
!           and update qtf if necessary.

  do j = 1, n
     sum = zero
     do i = 1, n
        sum = sum + fjac(i,j)*wa4(i)
     end do
     wa2(j) = (sum - wa3(j))/pnorm
     wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
     if (ratio .ge. p0001) qtf(j) = sum
  end do

!           compute the qr factorization of the updated jacobian.

  call r1updt(n,n,r,lr,wa1,wa2,wa3,sing_dummy)
  call r1mpyq(n,n,fjac,ldfjac,wa2,wa3)
  call r1mpyq(1,n,qtf,1,wa2,wa3)

!           end of the inner loop.

  jeval = .false.
  go to 180

290 continue

!        end of the outer loop.

  go to 30

300 continue

!     termination, either normal or user imposed.

  if (iflag .lt. 0) info = iflag
  iflag = 0
  if (nprint .gt. 0) call fcn(n,x,fvec,iflag,nprint)

  return

!     last card of subroutine hybrd.

end subroutine hybrd

subroutine hybrd2(fcn,n,x,fvec,tol,info,wa,lwa)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: n,info,lwa
  real(rq) :: tol
  real(rq) :: x(n),fvec(n),wa(lwa)

  external fcn

!     **********
!
!     subroutine hybrd2
!
!     the purpose of hybrd1 is to find a zero of a system of
!     n nonlinear functions in n variables by a modification
!     of the powell hybrid method. this is done by using the
!     more general nonlinear equation solver hybrd. the user
!     must provide a subroutine which calculates the functions.
!     the jacobian is then calculated by a forward-difference
!     approximation.
!
!     the subroutine statement is
!
!       subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)
!
!     where
!
!       fcn is the name of the user-supplied subroutine which
!         calculates the functions. fcn must be declared
!         in an external statement in the user calling
!         program, and should be written as follows.
!
!         subroutine fcn(n,x,fvec,iflag)
!         integer n,iflag
!         real x(n),fvec(n)
!         ----------
!         calculate the functions at x and
!         return this vector in fvec.
!         ---------
!         return
!         end
!
!         the value of iflag should not be changed by fcn unless
!         the user wants to terminate execution of hybrd1.
!         in this case set iflag to a negative integer.
!
!       n is a positive integer input variable set to the number
!         of functions and variables.
!
!       x is an array of length n. on input x must contain
!         an initial estimate of the solution vector. on output x
!         contains the final estimate of the solution vector.
!
!       fvec is an output array of length n which contains
!         the functions evaluated at the output x.
!
!       tol is a nonnegative input variable. termination occurs
!         when the algorithm estimates that the relative error
!         between x and the solution is at most tol.
!
!       info is an integer output variable. if the user has
!         terminated execution, info is set to the (negative)
!         value of iflag. see description of fcn. otherwise,
!         info is set as follows.
!
!         info = 0   improper input parameters.
!
!         info = 1   algorithm estimates that the relative error
!                    between x and the solution is at most tol.
!
!         info = 2   number of calls to fcn has reached or exceeded
!                    200*(n+1).
!
!         info = 3   tol is too small. no further improvement in
!                    the approximate solution x is possible.
!
!         info = 4   iteration is not making good progress.
!
!       wa is a work array of length lwa.
!
!       lwa is a positive integer input variable not less than
!         (n*(3*n+13))/2.
!
!     subprograms called
!
!       user-supplied ...... fcn
!
!       minpack-supplied ... hybrd
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: index,j,lr,maxfev,ml,mode,mu,nfev,nprint
  real(rq) :: epsfcn,factor,xtol
!     data factor /1.0e2/
  data factor /0.1_rq/

  info = 0

!     check the input parameters for errors.

  if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) go to 20

!     call hybrd.

  maxfev = 200*(n + 1)
  xtol = tol
  ml = n - 1
  mu = n - 1
!     set epsfcn to 1.e-4 for HEQ problem
!     epsfcn = zero
  epsfcn = 1.d-4
  mode = 2

  do j = 1, n
     wa(j) = one
  end do

  nprint = 0
  lr = (n*(n + 1))/2
  index = 6*n + lr

  call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, &
       factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, wa(n+1), &
       wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))

  if (info .eq. 5) info = 4

20 continue

  return

!     last card of subroutine hybrd1.

end subroutine hybrd2

subroutine merge (tcos,i1,m1,i2,m2,i3)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: tcos(*)

!     this subroutine merges two ascending strings of numbers in the
!     array tcos.  the first string is of length m1 and starts at
!     tcos(i1+1).  the second string is of length m2 and starts at
!     tcos(i2+1).  the merged string goes into tcos(i3+1).

  j1 = 1
  j2 = 1
  j = i3
  if (m1 .eq. 0) go to 107
  if (m2 .eq. 0) go to 104
101 j = j+1
  l = j1+i1
  x = tcos(l)
  l = j2+i2
  y = tcos(l)
  if (x-y) 102,102,103
102 tcos(j) = x
  j1 = j1+1
  if (j1 .gt. m1) go to 106
  go to 101
  103 tcos(j) = y
  j2 = j2+1
  if (j2 .le. m2) go to 101
  if (j1 .gt. m1) go to 109
104 k = j-j1+1
  do j=j1,m1
     m = k+j
     l = j+i1
     tcos(m) = tcos(l)
  end do
  go to 109
106 continue
  if (j2 .gt. m2) go to 109
107 k = j-j2+1
  do j=j2,m2
     m = k+j
     l = j+i2
     tcos(m) = tcos(l)
  end do
109 continue

  return

end subroutine merge

subroutine minsol(usol,idmn,zn,zm,pertrb)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this subroutine orthogonalizes the array usol with respect to
!     the constant array in a weighted least squares norm

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  real(rq) :: usol(idmn,*),zn(*),zm(*),pertrb

!     entry at minsol occurrs when the final solution is
!     to be minimized with respect to the weighted
!     least squares norm

  istr = 1
  ifnl = k
  jstr = 1
  jfnl = l

!     compute weighted inner products

  ute = 0.0_rq
  ete = 0.0_rq
  do i=is,ms
     ii = i-is+1
     do j=js,ns
        jj = j-js+1
        ete = ete+zm(ii)*zn(jj)
        ute = ute+usol(i,j)*zm(ii)*zn(jj)
     end do
  end do

!     set perturbation parameter

  pertrb = ute/ete

!     subtract off constant pertrb

  do i=istr,ifnl
     do j=jstr,jfnl
        usol(i,j) = usol(i,j)-pertrb
     end do
  end do

  return

end subroutine minsol

subroutine orthog(usol,idmn,zn,zm,pertrb)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this subroutine orthogonalizes the array usol with respect to
!     the constant array in a weighted least squares norm

  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is,ms,js,ns,dlx,dly, &
       tdlx3,tdly3,dlx4,dly4

  real(rq) :: usol(idmn,*),zn(*),zm(*),pertrb

  istr = is
  ifnl = ms
  jstr = js
  jfnl = ns

!     compute weighted inner products

  ute = 0.0_rq
  ete = 0.0_rq
  do i=is,ms
     ii = i-is+1
     do j=js,ns
        jj = j-js+1
        ete = ete+zm(ii)*zn(jj)
        ute = ute+usol(i,j)*zm(ii)*zn(jj)
     end do
  end do

!     set perturbation parameter

  pertrb = ute/ete

!     subtract off constant pertrb

  do i=istr,ifnl
     do j=jstr,jfnl
        usol(i,j) = usol(i,j)-pertrb
     end do
  end do

  return

end subroutine orthog

subroutine poisd2(mr,nr,istag,ba,bb,bc,q,idimq,b,w,d,tcos,p)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     subroutine to solve poisson"s equation for dirichlet boundary
!     conditions.
!
!     istag = 1 if the last diagonal block is the matrix a.
!     istag = 2 if the last diagonal block is the matrix a+i.

  real(rq) :: q(idimq,*),ba(*),bb(*),bc(*),tcos(*),b(*),d(*),w(*),p(*)

  m = mr
  n = nr
  jsh = 0
  fi = 1._rq/(istag)
  ip = -m
  ipstor = 0
  go to (101,102),istag
101 kr = 0
  irreg = 1
  if (n .gt. 1) go to 106
  tcos(1) = 0._rq
  go to 103
102 kr = 1
  jstsav = 1
  irreg = 2
  if (n .gt. 1) go to 106
  tcos(1) = -1._rq
103 do i=1,m
     b(i) = q(i,1)
  end do
  call trix(1,0,m,ba,bb,bc,b,tcos,d,w)
  do i=1,m
     q(i,1) = b(i)
  end do
  go to 183
106 lr = 0
  do i=1,m
     p(i) = 0._rq
  end do

  nun = n
  jst = 1
  jsp = n

!     irreg = 1 when no irregularities have occurred, otherwise it is 2.

108 l = 2*jst
  nodd = 2-2*((nun+1)/2)+nun

!     nodd = 1 when nun is odd, otherwise it is 2.

  go to (110,109),nodd
109 jsp = jsp-l
  go to 111
110 jsp = jsp-jst
  if (irreg .ne. 1) jsp = jsp-l

111 continue

!     regular reduction

  call cosgen(jst,1,0.5_rq,0.0_rq,tcos)

  if (l .gt. jsp) go to 118

  do j=l,jsp,l
     jm1 = j-jsh
     jp1 = j+jsh
     jm2 = j-jst
     jp2 = j+jst
     jm3 = jm2-jsh
     jp3 = jp2+jsh
     if (jst .ne. 1) go to 113
     do i=1,m
        b(i) = 2._rq*q(i,j)
        q(i,j) = q(i,jm2)+q(i,jp2)
     end do
     go to 115
113  do i=1,m
        t = q(i,j)-q(i,jm1)-q(i,jp1)+q(i,jm2)+q(i,jp2)
        b(i) = t+q(i,j)-q(i,jm3)-q(i,jp3)
        q(i,j) = t
     end do
115  continue
     call trix(jst,0,m,ba,bb,bc,b,tcos,d,w)
     do i=1,m
        q(i,j) = q(i,j)+b(i)
     end do
  end do

!     reduction for last unknown

118 go to (119,136),nodd
119 go to (152,120),irreg

!     odd number of unknowns

120 jsp = jsp+l
  j = jsp
  jm1 = j-jsh
  jp1 = j+jsh
  jm2 = j-jst
  jp2 = j+jst
  jm3 = jm2-jsh
  go to (123,121),istag
121 continue
  if (jst .ne. 1) go to 123
  do i=1,m
     b(i) = q(i,j)
     q(i,j) = 0._rq
  end do
  go to 130
123 go to (124,126),noddpr
124 do i=1,m
     ip1 = ip+i
     b(i) = .5_rq*(q(i,jm2)-q(i,jm1)-q(i,jm3))+p(ip1)+q(i,j)
  end do
  go to 128
126 do i=1,m
     b(i) = .5_rq*(q(i,jm2)-q(i,jm1)-q(i,jm3))+q(i,jp2)-q(i,jp1)+q(i,j)
  end do
128 do i=1,m
     q(i,j) = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))
  end do
130 call trix(jst,0,m,ba,bb,bc,b,tcos,d,w)
  ip = ip+m
  ipstor = max(ipstor,ip+m)
  do i=1,m
     ip1 = ip+i
     p(ip1) = q(i,j)+b(i)
     b(i) = q(i,jp2)+p(ip1)
  end do
  if (lr .ne. 0) go to 133
  do i=1,jst
     krpi = kr+i
     tcos(krpi) = tcos(i)
  end do
  go to 134
133 continue
  call cosgen(lr,jstsav,0._rq,fi,tcos(jst+1))
  call merge(tcos,0,jst,jst,lr,kr)
134 continue
  call cosgen(kr,jstsav,0.0_rq,fi,tcos)
  call trix(kr,kr,m,ba,bb,bc,b,tcos,d,w)
  do i=1,m
     ip1 = ip+i
     q(i,j) = q(i,jm2)+b(i)+p(ip1)
  end do
  lr = kr
  kr = kr+l
  go to 152

!     even number of unknowns

136 jsp = jsp+l
  j = jsp
  jm1 = j-jsh
  jp1 = j+jsh
  jm2 = j-jst
  jp2 = j+jst
  jm3 = jm2-jsh
  go to (137,138),irreg
137 continue
  jstsav = jst
  ideg = jst
  kr = l
  go to 139
138 call cosgen(kr,jstsav,0.0_rq,fi,tcos)
  call cosgen(lr,jstsav,0.0_rq,fi,tcos(kr+1))
  ideg = kr
  kr = kr+jst
139 if (jst .ne. 1) go to 141
  irreg = 2
  do i=1,m
     b(i) = q(i,j)
     q(i,j) = q(i,jm2)
  end do
  go to 150
141 do i=1,m
     b(i) = q(i,j)+.5_rq*(q(i,jm2)-q(i,jm1)-q(i,jm3))
  end do
  go to (143,145),irreg
143 do i=1,m
     q(i,j) = q(i,jm2)+.5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))
  end do
  irreg = 2
  go to 150
145 continue
  go to (146,148),noddpr
146 do i=1,m
     ip1 = ip+i
     q(i,j) = q(i,jm2)+p(ip1)
  end do
  ip = ip-m
  go to 150
148 do i=1,m
     q(i,j) = q(i,jm2)+q(i,j)-q(i,jm1)
  end do
150 call trix (ideg,lr,m,ba,bb,bc,b,tcos,d,w)
  do i=1,m
     q(i,j) = q(i,j)+b(i)
  end do
152 nun = nun/2
  noddpr = nodd
  jsh = jst
  jst = 2*jst
  if (nun .ge. 2) go to 108

!     start solution.

  j = jsp
  do i=1,m
     b(i) = q(i,j)
  end do
  go to (154,155),irreg
154 continue
  call cosgen(jst,1,0.5_rq,0.0_rq,tcos)
  ideg = jst
  go to 156
155 kr = lr+jst
  call cosgen(kr,jstsav,0.0_rq,fi,tcos)
  call cosgen(lr,jstsav,0.0_rq,fi,tcos(kr+1))
  ideg = kr
156 continue
  call trix(ideg,lr,m,ba,bb,bc,b,tcos,d,w)
  jm1 = j-jsh
  jp1 = j+jsh
  go to (157,159),irreg
157 do i=1,m
     q(i,j) = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i)
  end do
  go to 164
159 go to (160,162),noddpr
160 do i=1,m
     ip1 = ip+i
     q(i,j) = p(ip1)+b(i)
  end do
  ip = ip-m
  go to 164
162 do i=1,m
     q(i,j) = q(i,j)-q(i,jm1)+b(i)
  end do
164 continue

!     start back substitution.

  jst = jst/2
  jsh = jst/2
  nun = 2*nun
  if (nun .gt. n) go to 183
!  do 182 j=jst,n,l
  do j=jst,n,l
     jm1 = j-jsh
     jp1 = j+jsh
     jm2 = j-jst
     jp2 = j+jst
     if (j .gt. jst) go to 166
     do i=1,m
        b(i) = q(i,j)+q(i,jp2)
     end do
     go to 170
166  if (jp2 .le. n) go to 168
     do i=1,m
        b(i) = q(i,j)+q(i,jm2)
     end do
     if (jst .lt. jstsav) irreg = 1
     go to (170,171),irreg
168  do i=1,m
        b(i) = q(i,j)+q(i,jm2)+q(i,jp2)
     end do
170  continue
     call cosgen(jst,1,0.5_rq,0.0_rq,tcos)
     ideg = jst
     jdeg = 0
     go to 172
171  if (j+l .gt. n) lr = lr-jst
     kr = jst+lr
     call cosgen(kr,jstsav,0.0_rq,fi,tcos)
     call cosgen(lr,jstsav,0.0_rq,fi,tcos(kr+1))
     ideg = kr
     jdeg = lr
172  continue
     call trix(ideg,jdeg,m,ba,bb,bc,b,tcos,d,w)
     if (jst .gt. 1) go to 174
     do i=1,m
        q(i,j) = b(i)
     end do
     go to 182
174  if (jp2 .gt. n) go to 177
175  do i=1,m
        q(i,j) = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i)
     end do
     go to 182
177  go to (175,178),irreg
178  if (j+jsh .gt. n) go to 180
     do i=1,m
        ip1 = ip+i
        q(i,j) = b(i)+p(ip1)
     end do
     ip = ip-m
     go to 182
180  do i=1,m
        q(i,j) = b(i)+q(i,j)-q(i,jm1)
     end do
! I had flipped the two lines below! JAC 05/14/05
182  continue
  end do
  l = l/2
  go to 164
183 continue

!     return storage requirements for p vectors.

  w(1) = ipstor

  return

end subroutine poisd2

subroutine poisn2(m,n,istag,mixbnd,a,bb,c,q,idimq,b,b2,b3,w,w2,w3,d,tcos,p)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     subroutine to solve poisson's equation with neumann boundary
!     conditions.
!
!     istag = 1 if the last diagonal block is a.
!     istag = 2 if the last diagonal block is a-i.
!     mixbnd = 1 if have neumann boundary conditions at both boundaries.
!     mixbnd = 2 if have neumann boundary conditions at bottom and
!     dirichlet condition at top.  (for this case, must have istag = 1.)

  real(rq) :: a(*),bb(*),c(*),q(idimq,*),b(*),b2(*),b3(*),w(*),w2(*),w3(*), &
       d(*),tcos(*),k(4),p(*)

  equivalence (k(1),k1),(k(2),k2),(k(3),k3),(k(4),k4)

  fistag = 3-istag
  fnum = 1._rq/(istag)
  fden = 0.5_rq*(istag-1)
  mr = m
  ip = -mr
  ipstor = 0
  i2r = 1
  jr = 2
  nr = n
  nlast = n
  kr = 1
  lr = 0
  go to (101,103),istag
101 continue
  do i=1,mr
     q(i,n) = .5_rq*q(i,n)
  end do
  go to (103,104),mixbnd
103 if (n .le. 3) go to 155
104 continue
  jr = 2*i2r
  nrod = 1
  if ((nr/2)*2 .eq. nr) nrod = 0
  go to (105,106),mixbnd
105 jstart = 1
  go to 107
106 jstart = jr
  nrod = 1-nrod
107 continue
  jstop = nlast-jr
  if (nrod .eq. 0) jstop = jstop-i2r
  call cosgen(i2r,1,0.5_rq,0.0_rq,tcos)
  i2rby2 = i2r/2
  if (jstop .ge. jstart) go to 108
  j = jr
  go to 116
108 continue

!     regular reduction.

  do j=jstart,jstop,jr
     jp1 = j+i2rby2
     jp2 = j+i2r
     jp3 = jp2+i2rby2
     jm1 = j-i2rby2
     jm2 = j-i2r
     jm3 = jm2-i2rby2
     if (j .ne. 1) go to 109
     jm1 = jp1
     jm2 = jp2
     jm3 = jp3
109  continue
     if (i2r .ne. 1) go to 111
     if (j .eq. 1) jm2 = jp2
     do i=1,mr
        b(i) = 2._rq*q(i,j)
        q(i,j) = q(i,jm2)+q(i,jp2)
     end do
     go to 113
111  continue
     do i=1,mr
        fi = q(i,j)
        q(i,j) = q(i,j)-q(i,jm1)-q(i,jp1)+q(i,jm2)+q(i,jp2)
        b(i) = fi+q(i,j)-q(i,jm3)-q(i,jp3)
     end do
113  continue
     call trix(i2r,0,mr,a,bb,c,b,tcos,d,w)
     do i=1,mr
        q(i,j) = q(i,j)+b(i)
     end do

!     end of reduction for regular unknowns.

  end do

!     begin special reduction for last unknown.

  j = jstop+jr
116 nlast = j
  jm1 = j-i2rby2
  jm2 = j-i2r
  jm3 = jm2-i2rby2
  if (nrod .eq. 0) go to 128

!     odd number of unknowns

  if (i2r .ne. 1) go to 118
  do i=1,mr
     b(i) = fistag*q(i,j)
     q(i,j) = q(i,jm2)
  end do
  go to 126
118 do i=1,mr
     b(i) = q(i,j)+.5_rq*(q(i,jm2)-q(i,jm1)-q(i,jm3))
  end do
  if (nrodpr .ne. 0) go to 121
  do i=1,mr
     ii = ip+i
     q(i,j) = q(i,jm2)+p(ii)
  end do
  ip = ip-mr
  go to 123
121 continue
  do i=1,mr
     q(i,j) = q(i,j)-q(i,jm1)+q(i,jm2)
  end do
123 if (lr .eq. 0) go to 124
  call cosgen(lr,1,0.5_rq,fden,tcos(kr+1))
  go to 126
124 continue
  do i=1,mr
     b(i) = fistag*b(i)
  end do
126 continue
  call cosgen(kr,1,0.5_rq,fden,tcos)
  call trix(kr,lr,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,j) = q(i,j)+b(i)
  end do
  kr = kr+i2r
  go to 151
128 continue

!     even number of unknowns

  jp1 = j+i2rby2
  jp2 = j+i2r
  if (i2r .ne. 1) go to 135
  do i=1,mr
     b(i) = q(i,j)
  end do
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  ip = 0
  ipstor = mr
  go to (133,130),istag
130 do i=1,mr
     p(i) = b(i)
     b(i) = b(i)+q(i,n)
  end do
  tcos(1) = 1._rq
  tcos(2) = 0._rq
  call trix(1,1,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,j) = q(i,jm2)+p(i)+b(i)
  end do
  go to 150
133 continue
  do i=1,mr
     p(i) = b(i)
     q(i,j) = q(i,jm2)+2._rq*q(i,jp2)+3._rq*b(i)
  end do
  go to 150
135 continue
  do i=1,mr
     b(i) = q(i,j)+.5_rq*(q(i,jm2)-q(i,jm1)-q(i,jm3))
  end do
  if (nrodpr .ne. 0) go to 138
  do i=1,mr
     ii = ip+i
     b(i) = b(i)+p(ii)
  end do
  go to 140
138 continue
  do i=1,mr
     b(i) = b(i)+q(i,jp2)-q(i,jp1)
  end do
140 continue
  call trix(i2r,0,mr,a,bb,c,b,tcos,d,w)
  ip = ip+mr
  ipstor = max(ipstor,ip+mr)
  do i=1,mr
     ii = ip+i
     p(ii) = b(i)+.5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))
     b(i) = p(ii)+q(i,jp2)
  end do
  if (lr .eq. 0) go to 142
  call cosgen(lr,1,0.5_rq,fden,tcos(i2r+1))
  call merge(tcos,0,i2r,i2r,lr,kr)
  go to 144
142 do i=1,i2r
     ii = kr+i
     tcos(ii) = tcos(i)
  end do
144 call cosgen(kr,1,0.5_rq,fden,tcos)
  if (lr .ne. 0) go to 145
  go to (146,145),istag
145 continue
  call trix(kr,kr,mr,a,bb,c,b,tcos,d,w)
  go to 148
146 continue
  do i=1,mr
     b(i) = fistag*b(i)
  end do
148 continue
  do i=1,mr
     ii = ip+i
     q(i,j) = q(i,jm2)+p(ii)+b(i)
  end do
150 continue
  lr = kr
  kr = kr+jr
151 continue
  go to (152,153),mixbnd
152 nr = (nlast-1)/jr+1
  if (nr .le. 3) go to 155
  go to 154
153 nr = nlast/jr
  if (nr .le. 1) go to 192
154 i2r = jr
  nrodpr = nrod
  go to 104
155 continue

!      begin solution

  j = 1+jr
  jm1 = j-i2r
  jp1 = j+i2r
  jm2 = nlast-i2r
  if (nr .eq. 2) go to 184
  if (lr .ne. 0) go to 170
  if (n .ne. 3) go to 161

!     case n = 3.

  go to (156,168),istag
156 continue
  do i=1,mr
     b(i) = q(i,2)
  end do
  tcos(1) = 0._rq
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,2) = b(i)
     b(i) = 4._rq*b(i)+q(i,1)+2._rq*q(i,3)
  end do
  tcos(1) = -2._rq
  tcos(2) = 2._rq
  i1 = 2
  i2 = 0
  call trix(i1,i2,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,2) = q(i,2)+b(i)
     b(i) = q(i,1)+2._rq*q(i,2)
  end do
  tcos(1) = 0._rq
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,1) = b(i)
  end do
  jr = 1
  i2r = 0
  go to 194

!     case n = 2**p+1

161 continue
  go to (162,170),istag
162 continue
  do i=1,mr
     b(i) = q(i,j)+.5_rq*q(i,1)-q(i,jm1)+q(i,nlast)-q(i,jm2)
  end do
  call cosgen(jr,1,0.5_rq,0.0_rq,tcos)
  call trix(jr,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,j) = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))+b(i)
     b(i) = q(i,1)+2._rq*q(i,nlast)+4._rq*q(i,j)
  end do
  jr2 = 2*jr
  call cosgen(jr,1,0.0_rq,0.0_rq,tcos)
  do i=1,jr
     i1 = jr+i
     i2 = jr+1-i
     tcos(i1) = -tcos(i2)
  end do
  call trix(jr2,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,j) = q(i,j)+b(i)
     b(i) = q(i,1)+2._rq*q(i,j)
  end do
  call cosgen(jr,1,0.5_rq,0.0_rq,tcos)
  call trix(jr,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,1) = .5_rq*q(i,1)-q(i,jm1)+b(i)
  end do
  go to 194

!     case of general n with nr = 3 .

168 do i=1,mr
     b(i) = q(i,2)
     q(i,2) = 0._rq
     b2(i) = q(i,3)
     b3(i) = q(i,1)
  end do
  jr = 1
  i2r = 0
  j = 2
  go to 177
170 continue
  do i=1,mr
     b(i) = .5_rq*q(i,1)-q(i,jm1)+q(i,j)
  end do
  if (nrod .ne. 0) go to 173
  do i=1,mr
     ii = ip+i
     b(i) = b(i)+p(ii)
  end do
  go to 175
173 do i=1,mr
     b(i) = b(i)+q(i,nlast)-q(i,jm2)
  end do
175 continue
  do i=1,mr
     t = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))
     q(i,j) = t
     b2(i) = q(i,nlast)+t
     b3(i) = q(i,1)+2._rq*t
  end do
177 continue
  k1 = kr+2*jr-1
  k2 = kr+jr
  tcos(k1+1) = -2._rq
  k4 = k1+3-istag
  call cosgen(k2+istag-2,1,0.0_rq,fnum,tcos(k4))
  k4 = k1+k2+1
  call cosgen(jr-1,1,0.0_rq,1.0_rq,tcos(k4))
  call merge(tcos,k1,k2,k1+k2,jr-1,0)
  k3 = k1+k2+lr
  call cosgen(jr,1,0.5_rq,0.0_rq,tcos(k3+1))
  k4 = k3+jr+1
  call cosgen(kr,1,0.5_rq,fden,tcos(k4))
  call merge(tcos,k3,jr,k3+jr,kr,k1)
  if (lr .eq. 0) go to 178
  call cosgen(lr,1,0.5_rq,fden,tcos(k4))
  call merge(tcos,k3,jr,k3+jr,lr,k3-lr)
  call cosgen(kr,1,0.5_rq,fden,tcos(k4))
178 k3 = kr
  k4 = kr
  call tri3(mr,a,bb,c,k,b,b2,b3,tcos,d,w,w2,w3)
  do i=1,mr
     b(i) = b(i)+b2(i)+b3(i)
  end do
  tcos(1) = 2._rq
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,j) = q(i,j)+b(i)
     b(i) = q(i,1)+2._rq*q(i,j)
  end do
  call cosgen(jr,1,0.5_rq,0.0_rq,tcos)
  call trix(jr,0,mr,a,bb,c,b,tcos,d,w)
  if (jr .ne. 1) go to 182
  do i=1,mr
     q(i,1) = b(i)
  end do
  go to 194
182 continue
  do i=1,mr
     q(i,1) = .5_rq*q(i,1)-q(i,jm1)+b(i)
  end do
  go to 194
184 continue
  if (n .ne. 2) go to 188

!     case  n = 2

  do i=1,mr
     b(i) = q(i,1)
  end do
  tcos(1) = 0._rq
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,1) = b(i)
     b(i) = 2._rq*(q(i,2)+b(i))*fistag
  end do
  tcos(1) = -fistag
  tcos(2) = 2._rq
  call trix(2,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,1) = q(i,1)+b(i)
  end do
  jr = 1
  i2r = 0
  go to 194
188 continue

!     case of general n and nr = 2 .

  do i=1,mr
     ii = ip+i
     b3(i) = 0._rq
     b(i) = q(i,1)+2._rq*p(ii)
     q(i,1) = .5_rq*q(i,1)-q(i,jm1)
     b2(i) = 2._rq*(q(i,1)+q(i,nlast))
  end do
  k1 = kr+jr-1
  tcos(k1+1) = -2._rq
  k4 = k1+3-istag
  call cosgen(kr+istag-2,1,0.0_rq,fnum,tcos(k4))
  k4 = k1+kr+1
  call cosgen(jr-1,1,0.0_rq,1.0_rq,tcos(k4))
  call merge(tcos,k1,kr,k1+kr,jr-1,0)
  call cosgen(kr,1,0.5_rq,fden,tcos(k1+1))
  k2 = kr
  k4 = k1+k2+1
  call cosgen(lr,1,0.5_rq,fden,tcos(k4))
  k3 = lr
  k4 = 0
  call tri3(mr,a,bb,c,k,b,b2,b3,tcos,d,w,w2,w3)
  do i=1,mr
     b(i) = b(i)+b2(i)
  end do
  tcos(1) = 2._rq
  call trix(1,0,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,1) = q(i,1)+b(i)
  end do
  go to 194
192 do i=1,mr
     b(i) = q(i,nlast)
  end do
  go to 196
194 continue

!     start back substitution.

  j = nlast-jr
  do i=1,mr
     b(i) = q(i,nlast)+q(i,j)
  end do
196 jm2 = nlast-i2r
  if (jr .ne. 1) go to 198
  do i=1,mr
     q(i,nlast) = 0._rq
  end do
  go to 202
198 continue
  if (nrod .ne. 0) go to 200
  do i=1,mr
     ii = ip+i
     q(i,nlast) = p(ii)
  end do
  ip = ip-mr
  go to 202
200 do i=1,mr
     q(i,nlast) = q(i,nlast)-q(i,jm2)
  end do
202 continue
  call cosgen(kr,1,0.5_rq,fden,tcos)
  call cosgen(lr,1,0.5_rq,fden,tcos(kr+1))
  if (lr .ne. 0) go to 204
  do i=1,mr
     b(i) = fistag*b(i)
  end do
204 continue
  call trix(kr,lr,mr,a,bb,c,b,tcos,d,w)
  do i=1,mr
     q(i,nlast) = q(i,nlast)+b(i)
  end do
  nlastp = nlast
206 continue
  jstep = jr
  jr = i2r
  i2r = i2r/2
  if (jr .eq. 0) go to 222
  go to (207,208),mixbnd
207 jstart = 1+jr
  go to 209
208 jstart = jr
209 continue
  kr = kr-jr
  if (nlast+jr .gt. n) go to 210
  kr = kr-jr
  nlast = nlast+jr
  jstop = nlast-jstep
  go to 211
210 continue
  jstop = nlast-jr
211 continue
  lr = kr-jr
  call cosgen(jr,1,0.5_rq,0.0_rq,tcos)
  do j=jstart,jstop,jstep
     jm2 = j-jr
     jp2 = j+jr
     if (j .ne. jr) go to 213
     do i=1,mr
        b(i) = q(i,j)+q(i,jp2)
     end do
     go to 215
213  continue
     do i=1,mr
        b(i) = q(i,j)+q(i,jm2)+q(i,jp2)
     end do
215  continue
     if (jr .ne. 1) go to 217
     do i=1,mr
        q(i,j) = 0._rq
     end do
     go to 219
217  continue
     jm1 = j-i2r
     jp1 = j+i2r
     do i=1,mr
        q(i,j) = .5_rq*(q(i,j)-q(i,jm1)-q(i,jp1))
     end do
219  continue
     call trix(jr,0,mr,a,bb,c,b,tcos,d,w)
     do i=1,mr
        q(i,j) = q(i,j)+b(i)
     end do
  end do
  nrod = 1
  if (nlast+i2r .le. n) nrod = 0
  if (nlastp .ne. nlast) go to 194
  go to 206
222 continue

!     return storage requirements for p vectors.

  w(1) = ipstor

  return

end subroutine poisn2

subroutine poisp2(m,n,a,bb,c,q,idimq,b,b2,b3,w,w2,w3,d,tcos,p)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     subroutine to solve poisson equation with periodic boundary
!     conditions.

  real(rq) :: a(*),bb(*),c(*),q(idimq,*),b(*),b2(*),b3(*),w(*),w2(*),w3(*), &
       d(*),tcos(*),p(*)

  mr = m
  nr = (n+1)/2
  nrm1 = nr-1
  if (2*nr .ne. n) go to 107

!     even number of unknowns

  do j=1,nrm1
     nrmj = nr-j
     nrpj = nr+j
     do i=1,mr
        s = q(i,nrmj)-q(i,nrpj)
        t = q(i,nrmj)+q(i,nrpj)
        q(i,nrmj) = s
        q(i,nrpj) = t
     end do
  end do
  do i=1,mr
     q(i,nr) = 2._rq*q(i,nr)
     q(i,n) = 2._rq*q(i,n)
  end do
  call poisd2(mr,nrm1,1,a,bb,c,q,idimq,b,w,d,tcos,p)
  ipstor = w(1)
  call poisn2(mr,nr+1,1,1,a,bb,c,q(1,nr),idimq,b,b2,b3,w,w2,w3,d,tcos,p)
  ipstor = max(ipstor,int(w(1)))
  do j=1,nrm1
     nrmj = nr-j
     nrpj = nr+j
     do i=1,mr
        s = .5_rq*(q(i,nrpj)+q(i,nrmj))
        t = .5_rq*(q(i,nrpj)-q(i,nrmj))
        q(i,nrmj) = s
        q(i,nrpj) = t
     end do
  end do
  do i=1,mr
     q(i,nr) = .5_rq*q(i,nr)
     q(i,n) = .5_rq*q(i,n)
  end do
  go to 118

107 continue

!     odd  number of unknowns

  do j=1,nrm1
     nrpj = n+1-j
     do i=1,mr
        s = q(i,j)-q(i,nrpj)
        t = q(i,j)+q(i,nrpj)
        q(i,j) = s
        q(i,nrpj) = t
     end do
  end do
  do i=1,mr
     q(i,nr) = 2._rq*q(i,nr)
  end do
  lh = nrm1/2
  do j=1,lh
     nrmj = nr-j
     do i=1,mr
        s = q(i,j)
        q(i,j) = q(i,nrmj)
        q(i,nrmj) = s
     end do
  end do

  call poisd2(mr,nrm1,2,a,bb,c,q,idimq,b,w,d,tcos,p)
  ipstor = w(1)
  call poisn2(mr,nr,2,1,a,bb,c,q(1,nr),idimq,b,b2,b3,w,w2,w3,d,tcos,p)
  ipstor = max(ipstor,int(w(1)))
  do j=1,nrm1
     nrpj = nr+j
     do i=1,mr
        s = .5_rq*(q(i,nrpj)+q(i,j))
        t = .5_rq*(q(i,nrpj)-q(i,j))
        q(i,nrpj) = t
        q(i,j) = s
     end do
  end do
  do i=1,mr
     q(i,nr) = .5_rq*q(i,nr)
  end do
  do j=1,lh
     nrmj = nr-j
     do i=1,mr
        s = q(i,j)
        q(i,j) = q(i,nrmj)
        q(i,nrmj) = s
     end do
  end do
118 continue

!     return storage requirements for p vectors.

  w(1) = ipstor

  return

end subroutine poisp2

subroutine qform(m,n,q,ldq,wa)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)
      
  integer :: m,n,ldq
  real(rq) :: q(ldq,m),wa(m)

!     **********
!
!     subroutine qform
!
!     this subroutine proceeds from the computed qr factorization of
!     an m by n matrix a to accumulate the m by m orthogonal matrix
!     q from its factored form.
!
!     the subroutine statement is
!
!       subroutine qform(m,n,q,ldq,wa)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of a and the order of q.
!
!       n is a positive integer input variable set to the number
!         of columns of a.
!
!       q is an m by m array. on input the full lower trapezoid in
!         the first min(m,n) columns of q contains the factored form.
!         on output q has been accumulated into a square matrix.
!
!       ldq is a positive integer input variable not less than m
!         which specifies the leading real of the array q.
!
!       wa is a work array of length m.
!
!     subprograms called
!
!       fortran-supplied ... min0
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i,j,jm1,k,l,minmn,np1
  real(rq) :: sum,temp

!     zero out upper triangle of q in the first min(m,n) columns.

  minmn = min(m,n)
  if (minmn .lt. 2) go to 30
  do j = 2, minmn
     jm1 = j - 1
     do i = 1, jm1
        q(i,j) = zero
     end do
  end do
30 continue

!     initialize remaining columns to those of the identity matrix.

  np1 = n + 1
  if (m .lt. np1) go to 60
  do j = np1, m
     do i = 1, m
        q(i,j) = zero
     end do
     q(j,j) = one
  end do
60 continue

!     accumulate q from its factored form.

  do l = 1, minmn
     k = minmn - l + 1
     do i = k, m
        wa(i) = q(i,k)
        q(i,k) = zero
     end do
     q(k,k) = one
     if (wa(k) .eq. zero) go to 110
     do j = k, m
        sum = zero
        do i = k, m
           sum = sum + q(i,j)*wa(i)
        end do
        temp = sum/wa(k)
        do i = k, m
           q(i,j) = q(i,j) - temp*wa(i)
        end do
     end do
110  continue
  end do

  return

!     last card of subroutine qform.

end subroutine qform

subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: m,n,lda,lipvt
  integer :: ipvt(lipvt)
  logical :: pivot
  real(rq) :: a(lda,n),rdiag(n),acnorm(n),wa(n)

!     **********
!
!     subroutine qrfac
!
!     this subroutine uses householder transformations with column
!     pivoting (optional) to compute a qr factorization of the
!     m by n matrix a. that is, qrfac determines an orthogonal
!     matrix q, a permutation matrix p, and an upper trapezoidal
!     matrix r with diagonal elements of nonincreasing magnitude,
!     such that a*p = q*r. the householder transformation for
!     column k, k = 1,2,...,min(m,n), is of the form
!
!                           t
!           i - (1/u(k))*u*u
!
!     where u has zeros in the first k-1 positions. the form of
!     this transformation and the method of pivoting first
!     appeared in the corresponding linpack subroutine.
!
!     the subroutine statement is
!
!       subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of a.
!
!       n is a positive integer input variable set to the number
!         of columns of a.
!
!       a is an m by n array. on input a contains the matrix for
!         which the qr factorization is to be computed. on output
!         the strict upper trapezoidal part of a contains the strict
!         upper trapezoidal part of r, and the lower trapezoidal
!         part of a contains a factored form of q (the non-trivial
!         elements of the u vectors described above).
!
!       lda is a positive integer input variable not less than m
!         which specifies the leading real of the array a.
!
!       pivot is a logical input variable. if pivot is set true,
!         then column pivoting is enforced. if pivot is set false,
!         then no column pivoting is done.
!
!       ipvt is an integer output array of length lipvt. ipvt
!         defines the permutation matrix p such that a*p = q*r.
!         column j of p is column ipvt(j) of the identity matrix.
!         if pivot is false, ipvt is not referenced.
!
!       lipvt is a positive integer input variable. if pivot is false,
!         then lipvt may be as small as 1. if pivot is true, then
!         lipvt must be at least n.
!
!       rdiag is an output array of length n which contains the
!         diagonal elements of r.
!
!       acnorm is an output array of length n which contains the
!         norms of the corresponding columns of the input matrix a.
!         if this information is not needed, then acnorm can coincide
!         with rdiag.
!
!       wa is a work array of length n. if pivot is false, then wa
!         can coincide with rdiag.
!
!     subprograms called
!
!       minpack-supplied ... enorm
!
!       fortran-supplied ... amax1,sqrt,min0
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i,j,jp1,k,kmax,minmn
  real(rq) :: ajnorm,epsmch,sum,temp
  real(rq) :: enorm

!     epsmch is the machine precision.

  epsmch = errt_rq ! d1mach(3)

!     compute the initial column norms and initialize several arrays.

  do j = 1, n
     acnorm(j) = enorm(m,a(1,j))
     rdiag(j) = acnorm(j)
     wa(j) = rdiag(j)
     if (pivot) ipvt(j) = j
  end do

!     reduce a to r with householder transformations.

  minmn = min(m,n)
  do j = 1, minmn
     if (.not.pivot) go to 40

!        bring the column of largest norm into the pivot position.

     kmax = j
     do k = j, n
        if (rdiag(k) .gt. rdiag(kmax)) kmax = k
     end do
     if (kmax .eq. j) go to 40
     do i = 1, m
        temp = a(i,j)
        a(i,j) = a(i,kmax)
        a(i,kmax) = temp
     end do
     rdiag(kmax) = rdiag(j)
     wa(kmax) = wa(j)
     k = ipvt(j)
     ipvt(j) = ipvt(kmax)
     ipvt(kmax) = k
40   continue

!        compute the householder transformation to reduce the
!        j-th column of a to a multiple of the j-th unit vector.

     ajnorm = enorm(m-j+1,a(j,j))
     if (ajnorm .eq. zero) go to 100
     if (a(j,j) .lt. zero) ajnorm = -ajnorm
     do i = j, m
        a(i,j) = a(i,j)/ajnorm
     end do
     a(j,j) = a(j,j) + one

!        apply the transformation to the remaining columns
!        and update the norms.

     jp1 = j + 1
     if (n .lt. jp1) go to 100
     do k = jp1, n
        sum = zero
        do i = j, m
           sum = sum + a(i,j)*a(i,k)
        end do
        temp = sum/a(j,j)
        do i = j, m
           a(i,k) = a(i,k) - temp*a(i,j)
        end do
        if (.not.pivot .or. rdiag(k) .eq. zero) go to 80
        temp = a(j,k)/rdiag(k)
        rdiag(k) = rdiag(k)*sqrt(max(zero,one-temp**2))
        if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80
        rdiag(k) = enorm(m-j,a(jp1,k))
        wa(k) = rdiag(k)
80      continue
     end do
100  continue
     rdiag(j) = -ajnorm
  end do

  return

!     last card of subroutine qrfac.

end subroutine qrfac

subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: fun, a, b, abserr, relerr, result, errest, flag
  integer :: nofun

!   estimate the integral of fun(x) from a to b
!   to a user provided tolerance.
!   an automatic adaptive routine based on
!   the 8-panel newton-cotes rule.
!
!   input ..
!
!   fun     the name of the integrand function subprogram fun(x).
!   a       the lower limit of integration.
!   b       the upper limit of integration.(b may be less than a.)
!   relerr  a relative error tolerance. (should be non-negative)
!   abserr  an absolute error tolerance. (should be non-negative)
!
!   output ..
!
!   result  an approximation to the integral hopefully satisfying the
!           least stringent of the two error tolerances.
!   errest  an estimate of the magnitude of the actual error.
!   nofun   the number of function values used in calculation of result.
!   flag    a reliability indicator.  if flag is zero, then result
!           probably satisfies the error tolerance.  if flag is
!           xxx.yyy , then  xxx = the number of intervals which have
!           not converged and  0.yyy = the fraction of the interval
!           left to do when the limit on  nofun  was approached.

  real(rq) :: w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp
  real(rq) :: qprev,qnow,qdiff,qleft,esterr,tolerr
  real(rq) :: qright(31),f(16),x(16),fsave(8,30),xsave(8,30)
  integer :: levmin,levmax,levout,nomax,nofin,lev,nim,i,j

!   ***   stage 1 ***   general initialization
!   set constants.

  levmin = 1
  levmax = 30
  levout = 6
  nomax = 5000
  nofin = nomax - 8*(levmax-levout+2**(levout+1))

!   trouble when nofun reaches nofin

  w0 = 3956.0_rq / 14175.0_rq
  w1 = 23552.0_rq / 14175.0_rq
  w2 = -3712.0_rq / 14175.0_rq
  w3 = 41984.0_rq / 14175.0_rq
  w4 = -18160.0_rq / 14175.0_rq

!   initialize running sums to zero.

  flag = 0.0_rq
  result = 0.0_rq
  cor11 = 0.0_rq
  errest = 0.0_rq
  area = 0.0_rq
  nofun = 0
  if (a .eq. b) return

!   ***   stage 2 ***   initialization for first interval

  lev = 0
  nim = 1
  x0 = a
  x(16) = b
  qprev = 0.0_rq
  f0 = fun(x0)
  stone = (b - a) / 16.0_rq
  x(8) = (x0 + x(16)) / 2.0_rq
  x(4) = (x0 + x(8)) / 2.0_rq
  x(12) = (x(8) + x(16)) / 2.0_rq
  x(2) = (x0 + x(4)) / 2.0_rq
  x(6) = (x(4) + x(8)) / 2.0_rq
  x(10) = (x(8) + x(12)) / 2.0_rq
  x(14) = (x(12) + x(16)) / 2.0_rq
  do j = 2, 16, 2
     f(j) = fun(x(j))
  end do
  nofun = 9

!   ***   stage 3 ***   central calculation
!   requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16.
!   calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area.

30 x(1) = (x0 + x(2)) / 2.0_rq
  f(1) = fun(x(1))
  do j = 3, 15, 2
     x(j) = (x(j-1) + x(j+1)) / 2.0_rq
     f(j) = fun(x(j))
  end do
  nofun = nofun + 8
  step = (x(16) - x0) / 16.0_rq
  qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) + &
       w3*(f(3)+f(5)) + w4*f(4)) * step
  qright(lev+1)=(w0*(f(8)+f(16))+w1*(f(9)+f(15))+w2*(f(10)+f(14)) + &
       w3*(f(11)+f(13)) + w4*f(12)) * step
  qnow = qleft + qright(lev+1)
  qdiff = qnow - qprev
  area = area + qdiff

!   ***   stage 4 *** interval convergence test

  esterr = abs(qdiff) / 1023.0_rq
  tolerr = max(abserr,relerr*abs(area)) * (step/stone)
  if (lev .lt. levmin) go to 50
  if (lev .ge. levmax) go to 62
  if (nofun .gt. nofin) go to 60
  if (esterr .le. tolerr) go to 70

!   ***   stage 5   ***   no convergence
!   locate next interval.

50 nim = 2*nim
  lev = lev+1

!   store right hand elements for future use.

  do i = 1, 8
     fsave(i,lev) = f(i+8)
     xsave(i,lev) = x(i+8)
  end do

!   assemble left hand elements for immediate use.

  qprev = qleft
  do i = 1, 8
     j = -i
     f(2*j+18) = f(j+9)
     x(2*j+18) = x(j+9)
  end do
  go to 30

!   ***   stage 6   ***   trouble section
!   number of function values is about to exceed limit.

60 nofin = 2*nofin
  levmax = levout
  flag = flag + (b - x0) / (b - a)
  go to 70

!   current level is levmax.

62 flag = flag + 1.0_rq

!   ***   stage 7   ***   interval converged
!   add contributions into running sums.

70 result = result + qnow
  errest = errest + esterr
  cor11 = cor11 + qdiff / 1023.0_rq

!   locate next interval.

72 if (nim .eq. 2*(nim/2)) go to 75
  nim = nim/2
  lev = lev-1
  go to 72
75 nim = nim + 1
  if (lev .le. 0) go to 80

!   assemble elements required for the next interval.

  qprev = qright(lev)
  x0 = x(16)
  f0 = f(16)
  do i = 1, 8
     f(2*i) = fsave(i,lev)
     x(2*i) = xsave(i,lev)
  end do
  go to 30

!   ***   stage 8   ***   finalize and return

80 result = result + cor11

!   make sure errest not less than roundoff level.

  if (errest .eq. 0.0_rq) return
82 temp = abs(result) + errest
  if (temp .ne. abs(result)) return
  errest = 2.0_rq*errest
  go to 82

end subroutine quanc8

subroutine r1mpyq(m,n,a,lda,v,w)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: m,n,lda
  real(rq) :: a(lda,n),v(n),w(n)

!     **********
!
!     subroutine r1mpyq
!
!     given an m by n matrix a, this subroutine computes a*q where
!     q is the product of 2*(n - 1) transformations
!
!           gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
!
!     and gv(i), gw(i) are givens rotations in the (i,n) plane which
!     eliminate elements in the i-th and n-th planes, respectively.
!     q itself is not given, rather the information to recover the
!     gv, gw rotations is supplied.
!
!     the subroutine statement is
!
!       subroutine r1mpyq(m,n,a,lda,v,w)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of a.
!
!       n is a positive integer input variable set to the number
!         of columns of a.
!
!       a is an m by n array. on input a must contain the matrix
!         to be postmultiplied by the orthogonal matrix q
!         described above. on output a*q has replaced a.
!
!       lda is a positive integer input variable not less than m
!         which specifies the leading real of the array a.
!
!       v is an input array of length n. v(i) must contain the
!         information necessary to recover the givens rotation gv(i)
!         described above.
!
!       w is an input array of length n. w(i) must contain the
!         information necessary to recover the givens rotation gw(i)
!         described above.
!
!     subroutines called
!
!       fortran-supplied ... abs,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more
!
!     **********

  integer :: i,j,nmj,nm1
  real(rq) :: cos,sin,temp

!     apply the first set of givens rotations to a

  nm1 = n - 1
  if (nm1 .lt. 1) go to 50
  do nmj = 1, nm1
     j = n - nmj
     if (abs(v(j)) .gt. one) cos = one/v(j)
     if (abs(v(j)) .gt. one) sin = sqrt(one-cos**2)
     if (abs(v(j)) .le. one) sin = v(j)
     if (abs(v(j)) .le. one) cos = sqrt(one-sin**2)
     do i = 1, m
        temp = cos*a(i,j) - sin*a(i,n)
        a(i,n) = sin*a(i,j) + cos*a(i,n)
        a(i,j) = temp
     end do
  end do

!     apply the second set of givens rotations to a.

  do j = 1, nm1
     if (abs(w(j)) .gt. one) cos = one/w(j)
     if (abs(w(j)) .gt. one) sin = sqrt(one-cos**2)
     if (abs(w(j)) .le. one) sin = w(j)
     if (abs(w(j)) .le. one) cos = sqrt(one-sin**2)
     do i = 1, m
        temp = cos*a(i,j) + sin*a(i,n)
        a(i,n) = -sin*a(i,j) + cos*a(i,n)
        a(i,j) = temp
     end do
  end do
50 continue

  return

!     last card of subroutine r1mpyq.

end subroutine r1mpyq

subroutine r1updt(m,n,s,ls,u,v,w,sing)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: m,n,ls
  logical :: sing
  real(rq) :: s(ls),u(m),v(n),w(m)

!     **********
!
!     subroutine r1updt
!
!     given an m by n lower trapezoidal matrix s, an m-vector u,
!     and an n-vector v, the problem is to determine an
!     orthogonal matrix q such that
!
!                   t
!           (s + u*v )*q
!
!     is again lower trapezoidal.
!
!     this subroutine determines q as the product of 2*(n - 1)
!     transformations
!
!           gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
!
!     where gv(i), gw(i) are givens rotations in the (i,n) plane
!     which eliminate elements in the i-th and n-th planes,
!     respectively. q itself is not accumulated, rather the
!     information to recover the gv, gw rotations is returned.
!
!     the subroutine statement is
!
!       subroutine r1updt(m,n,s,ls,u,v,w,sing)
!
!     where
!
!       m is a positive integer input variable set to the number
!         of rows of s.
!
!       n is a positive integer input variable set to the number
!         of columns of s. n must not exceed m.
!
!       s is an array of length ls. on input s must contain the lower
!         trapezoidal matrix s stored by columns. on output s contains
!         the lower trapezoidal matrix produced as described above.
!
!       ls is a positive integer input variable not less than
!         (n*(2*m-n+1))/2.
!
!       u is an input array of length m which must contain the
!         vector u.
!
!       v is an array of length n. on input v must contain the vector
!         v. on output v(i) contains the information necessary to
!         recover the givens rotation gv(i) described above.
!
!       w is an output array of length m. w(i) contains information
!         necessary to recover the givens rotation gw(i) described
!         above.
!
!       sing is a logical output variable. sing is set true if any
!         of  diagonal elements of  output s are zero. orwise
!         sing is set false.
!
!     subprograms called
!
!       fortran-supplied ... abs,sqrt
!
!     argonne national laboratory. minpack project. march 1980.
!     burton s. garbow, kenneth e. hillstrom, jorge j. more,
!     john l. nazareth
!
!     **********

  integer :: i,j,jj,l,nmj,nm1
  real(rq) :: cos,cotan,giant,sin,tan,tau,temp

!     giant is the largest magnitude.

  giant = erra_rq ! d1mach(2)

!     initializ diagonal element pointer.

  jj = (n*(2*m - n + 1))/2 - (m - n)

!     move the nontrivial part of the last column of s into w.

  l = jj
  do i = n, m
     w(i) = s(l)
     l = l + 1
  end do

!     rotate the vector v into a multiple of the n-th unit vector
!     in such a way that a spike is introduced into w.

  nm1 = n - 1
  if (nm1 .lt. 1) go to 70
  do nmj = 1, nm1
     j = n - nmj
     jj = jj - (m - j + 1)
     w(j) = zero
     if (v(j) .eq. zero) go to 50

!        determine a givens rotation which eliminates the
!        j-th element of v.

     if (abs(v(n)) .ge. abs(v(j))) go to 20
     cotan = v(n)/v(j)
     sin = HALF/sqrt(p25+p25*cotan**2)
     cos = sin*cotan
     tau = one
     if (abs(cos)*giant .gt. one) tau = one/cos
     go to 30
20   continue
     tan = v(j)/v(n)
     cos = HALF/sqrt(p25+p25*tan**2)
     sin = cos*tan
     tau = sin
30   continue

!        apply the transformation to v and store the information
!        necessary to recover the givens rotation.

     v(n) = sin*v(j) + cos*v(n)
     v(j) = tau

!        apply the transformation to s and extend the spike in w.

     l = jj
     do i = j, m
        temp = cos*s(l) - sin*w(i)
        w(i) = sin*s(l) + cos*w(i)
        s(l) = temp
        l = l + 1
     end do
50   continue
  end do
70 continue

!     add the spike from the rank 1 update to w.

  do i = 1, m
     w(i) = w(i) + v(n)*u(i)
  end do

!     eliminate the spike.

  sing = .false.
  if (nm1 .lt. 1) go to 140
  do j = 1, nm1
     if (w(j) .eq. zero) go to 120

!        determine a givens rotation which eliminates the
!        j-th element of the spike.

     if (abs(s(jj)) .ge. abs(w(j))) go to 90
     cotan = s(jj)/w(j)
     sin = HALF/sqrt(p25+p25*cotan**2)
     cos = sin*cotan
     tau = one
     if (abs(cos)*giant .gt. one) tau = one/cos
     go to 100
90   continue
     tan = w(j)/s(jj)
     cos = HALF/sqrt(p25+p25*tan**2)
     sin = cos*tan
     tau = sin
100  continue

!        apply the transformation to s and reduce the spike in w.

     l = jj
     do i = j, m
        temp = cos*s(l) + sin*w(i)
        w(i) = -sin*s(l) + cos*w(i)
        s(l) = temp
        l = l + 1
     end do

!        store the information necessary to recover the
!        givens rotation.

     w(j) = tau
120  continue

!        test for zero diagonal elements in the output s.

     if (s(jj) .eq. zero) sing = .true.
     jj = jj + (m - j + 1)
  end do
140 continue

!     move w back into the last column of the output s.

  l = jj
  do i = n, m
     s(l) = w(i)
     l = l + 1
  end do
  if (s(jj) .eq. zero) sing = .true.

  return

!     last card of subroutine r1updt.

end subroutine r1updt

subroutine sepx4(iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, &
     nbdcnd,bdc,bdd,cofx,grhs,usol,idmn,w,pertrb,ierror)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)
!                          equations.  ncar technical note
!                          ncar-tn/ia-109, pp. 135-137.

  real(rq) :: grhs(idmn,*),usol(idmn,*)
  real(rq) :: bda(*),bdb(*),bdc(*),bdd(*),w(*)
  real(rq) :: a,b,alpha,c,d,pertrb

  external cofx

!     the following call is for gathering statistics on
!     library use at ncar
!
!     check input parameters

  call chkprm(iorder,a,b,m,mbdcnd,c,d,n,nbdcnd,cofx,idmn,ierror)
  if (ierror .ne. 0) return

!     compute minimum work space and check work space length input

  l = n+1
  if (nbdcnd .eq. 0) l = n
  k = m+1
  l = n+1
!     estimate log base 2 of n

!     modified after conversation with john adams,feb.27,1980

  log2n=int(log((n+1.0_rq))/log(2.0_rq)+0.5_rq)
  length=4*(n+1)+(10+log2n)*(m+1)

  ierror = 11
  linput = int(w(1)+0.5_rq)
  ierror = 0

!     set work space indices

  i1 = length+2
  i2 = i1+l
  i3 = i2+l
  i4 = i3+l
  i5 = i4+l
  i6 = i5+l
  i7 = i6+l
  i8 = i7+k
  i9 = i8+k
  i10 = i9+k
  i11 = i10+k
  i12 = i11+k
  i13 = 2
  loutpt = length+6*(k+l)+i12+3
  w(1) = (loutpt)
  if (loutpt .gt. linput) return

  call spelip(iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n,nbdcnd, &
       bdc,bdd,cofx,w(i1),w(i2),w(i3), w(i4),w(i5),w(i6),w(i7),w(i8), &
       w(i9),w(i10),w(i11), w(i12),grhs,usol,idmn,w(i13),pertrb,ierror)

  return

end subroutine sepx4

function seval_c(n,u,x,y,b,c,d)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: x(n),y(n),b(n),c(n),d(n),seval_c
  data i/1/

  if (i.ge.n) i=1
  if (u.lt.x(i)) go to 10
  if (u.le.x(i+1)) go to 30
10 i=1
  j=n+1
20 k=(i+j)/2
  if (u.lt.x(k)) j=k
  if (u.ge.x(k)) i=k
  if (j.gt.i+1) go to 20
30 dx=u-x(i)
  seval_c=y(i)+dx*(b(i)+dx*(c(i)+dx*d(i)))

  return

end function seval_c

subroutine spelip(iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n, &
     nbdcnd,bdc,bdd,cofx,an,bn, cn,dn,un,zn,am,bm,cm,dm,um,zm,grhs, &
     usol,idmn, w,pertrb,ierror)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     spelip sets up vectors and arrays for input to blktri
!     and computes a second order solution in usol.  a return jump to
!     sepeli occurrs if iorder=2.  if iorder=4 a fourth order
!     solution is generated in usol.

  real(rq) :: bda(*),bdb(*),bdc(*),bdd(*),w(*)
  real(rq) :: grhs(idmn,*),usol(idmn,*)
  real(rq) :: an(*),bn(*),cn(*),dn(*),un(*),zn(*)
  real(rq) :: am(*),bm(*),cm(*),dm(*),um(*),zm(*)

  real(rq) :: a,b,alpha,c,d,pertrb
  real(rq) :: ait,bit,cit,dit,dlx,dly,tdlx3,tdly3,dlx4,dly4
  common /splp/ kswx,kswy,k,l,ait,bit,cit,dit,mit,nit,is, &
       ms,js,ns,dlx,dly,tdlx3,tdly3,dlx4,dly4

  logical singlr

  external cofx

!     set parameters internally

  kswx = mbdcnd+1
  kswy = nbdcnd+1
  k = m+1
  l = n+1
  ait = a
  bit = b
  cit = c
  dit = d
  dly=(dit-cit)/(n)

!     set right hand side values from grhs in usol on the interior
!     and non-specified boundaries.

  do i=2,m
     do j=2,n
        usol(i,j)=dly**2*grhs(i,j)
     end do
  end do
  if (kswx.eq.2 .or. kswx.eq.3) go to 40
  do j=2,n
     usol(1,j)=dly**2*grhs(1,j)
  end do
40 continue
  if (kswx.eq.2 .or. kswx.eq.5) go to 60
  do j=2,n
     usol(k,j)=dly**2*grhs(k,j)
  end do
60 continue
  if (kswy.eq.2 .or. kswy.eq.3) go to 80
  do i=2,m
     usol(i,1)=dly**2*grhs(i,1)
  end do
80 continue
  if (kswy.eq.2 .or. kswy.eq.5) go to 100
  do i=2,m
     usol(i,l)=dly**2*grhs(i,l)
  end do
100 continue
  if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.3) &
       usol(1,1)=dly**2*grhs(1,1)
  if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.3) &
       usol(k,1)=dly**2*grhs(k,1)
  if (kswx.ne.2 .and. kswx.ne.3 .and. kswy.ne.2 .and. kswy.ne.5) &
       usol(1,l)=dly**2*grhs(1,l)
  if (kswx.ne.2 .and. kswx.ne.5 .and. kswy.ne.2 .and. kswy.ne.5) &
       usol(k,l)=dly**2*grhs(k,l)

!     set switches for periodic or non-periodic boundaries

  mp=1
  if (kswx.eq.1) mp=0
  np=nbdcnd

!     set dlx,dly and size of block tri-diagonal system generated
!     in nint,mint

  dlx = (bit-ait)/(m)
  mit = k-1
  if (kswx .eq. 2) mit = k-2
  if (kswx .eq. 4) mit = k
  dly = (dit-cit)/(n)
  nit = l-1
  if (kswy .eq. 2) nit = l-2
  if (kswy .eq. 4) nit = l
  tdlx3 = 2.0_rq*dlx**3
  dlx4 = dlx**4
  tdly3 = 2.0_rq*dly**3
  dly4 = dly**4

!     set subscript limits for portion of array to input to blktri

  is = 1
  js = 1
  if (kswx.eq.2 .or. kswx.eq.3) is = 2
  if (kswy.eq.2 .or. kswy.eq.3) js = 2
  ns = nit+js-1
  ms = mit+is-1

!     set x - direction

  do i=1,mit
     xi = ait+(is+i-2)*dlx
     call cofx(xi,ai,bi,ci)
     axi = (ai/dlx-0.5_rq*bi)/dlx
     bxi = -2._rq*ai/dlx**2+ci
     cxi = (ai/dlx+0.5_rq*bi)/dlx
     am(i)=dly**2*axi
     bm(i)=dly**2*bxi
     cm(i)=dly**2*cxi
  end do

!     set y direction

  do j=1,nit
     dyj=1.0_rq
     eyj=-2.0_rq
     fyj=1.0_rq
     an(j) = dyj
     bn(j) = eyj
     cn(j) = fyj
  end do

!     adjust edges in x direction unless periodic

  ax1 = am(1)
  cxm = cm(mit)
  go to (170,130,150,160,140),kswx

!     dirichlet-dirichlet in x direction

130 am(1) = 0.0_rq
  cm(mit) = 0.0_rq
  go to 170

!     mixed-dirichlet in x direction

140 am(1) = 0.0_rq
  bm(1) = bm(1)+2._rq*alpha*dlx*ax1
  cm(1) = cm(1)+ax1
  cm(mit) = 0.0_rq
  go to 170

!     dirichlet-mixed in x direction

150 am(1) = 0.0_rq
  am(mit) = am(mit)+cxm
  bm(mit) = bm(mit)-2._rq*beta*dlx*cxm
  cm(mit) = 0.0_rq
  go to 170

!     mixed - mixed in x direction

160 continue
  am(1) = 0.0_rq
  bm(1) = bm(1)+2._rq*dlx*alpha*ax1
  cm(1) = cm(1)+ax1
  am(mit) = am(mit)+cxm
  bm(mit) = bm(mit)-2._rq*dlx*beta*cxm
  cm(mit) = 0.0_rq
170 continue

!     adjust in y direction unless periodic

  dy1 = an(1)
  fyn = cn(nit)
  gama=0.0_rq
  xnu=0.0_rq
  go to (220,180,200,210,190),kswy

!     dirichlet-dirichlet in y direction

180 continue
  an(1) = 0.0_rq
  cn(nit) = 0.0_rq
  go to 220

!     mixed-dirichlet in y direction

190 continue
  an(1) = 0.0_rq
  bn(1) = bn(1)+2._rq*dly*gama*dy1
  cn(1) = cn(1)+dy1
  cn(nit) = 0.0_rq
  go to 220

!     dirichlet-mixed in y direction

200 an(1) = 0.0_rq
  an(nit) = an(nit)+fyn
  bn(nit) = bn(nit)-2._rq*dly*xnu*fyn
  cn(nit) = 0.0_rq
  go to 220

!     mixed - mixed direction in y direction

210 continue
  an(1) = 0.0_rq
  bn(1) = bn(1)+2._rq*dly*gama*dy1
  cn(1) = cn(1)+dy1
  an(nit) = an(nit)+fyn
  bn(nit) = bn(nit)-2.0_rq*dly*xnu*fyn
  cn(nit) = 0.0_rq
220 if (kswx .eq. 1) go to 270

!     adjust usol along x edge

  do j=js,ns
     if (kswx.ne.2 .and. kswx.ne.3) go to 230
     usol(is,j) = usol(is,j)-ax1*usol(1,j)
     go to 240
230  usol(is,j) = usol(is,j)+2.0_rq*dlx*ax1*bda(j)
240  if (kswx.ne.2 .and. kswx.ne.5) go to 250
     usol(ms,j) = usol(ms,j)-cxm*usol(k,j)
     go to 260
250  usol(ms,j) = usol(ms,j)-2.0_rq*dlx*cxm*bdb(j)
260  continue
  end do
  270 if (kswy .eq. 1) go to 320

!     adjust usol along y edge

  do i=is,ms
     if (kswy.ne.2 .and. kswy.ne.3) go to 280
     usol(i,js) = usol(i,js)-dy1*usol(i,1)
     go to 290
280  usol(i,js) = usol(i,js)+2.0_rq*dly*dy1*bdc(i)
290  if (kswy.ne.2 .and. kswy.ne.5) go to 300
     usol(i,ns) = usol(i,ns)-fyn*usol(i,l)
     go to 310
300  usol(i,ns) = usol(i,ns)-2.0_rq*dly*fyn*bdd(i)
310  continue
  end do
320 continue

!     save adjusted edges in grhs if iorder=4

  if (iorder .ne. 4) go to 350
  do j=js,ns
     grhs(is,j) = usol(is,j)
     grhs(ms,j) = usol(ms,j)
  end do
  do i=is,ms
     grhs(i,js) = usol(i,js)
     grhs(i,ns) = usol(i,ns)
  end do
350 continue
  iord = iorder
  pertrb = 0.0_rq

!     check if operator is singular

  call chksng(mbdcnd,nbdcnd,alpha,beta,cofx,singlr)

!     compute non-zero eigenvector in null space of transpose
!     if singular

  if (singlr) call trisp (mit,am,bm,cm,dm,um,zm)
  if (singlr) call trisp (nit,an,bn,cn,dn,un,zn)

!     adjust right hand side if necessary

360 continue
  if (singlr) call orthog (usol,idmn,zn,zm,pertrb)

!     compute solution

!     save adjusted right hand side in grhs
  do j=js,ns
     do i=is,ms
        grhs(i,j)=usol(i,j)
     end do
  end do

  call genbun(np,nit,mp,mit,am,bm,cm,idmn,usol(is,js),ieror,w)
!     check if error detected in pois
!     this can only correspond to ierror=12
  if (ieror.eq.0) go to 224
!     set error flag if improper coefficients input to pois
  ierror=12
  return
224 continue
  if (ierror .ne. 0) return

!     set periodic boundaries if necessary

  if (kswx .ne. 1) go to 380
  do j=1,l
     usol(k,j) = usol(1,j)
  end do
380 if (kswy .ne. 1) go to 400
  do i=1,k
     usol(i,l) = usol(i,1)
  end do
400 continue

!     minimize solution with respect to weighted least squares
!     norm if operator is singular

  if (singlr) call minsol (usol,idmn,zn,zm,prtrb)

!     return if deferred corrections and a fourth order solution are
!     not flagged

  if (iord .eq. 2) return
  iord = 2

!     compute new right hand side for fourth order solution

  call defer(cofx,idmn,usol,grhs)
  go to 360

end subroutine spelip

subroutine store(x)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: x,v
  common /value/ v

  v = x

  return

end subroutine store

subroutine tri3(m,a,b,c,k,y1,y2,y3,tcos,d,w1,w2,w3)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: a(*),b(*),c(*),k(4),tcos(*),y1(*),y2(*),y3(*),d(*), &
       w1(*),w2(*),w3(*)

!     subroutine to solve three linear systems whose common coefficient
!     matrix is a rational function in the matrix given by
!
!                  tridiagonal (...,a(i),b(i),c(i),...)

  mm1 = m-1
  k1 = k(1)
  k2 = k(2)
  k3 = k(3)
  k4 = k(4)
  f1 = k1+1
  f2 = k2+1
  f3 = k3+1
  f4 = k4+1
  k2k3k4 = k2+k3+k4
  if (k2k3k4 .eq. 0) go to 101
  l1 = f1/f2
  l2 = f1/f3
  l3 = f1/f4
  lint1 = 1
  lint2 = 1
  lint3 = 1
  kint1 = k1
  kint2 = kint1+k2
  kint3 = kint2+k3
101 continue
  do n=1,k1
     x = tcos(n)
     if (k2k3k4 .eq. 0) go to 107
     if (n .ne. l1) go to 103
     do i=1,m
        w1(i) = y1(i)
     end do
103  if (n .ne. l2) go to 105
     do i=1,m
        w2(i) = y2(i)
     end do
105  if (n .ne. l3) go to 107
     do i=1,m
        w3(i) = y3(i)
     end do
107  continue
     z = 1._rq/(b(1)-x)
     d(1) = c(1)*z
     y1(1) = y1(1)*z
     y2(1) = y2(1)*z
     y3(1) = y3(1)*z
     do i=2,m
        z = 1._rq/(b(i)-x-a(i)*d(i-1))
        d(i) = c(i)*z
        y1(i) = (y1(i)-a(i)*y1(i-1))*z
        y2(i) = (y2(i)-a(i)*y2(i-1))*z
        y3(i) = (y3(i)-a(i)*y3(i-1))*z
     end do
     do ip=1,mm1
        i = m-ip
        y1(i) = y1(i)-d(i)*y1(i+1)
        y2(i) = y2(i)-d(i)*y2(i+1)
        y3(i) = y3(i)-d(i)*y3(i+1)
     end do
     if (k2k3k4 .eq. 0) go to 115
     if (n .ne. l1) go to 111
     i = lint1+kint1
     xx = x-tcos(i)
     do i=1,m
        y1(i) = xx*y1(i)+w1(i)
     end do
     lint1 = lint1+1
     l1 = ((lint1)*f1)/f2
111  if (n .ne. l2) go to 113
     i = lint2+kint2
     xx = x-tcos(i)
     do i=1,m
        y2(i) = xx*y2(i)+w2(i)
     end do
     lint2 = lint2+1
     l2 = ((lint2)*f1)/f3
113  if (n .ne. l3) go to 115
     i = lint3+kint3
     xx = x-tcos(i)
     do i=1,m
        y3(i) = xx*y3(i)+w3(i)
     end do
     lint3 = lint3+1
     l3 = ((lint3)*f1)/f4
115  continue
  end do

  return

end subroutine tri3

subroutine trisp(n,a,b,c,d,u,z)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     this subroutine solves for a non-zero eigenvector corresponding
!     to the zero eigenvalue of the transpose of the rank
!     deficient one matrix with subdiagonal a, diagonal b, and
!     superdiagonal c , with a(1) in the (1,n) position, with
!     c(n) in the (n,1) position, and all other elements zero.

  real(rq) :: a(n),b(n),c(n),d(n),u(n),z(n)

  bn = b(n)
  d(1) = a(2)/b(1)
  v = a(1)
  u(1) = c(n)/b(1)
  nm2 = n-2
  do j=2,nm2
     den = b(j)-c(j-1)*d(j-1)
     d(j) = a(j+1)/den
     u(j) = -c(j-1)*u(j-1)/den
     bn = bn-v*u(j-1)
     v = -v*d(j-1)
  end do
  den = b(n-1)-c(n-2)*d(n-2)
  d(n-1) = (a(n)-c(n-2)*u(n-2))/den
  an = c(n-1)-v*d(n-2)
  bn = bn-v*u(n-2)
  den = bn-an*d(n-1)

!     set last component equal to one

  z(n) = 1.0_rq
  z(n-1) = -d(n-1)
  nm1 = n-1
  do j=2,nm1
     k = n-j
     z(k) = -d(k)*z(k+1)-u(k)*z(n)
  end do

  return

end subroutine trisp

subroutine trix(idegbr,idegcr,m,a,b,c,y,tcos,d,w)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

!     subroutineto solve a system of linear equations where the
!     coefficient matrix is a rational function in the matrix given by
!     tridiagonal  ( . . . , a(i), b(i), c(i), . . . ).

  real(rq) :: a(*),b(*),c(*),y(*),tcos(*),d(*),w(*)

  mm1 = m-1
  fb = idegbr+1
  fc = idegcr+1
  l = fb/fc
  lint = 1
  do k=1,idegbr
     x = tcos(k)
     if (k .ne. l) go to 102
     i = idegbr+lint
     xx = x-tcos(i)
     do i=1,m
        w(i) = y(i)
        y(i) = xx*y(i)
     end do
102  continue
     z = 1._rq/(b(1)-x)
     d(1) = c(1)*z
     y(1) = y(1)*z
     do i=2,mm1
        z = 1._rq/(b(i)-x-a(i)*d(i-1))
        d(i) = c(i)*z
        y(i) = (y(i)-a(i)*y(i-1))*z
     end do
     z = b(m)-x-a(m)*d(mm1)
     if (z .ne. 0._rq) go to 104
     y(m) = 0._rq
     go to 105
104  y(m) = (y(m)-a(m)*y(mm1))/z
105  continue
     do ip=1,mm1
        i = m-ip
        y(i) = y(i)-d(i)*y(i+1)
     end do
     if (k .ne. l) go to 108
     do i=1,m
        y(i) = y(i)+w(i)
     end do
     lint = lint+1
     l = ((lint)*fb)/fc
108  continue
  end do

  return

end subroutine trix

function zeroin_c(ax,bx,f,tol)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: ax,bx,f,tol,zeroin_c

!      a zero of the function  f(x)  is computed in the interval ax,bx .
!
!  input..
!
!  ax     left endpoint of initial interval
!  bx     right endpoint of initial interval
!  f      function subprogram which evaluates f(x) for any x in
!         the interval  ax,bx
!  tol    desired length of the interval of uncertainty of the
!         final result ( .ge. 0.0)
!
!  output..
!
!  zeroin abcissa approximating a zero of  f  in the interval ax,bx
!
!      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
!  without  a  check.  zeroin  returns a zero  x  in the given interval
!  ax,bx  to within a tolerance  4*macheps*abs(x) + tol, where macheps
!  is the relative machine precision.
!      this function subprogram is a slightly  modified  translation  of
!  the algol 60 procedure  zero  given in  richard brent, algorithms for
!  minimization without derivatives, prentice - hall, inc. (1973).

  real(rq) :: a,b,c,d,e,eps,fa,fb,fc,tol1,xm,p,q,r,s

!  compute eps, the relative machine precision

  eps = 1.0_rq
10 eps = eps/2.0_rq
  tol1 = 1.0_rq + eps
  if (tol1 .gt. 1.0_rq) go to 10

! initialization

  a = ax
  b = bx
  fa = f(a)
  fb = f(b)

! begin step

20 c = a
  fc = fa
  d = b - a
  e = d
30 if (abs(fc) .ge. abs(fb)) go to 40
  a = b
  b = c
  c = a
  fa = fb
  fb = fc
  fc = fa

! convergence test

40 tol1 = 2.0_rq*eps*abs(b) + 0.5_rq*tol
  xm = .5_rq*(c - b)
  if (abs(xm) .le. tol1) go to 90
  if (fb .eq. 0.0_rq) go to 90

! is bisection necessary

  if (abs(e) .lt. tol1) go to 70
  if (abs(fa) .le. abs(fb)) go to 70

! is quadratic interpolation possible

  if (a .ne. c) go to 50

! linear interpolation

  s = fb/fa
  p = 2.0_rq*xm*s
  q = 1.0_rq - s
  go to 60

! inverse quadratic interpolation

50 q = fa/fc
  r = fb/fc
  s = fb/fa
  p = s*(2.0_rq*xm*q*(q - r) - (b - a)*(r - 1.0_rq))
  q = (q - 1.0_rq)*(r - 1.0_rq)*(s - 1.0_rq)

! adjust signs

60 if (p .gt. 0.0_rq) q = -q
  p = abs(p)

! is interpolation acceptable

  if ((2.0_rq*p) .ge. (3.0_rq*xm*q - abs(tol1*q))) go to 70
  if (p .ge. abs(0.5_rq*e*q)) go to 70
  e = d
  d = p/q
  go to 80

! bisection

70 d = xm
  e = d

! complete step

80 a = b
  fa = fb
  if (abs(d) .gt. tol1) b = b + d
  if (abs(d) .le. tol1) b = b + sign(tol1, xm)
  fb = f(b)
  if ((fb*(fc/abs(fc))) .gt. 0.0_rq) go to 20
  go to 30

! done

90 zeroin_c = b

  return

end function zeroin_c

function bessj(n,x,bessjp)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: bessj,x,bessjp
  parameter(iacc=40)

  bigni=(10.0_rq*errb_rq)*errb_rq ! d1mach(1)
!     bigno=0.10*r1mach(2)
  if (n.lt.1) call errdetec("bad index in bessj",0)
  bjm=bessj0(x)
  bj=bessj1(x)
  bessjp=bjm-bj/x
  bessj =bj
  if (n.eq.1) return
  tox=2._rq/x
  if (x.gt.(n)) then
     do j=1,n-1
        bjp=j*tox*bj-bjm
        bjm=bj
        bj=bjp
     end do
     bessj=bj
     bessjp=bjm-bj*n/x
  else
     ziacc=iacc
     m=2*((n+int(sqrt(ziacc*n)))/2)
     bessj=0._rq
     jsum=0
     sum=0._rq
     bjp=0._rq
!        bj=1.0
     bj=bigni*n/(2._rq*m)
     do j=m,1,-1
        bjm=j*tox*bj-bjp
        bjp=bj
        bj=bjm
!           if(abs(bj).gt.bigno)then
!              bj=bj*bigni
!              bjp=bjp*bigni
!              bessj=bessj*bigni
!              sum=sum*bigni
!           endif
        if (jsum.ne.0)sum=sum+bj
        jsum=1-jsum
        if (j.eq.n)bessj=bjp
        if (j.eq.n-1)bessjp=bjp
     end do
     sum=2._rq*sum-bj
     bessj=bessj/sum
     bessjp=bessjp/sum-n*bessj/x
  endif

  return

end function bessj

function bessj0(x)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: bessj0,x
  data p1,p2,p3,p4,p6 &
       /1._rq,-.1098628627e-2_rq,.2734510407e-4_rq, &
       -.2073370639e-5_rq,.2093887211e-6_rq/
  data q1,q2,q3,q4,q5/ &
       -.1562499995e-1_rq,.1430488765e-3_rq,-.6911147651e-5_rq, &
       .7621095161e-6_rq,-.934945152e-7_rq/
  data r1,r2,r3,z4,r5,r6 &
       /57568490574._rq,-13362590354._rq, &
       651619640._rq, -11214424.18_rq,77392.33017_rq,-184.9052456_rq/
  data s1,s2,s3,s4,s5,s6 &
       /57568490411._rq,1029532985._rq, &
       9494680.718_rq,59272.64853_rq,267.8532712_rq,1._rq/

  if (abs(x).lt.8._rq)then
     y=x**2
     bessj0=(r1+y*(r2+y*(r3+y*(z4+y*(r5+y*r6)))))/ &
          (s1+y*(s2+y*(s3+y*(s4+y*(s5+y*s6)))))
  else
     ax=abs(x)
     z=8._rq/ax
     y=z**2
     xx=ax-.785398164_rq
     bessj0=sqrt(.636619772_rq/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*p6))))- &
          z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
  endif

  return

end function bessj0

function bessj1(x)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: bessj1,x

  data r1,r2,r3,z4,r5,r6 &
       /72362614232._rq,-7895059235._rq, &
       242396853.1_rq, -2972611.439_rq,15704.48260_rq,-30.16036606_rq/
  data s1,s2,s3,s4,s5,s6 &
       /144725228442._rq,2300535178._rq, &
       18583304.74_rq,99447.43394_rq,376.9991397_rq,1._rq/
  data p1,p2,p3,p4,p6 &
       /1._rq,.183105e-2_rq,-.3516396496e-4_rq, &
       .2457520174e-5_rq, -.240337019e-6_rq/
  data q1,q2,q3,q4,q5 &
       /.04687499995_rq,-.2002690873e-3_rq,.8449199096e-5_rq, &
       -.88228987e-6_rq,.105787412e-6_rq/

  if (abs(x).lt.8._rq)then
     y=x**2
     bessj1=x*(r1+y*(r2+y*(r3+y*(z4+y*(r5+y*r6)))))/ &
          (s1+y*(s2+y*(s3+y*(s4+y*(s5+y*s6)))))
  else
     ax=abs(x)
     z=8._rq/ax
     y=z**2
     xx=ax-2.356194491_rq
     bessj1=sqrt(.636619772_rq/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*p6))))- &
          z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5))))) *sign(1._rq,x)
  endif

  return

end function bessj1

subroutine ssvd(nm,m,n,a,w,matu,u,matv,v,ierr,rv1)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  integer :: i,j,k,l,m,n,ii,i1,kk,k1,ll,l1,mn,nm,its,ierr
  real(rq) :: a(nm,n),w(n),u(nm,n),v(nm,n),rv1(n)
  real(rq) :: c,f,g,h,s,x,y,z,scale,anorm
  logical :: matu,matv

!     this subroutine is a translation of the algol procedure svd,
!     num. math. 14, 403-420(1970) by golub and reinsch.
!     handbook for auto. comp., vol ii-linear algebra, 134-151(1971).
!
!     this subroutine determines the singular value decomposition
!          t
!     a=usv  of a real m by n rectangular matrix.  householder
!     bidiagonalization and a variant of the qr algorithm are used.
!
!     on input.
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.  note that nm must be at least
!          as large as the maximum of m and n.
!
!        m is the number of rows of a (and u).
!
!        n is the number of columns of a (and u) and the order of v.
!
!        a contains the rectangular input matrix to be decomposed.
!
!        matu should be set to .true. if the u matrix in the
!          decomposition is desired, and to .false. otherwise.
!
!        matv should be set to .true. if the v matrix in the
!          decomposition is desired, and to .false. otherwise.
!
!     on output.
!
!        a is unaltered (unless overwritten by u or v).
!
!        w contains the n (non-negative) singular values of a (the
!          diagonal elements of s).  they are unordered.  if an
!          error exit is made, the singular values should be correct
!          for indices ierr+1,ierr+2,...,n.
!
!        u contains the matrix u (orthogonal column vectors) of the
!          decomposition if matu has been set to .true.  otherwise
!          u is used as a temporary array.  u may coincide with a.
!          if an error exit is made, the columns of u corresponding
!          to indices of correct singular values should be correct.
!
!        v contains the matrix v (orthogonal) of the decomposition if
!          matv has been set to .true.  otherwise v is not referenced.
!          v may also coincide with a if u is not needed.  if an error
!          exit is made, the columns of v corresponding to indices of
!          correct singular values should be correct.
!
!        ierr is set to
!          zero       for normal return,
!          k          if the k-th singular value has not been
!                     determined after 30 iterations.
!
!        rv1 is a temporary storage array.
!
!     questions and comments should be directed to b. s. garbow,
!     applied mathematics division, argonne national laboratory
!
!     modified to eliminate machep

  ierr = 0

  do i = 1, m
     do j = 1, n
        u(i,j) = a(i,j)
     end do
  end do
!     .......... householder reduction to bidiagonal form ..........
  g = 0.0_rq
  scale = 0.0_rq
  anorm = 0.0_rq

  do i = 1, n
     l = i + 1
     rv1(i) = scale * g
     g = 0.0_rq
     s = 0.0_rq
     scale = 0.0_rq
     if (i .gt. m) go to 210

     do k = i, m
        scale = scale + abs(u(k,i))
     end do

     if (scale .eq. 0.0_rq) go to 210

     do k = i, m
        u(k,i) = u(k,i) / scale
        s = s + u(k,i)**2
     end do

     f = u(i,i)
     g = -sign(sqrt(s),f)
     h = f * g - s
     u(i,i) = f - g
     if (i .eq. n) go to 190

     do j = l, n
        s = 0.0_rq
        do k = i, m
           s = s + u(k,i) * u(k,j)
        end do
        f = s / h
        do k = i, m
           u(k,j) = u(k,j) + f * u(k,i)
        end do
     end do

190  do k = i, m
        u(k,i) = scale * u(k,i)
     end do

210  w(i) = scale * g
     g = 0.0_rq
     s = 0.0_rq
     scale = 0.0_rq
     if (i .gt. m .or. i .eq. n) go to 290

     do k = l, n
        scale = scale + abs(u(i,k))
     end do

     if (scale .eq. 0.0_rq) go to 290

     do k = l, n
        u(i,k) = u(i,k) / scale
        s = s + u(i,k)**2
     end do

     f = u(i,l)
     g = -sign(sqrt(s),f)
     h = f * g - s
     u(i,l) = f - g

     do k = l, n
        rv1(k) = u(i,k) / h
     end do

     if (i .eq. m) go to 270

     do j = l, m
        s = 0.0_rq
        do k = l, n
           s = s + u(j,k) * u(i,k)
        end do
        do k = l, n
           u(j,k) = u(j,k) + s * rv1(k)
        end do
     end do
270  do k = l, n
        u(i,k) = scale * u(i,k)
     end do
290  anorm = max(anorm,abs(w(i))+abs(rv1(i)))
  end do
!     .......... accumulation of right-hand transformations ..........
  if (.not. matv) go to 410
!     .......... for i=n step -1 until 1 do -- ..........
  do ii = 1, n
     i = n + 1 - ii
     if (i .eq. n) go to 390
     if (g .eq. 0.0_rq) go to 360

     do j = l, n
!     .......... double division avoids possible underflow ..........
        v(j,i) = (u(i,j) / u(i,l)) / g
     end do

     do j = l, n
        s = 0.0_rq
        do k = l, n
           s = s + u(i,k) * v(k,j)
        end do
        do k = l, n
           v(k,j) = v(k,j) + s * v(k,i)
        end do
     end do

360  do j = l, n
        v(i,j) = 0.0_rq
        v(j,i) = 0.0_rq
     end do

390  v(i,i) = 1.0_rq
     g = rv1(i)
     l = i
  end do
!     .......... accumulation of left-hand transformations ..........
410 if (.not. matu) go to 510
!     ..........for i=min(m,n) step -1 until 1 do -- ..........
  mn = n
  if (m .lt. n) mn = m

  do ii = 1, mn
     i = mn + 1 - ii
     l = i + 1
     g = w(i)
     if (i .eq. n) go to 430

     do j = l, n
        u(i,j) = 0.0_rq
     end do

430  if (g .eq. 0.0_rq) go to 475
     if (i .eq. mn) go to 460

     do j = l, n
        s = 0.0_rq

        do k = l, m
           s = s + u(k,i) * u(k,j)
        end do
!     .......... double division avoids possible underflow ..........
        f = (s / u(i,i)) / g

        do k = i, m
           u(k,j) = u(k,j) + f * u(k,i)
        end do
     end do

460  do j = i, m
        u(j,i) = u(j,i) / g
     end do

     go to 490

475  do j = i, m
        u(j,i) = 0.0_rq
     end do

490  u(i,i) = u(i,i) + 1.0_rq
  end do

!     .......... diagonalization of the bidiagonal form ..........
!     .......... for k=n step -1 until 1 do -- ..........
!510 do 700 kk = 1, n
510 do kk = 1, n
     k1 = n - kk
     k = k1 + 1
     its = 0
!     .......... test for splitting.
!                for l=k step -1 until 1 do -- ..........
520  do ll = 1, k
        l1 = k - ll
        l = l1 + 1
        if (abs(rv1(l)) + anorm .eq. anorm) go to 565
!     .......... rv1(1) is always zero, so there is no exit
!                through the bottom of the loop ..........
        if (abs(w(l1)) + anorm .eq. anorm) go to 540
     end do
!     .......... cancellation of rv1(l) if l greater than 1 ..........
540  c = 0.0_rq
     s = 1.0_rq

     do i = l, k
        f = s * rv1(i)
        rv1(i) = c * rv1(i)
        if (abs(f) + anorm .eq. anorm) go to 565
        g = w(i)
        h = sqrt(f*f+g*g)
        w(i) = h
        c = g / h
        s = -f / h
        if (.not. matu) go to 560

        do j = 1, m
           y = u(j,l1)
           z = u(j,i)
           u(j,l1) = y * c + z * s
           u(j,i) = -y * s + z * c
        end do
560     continue
     end do
!     .......... test for convergence ..........
565  z = w(k)
     if (l .eq. k) go to 650
!     .......... shift from bottom 2 by 2 minor ..........
     if (its .eq. 30) go to 1000
     its = its + 1
     x = w(l)
     y = w(k1)
     g = rv1(k1)
     h = rv1(k)
     f = ((y - z) * (y + z) + (g - h) * (g + h)) / (2.0_rq * h * y)
     g = sqrt(f*f+1.0_rq)
     f = ((x - z) * (x + z) + h * (y / (f + sign(g,f)) - h)) / x
!     .......... next qr transformation ..........
     c = 1.0_rq
     s = 1.0_rq

     do i1 = l, k1
        i = i1 + 1
        g = rv1(i)
        y = w(i)
        h = s * g
        g = c * g
        z = sqrt(f*f+h*h)
        rv1(i1) = z
        c = f / z
        s = h / z
        f = x * c + g * s
        g = -x * s + g * c
        h = y * s
        y = y * c
        if (.not. matv) go to 575

        do j = 1, n
           x = v(j,i1)
           z = v(j,i)
           v(j,i1) = x * c + z * s
           v(j,i) = -x * s + z * c
        end do

575     z = sqrt(f*f+h*h)
        w(i1) = z
!     .......... rotation can be arbitrary if z is zero ..........
        if (z .eq. 0.0_rq) go to 580
        c = f / z
        s = h / z
580     f = c * g + s * y
        x = -s * g + c * y
        if (.not. matu) go to 600

        do j = 1, m
           y = u(j,i1)
           z = u(j,i)
           u(j,i1) = y * c + z * s
           u(j,i) = -y * s + z * c
        end do
600     continue
     end do

     rv1(l) = 0.0_rq
     rv1(k) = f
     w(k) = x
     go to 520
!     .......... convergence ..........
650  if (z .ge. 0.0_rq) go to 700
!     .......... w(k) is made non-negative ..........
     w(k) = -z
     if (.not. matv) go to 700

     do j = 1, n
        v(j,k) = -v(j,k)
     end do
700  continue
  end do

  go to 1001

!     .......... set error -- no convergence to a
!                singular value after 30 iterations ..........
1000 ierr = k

1001 return

end subroutine ssvd

!/hmb/boxcar_f --- boxcar average, ala IDL

subroutine boxcar_f(y,n,w,ys)

  use sep_math

  implicit real(rq) (a-h)
  implicit real(rq) (o-z)

  real(rq) :: y(*), ys(*)
  integer :: n, w
  integer :: hw, i, k, k1, k2

  hw = w / 2
  do i = 1,n
     ys(i) = 0.0_rq
     if (i .le. hw) then
        k1 = 1
        k2 = 2 * i - 1
     elseif (i .gt. n - hw) then
        k1 = 2 * i - n
        k2 = n
     else
        k1 = i - hw
        k2 = i + hw
     endif
     do k = k1,k2
        ys(i) = ys(i) + y(k)
     end do
     ys(i) = ys(i) / (k2 - k1 + 1)
  end do

  return

end subroutine boxcar_f

