#pragma -xO
c
c Note that this ancient code gives wrong results when aggressive 
c optimization is specified - tested this with several compilers.
c
c
c     solution of the matrix equation ax + xb = c.
c     source: netlib.org/linalg
c
c     this is a sample main program which solves randomly generated
c     problems.
c
c     a is reduced to schur form and b to upper-hessenberg form.
c     the resulting block-schur system of equations is
c     solved and the solution transformed back to that of the
c     original equation.
c
c     april 9, 1978.  written by stephen nash
c
c
      real xx(10),yy(10),zz(10)
      real*8 d1mach
      real*8 eps,ort(10),a(10,10),b(10,10),c(10,10),v(10,10)
     *      ,aa(10,10),bb(10,10),tt(10,10),dabs,t(10,10),dmax,work(5310)
c      data eps/z3410000000000000/
c
c     within the main program, a,b and c are stored normally.
c     at the end of the computation c holds the solution x. the array
c     work is used for temporary storage within the subroutines.
c     v is used to store the transformation matrix for a.
c     the transformation matrix for b is stored in ort and b.
c     c and x are m * n matrices. a is m * m, b is n * n.
c
      integer ipr(200)
      eps = d1mach(4)
      write(*,*) eps
      ndim = 10
      mdim = 10
      mode = 1
      iseed = 14365725
      maxiij = 2
      do 90 iijj = 1,maxiij
c
c     n and m are randomly generated in the range u10,50e.
c     afterwards, the matrices a,b, and x (stored in t) are
c     also generated randomly with entries in the interval u0,1).
c     iseed is a seed for the random number generator.
c     if iijj=1 we are generating a new problem.  when
c     iijj=2, the right hand side is changed, but the
c     coefficient matrices are left unchanged.
c
      call randk(iseed,xx(1),0)
      call randk(iseed,xx(2),0)
      m = 10
      n = 5
      if (iijj .eq. 2) mode = 2
      nm = max0(n,m)
      write(6,10) m,n
10    format('-solution of',i3,' by',i3,' matrix equation')
      do 20 i = 1,nm
         do 15 k = 1,nm
            call randk(iseed,xx(k),0)
            call randk(iseed,yy(k),0)
            call randk(iseed,zz(k),0)
15       continue
         do 20 j = 1,nm
            if (iijj .eq. 2) go to 17
            a(i,j) = xx(j)
            b(i,j) = yy(j)
            aa(i,j) = a(i,j)
            bb(i,j) = b(i,j)
17          t(i,j) = zz(j)
20    continue
      do 30 i = 1,nm
      do 30 j = 1,nm
         tt(i,j) = t(i,j)
30    continue
c
c     generate c from a, b, and x
c
      call slvchk(aa,bb,t,c,ndim,n,mdim,m)
c
c     now solve the matrix equation
c
      call axxbc(mode,ndim,n,mdim,m,a,v,b,c,ort,work,ipr,eps,ierr)
      if (ierr.ne.0) go to 60
c
c     check the size of the error.
c
      dmax = 0.d0
      do 40 i = 1,m
      do 40 j = 1,n
         if (dmax.lt.dabs(c(i,j)-tt(i,j))) dmax = dabs(c(i,j)-tt(i,j))
40    continue
      write(6,50) dmax
50    format(' maximal error = ', d14.6)
      go to 90
60    write(6,70)
70    format('0singular system of equations')
90    continue
      stop
      end
c
c
c
c
c
      subroutine randk (iy, yfl, index)
c
c     this is a uniform random number generator written by g. e.
c  forsythe in spring 1969, following d. knuth, the art of computer
c  programming, vol. 2, pp. 155-156.  it is much superior to randu,
c  the random number generator found in ibm's scientific subroutine
c  package.
c
c     before the first call of randk, iy should be set outside randk
c  to an arbitrary integer value.  (in watfor this is essential.)
c  for program checkout, the initial value of iy should be a fixed
c  integer.  for random numbers different on every run (and hence
c  not reproducible), declare integer clock1 and then initialize
c  iy to clock1(4).
c
c     if randk is called with an integer index = 1, then the output
c  value of iy is a pseudorandom integer uniformly distributed in the
c  range 0 <= iy < 2**31.
c
c     if randk is called with index = 0, then not only is iy produced,
c  but also (at some extra cost in time) a floating number yfl, uni-
c  formly distributed in the interval 0.0 <= yfl < 1.0.
c
      iy = iy*314159269 + 453806245
4     if (iy .ge. 0) go to 6
c
c  caution:  the statement label 4 is essential in order to prevent
c  certain compilers (e.g., fortran h with opt 0) from performing
c  unwanted "optimizations."  it should not be removed.
c
5        iy = iy + 2147483647 + 1
c        statement 5 adds 2**31 to negative values of iy
c
6     if (index) 7, 7, 8
c
7        yfl = iy
         yfl = yfl*.4656613e-9
c
8     return
      end
c
c
c
c
c
      subroutine slvchk(a,b,x,c,ndim,n,mdim,m)
c
      integer i,j,k,m,mdim,n,ndim
      real*8 a(mdim,m),b(ndim,n),x(mdim,n),c(mdim,n)
c
c     this subroutine forms ax + xb in order to check the solution
c     to the problem.  the result is stored in the matrix c.
c     parameters:
c     a,b,x - input matrices
c     c     - output matrix
c     ndim  - declared row dimension of the matrix b
c     n     - actual row dimension of b and column dimension
c             of b, c, and x
c     mdim  - declared row dimension of the matrices a, x, and c
c     m     - actual column dimesion of a and row dimension of
c             a, x, and c.
c
      do 10 i = 1,m
         do 10 j = 1,n
            c(i,j) = 0.d0
            do 10 k = 1,m
               c(i,j) = c(i,j) + a(i,k) * x(k,j)
10    continue
      do 20 i = 1,m
         do 20 j = 1,n
            do 20 k = 1,n
               c(i,j) = c(i,j) + x(i,k) * b(k,j)
20    continue
      return
      end
c
c------------------------------------------------------------------------
c
      subroutine axxbc(mode,ndim,n,mdim,m,a,v,b,c,ort,d,ipr,eps,ierr)
c
      integer i,ierr,ind,ipr(1),j,m,mdim,mode,n,ndim
      real*8 a(mdim,m),b(ndim,n),v(ndim,n),
     *     c(mdim,n),ort(1),eps,reps,d(1)
c
c     this routine solves the matrix equation ax + xb = c where
c
c        a - m * m matrix
c        x - m * n matrix
c        b - n * n matrix
c        c - m * n matrix.
c
c     the parameters for this subroutine are:
c
c     mode - indicates whether a new matrix equation is being solved,
c            or that just the right hand side has been changed.
c            mode=1 implies that the equation is new
c            mode=2 implies that only the right hand side is new
c     ndim - declared row dimension of the matrix b
c     n    - row dimension of b; column dimension of b and c
c     mdim - declared row dimension of a, c, and v
c     m    - row dimension of a, c, and v; column dimension of a and v
c     a    - m * m matrix (double precision)
c     b    - n * n matrix (double precision)
c     v    - n * n matrix (double precision) used to store the matrix
c            which transforms b(t) to upper schur form
c     c    - m * n matrix which holds c on input and x on output
c     ort  - double precision vector used by subroutine rg
c            of length at least max(n,m)
c     d    - double precision vector for internal use of length
c            at least 2m**2 + 7m
c     ipr  - integer vector for internal use of length at least 4n
c     eps  - error tolerance. eps should equal the smallest number
c            which satisfies fl(1 + eps) > 1.
c     ierr - integer variable used to set error codes.
c            ierr=0 => proper return.
c            ierr=j => j-th eigenvalue of b has not been determined
c                      after 30 qr iterations.
c            ierr=-j => a singular matrix was encountered when
c                       solving for the j-th column of x.
c
c     method:
c
c     first of all, b(transpose) is formed and is used instead of
c     b throughout the program. (in the following discussion, b(t) is
c     used to represent b(transpose)).
c     b(t) is transformed to real upper schur form and a to upper
c     hessenberg form using orthogonal transformations.
c     the right hand side c is multiplied by these transformation
c     matrices and the solution of this transformed system is
c     computed.  this solution is then multiplied by the trans-
c     formation matrices in order to obtain the solution to the
c     original problem.
c
c     note:
c
c     in order to get optimal efficiency from this routine, n should
c     be <= m.  if this is not true for your problem, transpose the
c     equation and solve the resulting problem.
c
c     -------------------------------------------------------------
c
c     form b(transpose) for internal use
c
      if (mode .eq. 2) go to 7
      do 5 i = 1,n
         do 5 j = i,n
            d(1) = b(i,j)
            b(i,j) = b(j,i)
            b(j,i) = d(1)
5     continue
c
c     a and b(t) will be transformed into the appropriate forms using
c     modifications of eispack routines (modified by s. nash).
c
c     warning:  do not change the order of the next two statements
c
      call rg(ndim,n,b,1,v,ort,eps,ierr)
      call rg(mdim,m,a,0,a,ort,eps,ierr)
c
c     now, transform the right hand side.
c
7     call transf(a,ort,1,c,v,0,m,n,mdim,ndim,d)
c
c     now solve the system of equations (block back substitution)
c     the system is block upper hessenberg with upper hessenberg
c     matrices on the diagonal (a + b(i,i) * i) and multiples of
c     the identity off the diagonal.
c     tests are made to see whether a single or a double block
c     must be handled at the current stage and appropriate
c     subroutines are called.
c
c     set relative error tolerance
c
      reps = eps*n*n*m*m
      ind = n - 1
      if (ind.eq.0) go to 40
10    if (dabs(b(ind + 1,ind)).le.reps)  go to 20
      call n2solv(a,b,c,d,ndim,n,mdim,m,ind,ipr,reps,ierr)
      if (ierr.ne.0) return
      go to 30
20    call nsolve(a,b,c,d,ndim,n,mdim,m,ind,ipr,reps,ierr)
      if (ierr.ne.0) return
30    if (ind.gt.0) go to 10
40    if (ind.eq.0) call nsolve(a,b,c,d,ndim,n,mdim,m,ind,ipr,reps,ierr)
c
c     the solution of the transformed system of equations
c     has now been obtained.  it is transformed back into
c     the solution of the original system of equations.
c
      call transf(a,ort,0,c,v,1,m,n,mdim,ndim,d)
      return
      end
c
c
c
c
c
      subroutine rg(ndim,n,a,matz,z,ort,eps,ierr)
c
      integer n,ndim,ierr,matz
      real*8 a(ndim,n),z(ndim,n),ort(n),eps
c
c     this subroutine reduces a to either upper-hessenberg
c     or schur form depending on whether matz is zero or not.
c     the routines used are from eispack except that hqr2 has
c     been modified so as not to compute the eigenvectors of
c     a and only reduces a to schur form. orthogonal transformations
c     are used throughout.
c     parameters:
c     ndim - declared row dimension of the matrix a
c     n    - actual dimension of the matrix a
c     a    - matrix to be transformed (on input) and transformed
c            matrix (on output)
c     matz - integer variable; matz = 0 => transform a to upper-
c            hessenberg form; otherwise compute the schur form of a
c     z    - stores the transformation matrix if a is transformed to
c          - schur form (if matz=0, z can be the same as a).
c     ort  - vector used for internal storage; if matz=0, ort holds
c            information about the transformation matrix
c     eps  - error tolerance, as in subroutine axxbc.
c     ierr - error code; see routine axxbc for details
c
      ierr=0
      call orthes(ndim,n,a,ort)
      if (matz.eq.0) return
      call ortran(ndim,n,a,ort,z)
      call hqr2(ndim,n,a,z,eps,ierr)
10    return
      end
c
c
c
c
c
      subroutine orthes(ndim,n,a,ort)
c
      integer i,j,m,n,ii,jj,la,mp,ndim,kp1
      real*8 a(ndim,n),ort(n)
      real*8 f,g,h,scale
      real*8 dsqrt,dabs,dsign
c
c     this subroutine is a translation of the algol procedure orthes,
c     num. math. 12, 349-368(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
c
c     given a real general matrix, this subroutine
c     reduces a submatrix situated in rows and columns
c     1 through n to upper hessenberg form by
c     orthogonal similarity transformations.
c
c     on input:
c
c        ndim must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement;
c
c        n is the order of the matrix;
c
c        a contains the input matrix.
c
c     on output:
c
c        a contains the hessenberg matrix.  information about
c          the orthogonal transformations used in the reduction
c          is stored in the remaining triangle under the
c          hessenberg matrix;
c
c        ort contains further information about the transformations.
c          only elements 1 through n are used.
c
c     questions and comments should be directed to b. s. garbow,
c     applied mathematics division, argonne national laboratory
c
c     -----------------------------------------------------------------
c
      la = n - 1
      kp1 = 2
      if (la .lt. kp1) go to 200
c
      do 180 m = kp1, la
         h = 0.0d0
         ort(m) = 0.0d0
         scale = 0.0d0
c
c     scale column (algol tol then not needed)
c
         do 90 i = m, n
90       scale = scale + dabs(a(i,m-1))
c
         if (scale .eq. 0.0d0) go to 180
         mp = m + n
c
c        for i=n step -1 until m do --
c
         do 100 ii = m, n
            i = mp - ii
            ort(i) = a(i,m-1) / scale
            h = h + ort(i) * ort(i)
100      continue
c
         g = -dsign(dsqrt(h),ort(m))
         h = h - ort(m) * g
         ort(m) = ort(m) - g
c
c        form (i-(u*ut)/h) * a
c
         do 130 j = m, n
            f = 0.0d0
c
c           for i=n step -1 until m do --
c
            do 110 ii = m, n
               i = mp - ii
               f = f + ort(i) * a(i,j)
110         continue
c
            f = f / h
c
            do 120 i = m, n
120         a(i,j) = a(i,j) - f * ort(i)
c
130      continue
c
c        form (i-(u*ut)/h)*a*(i-(u*ut)/h)
c
         do 160 i = 1, n
            f = 0.0d0
c
c           for j=n step -1 until m do --
c
            do 140 jj = m, n
               j = mp - jj
               f = f + ort(j) * a(i,j)
140         continue
c
            f = f / h
c
            do 150 j = m, n
150         a(i,j) = a(i,j) - f * ort(j)
c
160      continue
c
         ort(m) = scale * ort(m)
         a(m,m-1) = scale * g
180   continue
200   return
      end
c
c
c
c
c
      subroutine ortran(ndim,n,a,ort,z)
c
      integer i,j,n,kl,mm,mp,ndim,mp1
      real*8 a(ndim,n),ort(n),z(ndim,n)
      real*8 g
c
c     this subroutine is a translation of the algol procedure ortrans,
c     num. math. 16, 181-204(1970) by peters and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
c
c     this subroutine accumulates the orthogonal similarity
c     transformations used in the reduction of a real general
c     matrix to upper hessenberg form by  orthes.
c
c     on input:
c
c        ndim must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement;
c
c        n is the order of the matrix;
c
c        a contains information about the orthogonal trans-
c          formations used in the reduction by  orthes
c          in its strict lower triangle;
c
c        ort contains further information about the trans-
c          formations used in the reduction by  orthes.
c          only elements 1 through n are used.
c
c     on output:
c
c        z contains the transformation matrix produced in the
c          reduction by  orthes;
c
c        ort has been altered.
c
c     questions and comments should be directed to b. s. garbow,
c     applied mathematics division, argonne national laboratory
c
c     -----------------------------------------------------------
c
c     initialize z to identity matrix
c
      do 80 i = 1, n
c
         do 60 j = 1, n
60       z(i,j) = 0.0d0
c
         z(i,i) = 1.0d0
80    continue
c
      kl = n - 2
      if (kl .lt. 1) go to 200
c
c     for mp=n-1 step -1 until 2 do --
c
      do 140 mm = 1, kl
         mp = n - mm
         if (a(mp,mp-1) .eq. 0.0d0) go to 140
         mp1 = mp + 1
c
         do 100 i = mp1, n
100      ort(i) = a(i,mp-1)
c
         do 130 j = mp, n
            g = 0.0d0
c
            do 110 i = mp, n
110         g = g + ort(i) * z(i,j)
c
c           divisor below is negative of h formed in orthes.
c           double division avoids possible underflow
c
            g = (g / ort(mp)) / a(mp,mp-1)
c
            do 120 i = mp, n
120         z(i,j) = z(i,j) + g * ort(i)
c
130      continue
c
140   continue
c
200   return
      end
c
c
c
c
c
      subroutine hqr2(ndim,n,h,z,eps,ierr)
c
      integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,ndim,nn,
     x        its,mp2,enm2,ierr
      real*8 h(ndim,n),z(ndim,n)
      real*8 p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,eps
      real*8 dsqrt,dabs,dsign
      integer min0
      logical notlas
c
c     this subroutine is a translation of the algol procedure hqr2,
c     num. math. 16, 181-204(1970) by peters and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 372-395(1971).
c     it has been further modified by stephen nash so that it only
c     computes the schur form of the upper-hessenberg matrix h.
c
c     on input:
c
c        ndim must be set to the row dimension of two - dimensional
c          array parameters as declared in the calling program
c          dimension statement;
c
c        n is the order of the matrix;
c
c        h contains the upper hessenberg matrix;
c
c        z contains the transformation matrix produced by ortran
c          after the reduction by orthes.
c
c     on output:
c
c        h has been destroyed;
c
c        z contains the transformation matrix.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     -----------------------------------------------------------------
c
c     eps is a machine dependent parameter specifying
c     the relative precision of floating point arithmetic.
c
      ierr = 0
      norm = 0.0d0
      k = 1
c
c     compute matrix norm
c
      do 50 i = 1, n
c
         do 40 j = k, n
40       norm = norm + dabs(h(i,j))
c
         k = i
50    continue
c
      en = n
      t = 0.0d0
c
c     search for next eigenvalues
c
60    if (en .lt. 1) go to 340
      its = 0
      na = en - 1
      enm2 = na - 1
c
c     look for single small sub-diagonal element
c     for l=en step -1 until 1 do --
c
70    do 80 ll = 1, en
         l = en + 1 - ll
         if (l .eq. 1) go to 100
         s = dabs(h(l-1,l-1)) + dabs(h(l,l))
         if (s .eq. 0.0d0) s = norm
         if (dabs(h(l,l-1)) .le. eps * s) go to 100
80    continue
c
c     form shift
c
100   x = h(en,en)
      if (l .eq. en) go to 270
      y = h(na,na)
      w = h(en,na) * h(na,en)
      if (l .eq. na) go to 280
      if (its .eq. 30) go to 1000
      if (its .ne. 10 .and. its .ne. 20) go to 130
c
c     form exceptional shift
c
      t = t + x
c
      do 120 i = 1, en
120   h(i,i) = h(i,i) - x
c
      s = dabs(h(en,na)) + dabs(h(na,enm2))
      x = 0.75d0 * s
      y = x
      w = -0.4375d0 * s * s
130   its = its + 1
c
c     look for two consecutive small
c     sub-diagonal elements.
c     for m=en-2 step -1 until l do --
c
      do 140 mm = l, enm2
         m = enm2 + l - mm
         zz = h(m,m)
         r = x - zz
         s = y - zz
         p = (r * s - w) / h(m+1,m) + h(m,m+1)
         q = h(m+1,m+1) - zz - r - s
         r = h(m+2,m+1)
         s = dabs(p) + dabs(q) + dabs(r)
         p = p / s
         q = q / s
         r = r / s
         if (m .eq. l) go to 150
         if (dabs(h(m,m-1)) * (dabs(q) + dabs(r)) .le. eps * dabs(p)
     x    * (dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))) go to 150
140   continue
c
150   mp2 = m + 2
c
      do 160 i = mp2, en
         h(i,i-2) = 0.0d0
         if (i .eq. mp2) go to 160
         h(i,i-3) = 0.0d0
160   continue
c
c     double qr step involving rows l to en and
c     columns m to en
c
      do 260 k = m, na
         notlas = k .ne. na
         if (k .eq. m) go to 170
         p = h(k,k-1)
         q = h(k+1,k-1)
         r = 0.0d0
         if (notlas) r = h(k+2,k-1)
         x = dabs(p) + dabs(q) + dabs(r)
         if (x .eq. 0.0d0) go to 260
         p = p / x
         q = q / x
         r = r / x
170      s = dsign(dsqrt(p*p+q*q+r*r),p)
         if (k .eq. m) go to 180
         h(k,k-1) = -s * x
         go to 190
180      if (l .ne. m) h(k,k-1) = -h(k,k-1)
190      p = p + s
         x = p / s
         y = q / s
         zz = r / s
         q = q / p
         r = r / p
c
c        row modification
c
         do 210 j = k, n
            p = h(k,j) + q * h(k+1,j)
            if (.not. notlas) go to 200
            p = p + r * h(k+2,j)
            h(k+2,j) = h(k+2,j) - p * zz
200         h(k+1,j) = h(k+1,j) - p * y
            h(k,j) = h(k,j) - p * x
210      continue
c
         j = min0(en,k+3)
c
c        column modification
c
         do 230 i = 1, j
            p = x * h(i,k) + y * h(i,k+1)
            if (.not. notlas) go to 220
            p = p + zz * h(i,k+2)
            h(i,k+2) = h(i,k+2) - p * r
220         h(i,k+1) = h(i,k+1) - p * q
            h(i,k) = h(i,k) - p
230      continue
c
c        accumulate transformations
c
         do 250 i = 1, n
            p = x * z(i,k) + y * z(i,k+1)
            if (.not. notlas) go to 240
            p = p + zz * z(i,k+2)
            z(i,k+2) = z(i,k+2) - p * r
240         z(i,k+1) = z(i,k+1) - p * q
            z(i,k) = z(i,k) - p
250      continue
c
260   continue
c
      go to 70
c
c     one root found
c
270   h(en,en) = x + t
      en = na
      go to 60
c
c     two roots found
c
280   p = (y - x) / 2.0d0
      q = p * p + w
      zz = dsqrt(dabs(q))
      h(en,en) = x + t
      x = h(en,en)
      h(na,na) = y + t
      if (q .lt. 0.0d0) go to 320
c
c     real pair
c
      zz = p + dsign(zz,p)
      x = h(en,na)
      s = dabs(x) + dabs(zz)
      p = x / s
      q = zz / s
      r = dsqrt(p*p+q*q)
      p = p / r
      q = q / r
c
c     row modification
c
      do 290 j = na, n
         zz = h(na,j)
         h(na,j) = q * zz + p * h(en,j)
         h(en,j) = q * h(en,j) - p * zz
290   continue
c
c     column modification
c
      do 300 i = 1, en
         zz = h(i,na)
         h(i,na) = q * zz + p * h(i,en)
         h(i,en) = q * h(i,en) - p * zz
300   continue
c
c     accumulate transformations
c
      do 310 i = 1, n
         zz = z(i,na)
         z(i,na) = q * zz + p * z(i,en)
         z(i,en) = q * z(i,en) - p * zz
310   continue
c
      go to 330
c
c     complex pair
c
320   continue
330   en = enm2
      go to 60
c
c     all roots found.  backsubstitute to find
c     vectors of upper triangular form
c
1000  ierr = en
340   return
      end
c
c
c
c
c
      subroutine transf(a,ort,it1,c,v,it2,m,n,mdim,ndim,d)
c
      integer i,it1,it2,j,k,k1,k2,kk,m,mdim,n,n2
      real*8 v(ndim,n),c(mdim,n),a(mdim,m),ort(m),d(1),g
c
c     subroutine to form c(new) = u * c * v.  the integer variables
c     it1 and it2 indicate whether u(transpose) or v(transpose)
c     are required instead of u or v.
c     if itx = 0 then the actual matrix is used, if itx = 1, then
c     its transpose is used.
c     in order to save storage, the matrix u (the transformation
c     matrix for the matrix a) is stored in the lower part of a
c     and in the vector ort in coded form. (see subroutine orthes)
c     the parameters for this subroutine are as for the subroutine
c     axxbc except that here ort takes the place of ort.
c
c     --------------------------------------------------------------
c
c     form u * c and store in c (as in subroutine ortran)
c
      m2 = m - 2
c
c     check for small matrix
c
      if (m2.le.0) go to 45
      do 40 kk = 1,m2
         k = m2 - kk + 1
         if (it1.eq.1) k = kk
         k1 = k + 1
         if (a(k1,k).eq.0.d0) go to 40
         d(k1) = ort(k1)
         k2 = k + 2
         do 10 i = k2,m
            d(i) = a(i,k)
10       continue
         do 30 j = 1,n
            g = 0.d0
            do 20 i = k1,m
               g = g + d(i) * c(i,j)
20          continue
            g = g / ort(k1) / a(k1,k)
            do 30 i = k1,m
            c(i,j) = c(i,j) + g * d(i)
30       continue
40    continue
c
c     form c(new) = (u * c) * v
c
45    do 60 i = 1,m
         do 50 j = 1,n
            d(j) = 0.d0
            do 50 k = 1,n
               if (it2.eq.0) d(j) = d(j) + c(i,k) * v(k,j)
               if (it2.eq.1) d(j) = d(j) + c(i,k) * v(j,k)
50          continue
            do 60 j = 1,n
               c(i,j) = d(j)
60    continue
      return
      end
c
c
c
c
c
      subroutine nsolve(a,b,c,d,ndim,n,mdim,m,ind,ipr,reps,ierr)
c
      integer i,i1,ierr,ind,ipr(1),irow1,j,m,m1,mdim,n,ndim,mfin
      real*8 a(mdim,m),b(ndim,n),c(mdim,n),d(1),reps
c
c     this subroutine sets up and solves (with the help of
c     the subroutine hesolv) a single system of equations
c
c      ( a + b(ind+1,ind+1) * i )(x(ind+1)) = (c(ind+1))
c
c     (x(i),c(i) - column i of the matrices x and c)
c     and stores the result in the appropriate row of the
c     matrix c.  the upper-hessenberg matrix is stored in the
c     vector d in order to save storage (entries below the sub-
c     diagonal are ignored).
c     the right hand side is also stored in the vector d in order
c     to reduce the number of vectors used in the subroutines.
c     the parameters are as in the subroutine axxbc.
c
c     ----------------------------------------------------------
c
c     perform block back-substitution if necessary
c
      if (ind.lt.n - 1) call backsb(c,b,ind,n,m,mdim,ndim)
c
c     set up the system of equations
c
      mfin = (m * (m + 1)) / 2 + m
      do 20 i = 1,m
c
c        find index of beginning of row i within the vector d
c
         m1 = irow1(i,m)
         i1 = i - 1
         if (i.eq.1) i1 = 1
         do 10 j = i1,m
            d(m1+j-i1+1) = a(i,j)
10       continue
         j = 2
         if (i.eq.1) j = 1
         d(m1+j) = d(m1+j) + b(ind+1,ind+1)
c
c        store the right hand side
c
         d(mfin+i) = c(i,ind+1)
20    continue
c
c     solve the system of equations and store the result in c.
c
      call hesolv(d,ipr,m,reps,ierr)
      if (ierr.ne.0) go to 40
      do 30 i = 1,m
         c(i,ind+1) = d(ipr(i))
30    continue
      ind = ind - 1
      return
40    ierr = -ind - 1
      return
      end
c
c
c
c
c
      subroutine hesolv(d,ipr,m,reps,ierr)
c
      integer i,i1,i2,ierr,ipr(1),irow1,j,j1,k,n,n1,mfin
      real*8 d(1),dabs,mult,reps
c
c     this subroutine solves an upper-hessenberg system of equations
c     which is stored in packed form in the vector d.  the method used
c     is gaussian elimination with partial pivoting.  the parameters
c     in the subroutine are:
c     d      -  matrix of coefficients, right hand side (on input),
c               and solution (on output)
c     ipr    -  integer vector which records interchanges
c     m      -  size of system
c     reps   -  error tolerance
c     ierr   -  error code (ierr=0 => normal return)
c                          (ierr=-1 => singular matrix)
c
c     ----------------------------------------------------------------
c
c     initialize interchange vectors and parameters.
c
      ierr = 0
      mfin = (m * (m + 1)) / 2 + m
      do 10 i = 1,m
         ipr(m+i) = irow1(i,m)
         ipr(i) = i + mfin
10    continue
      m1 = m - 1
c
c     reduce the matrix to upper triangular form
c
      if (m.eq.1) go to 35
      do 30 i = 1,m1
         if (dabs(d(ipr(m+i)+1)).gt.dabs(d(ipr(m+i+1)+1))) go to 20
c
c        interchange rows if necessary
c
         k = ipr(m+i)
         ipr(m+i) = ipr(m+i+1)
         ipr(m+i+1) = k
         k = ipr(i)
         ipr(i) = ipr(i+1)
         ipr(i+1) = k
c
c        check for computationally singular matrix
c
20       if (dabs(d(ipr(m+i)+1)).lt.reps) go to 60
         ipr(m+i+1) = ipr(m+i+1) + 1
c
c        eliminate subdiagonal element of a
c
         mult = d(ipr(m+i+1)) / d(ipr(m+i)+1)
         d(ipr(i+1)) = d(ipr(i+1)) - mult * d(ipr(i))
         i1 = i + 1
         do 30 j = i1,m
            d(ipr(m+i+1)+j-i) = d(ipr(m+i+1)+j-i) -
     *                            mult*d(ipr(m+i)+j+1-i)
30    continue
35    if (dabs(d(ipr(m+m)+1)).lt.reps) go to 60
c
c     perform back - substitution
c
      d(ipr(m)) = d(ipr(m)) / d(ipr(m+m)+1)
      if (m1.eq.0) return
      do 50 i1 = 1,m1
         i = m - i1
         i2 = i + 1
         mult = 0.d0
         do 40 j1 = i2,m
            j = j1 - i2 + 2
            mult = mult + d(ipr(j1)) * d(ipr(m+i)+j)
40       continue
         d(ipr(i)) = (d(ipr(i)) - mult) / d(ipr(m+i)+1)
50    continue
      return
60    ierr = -1
      return
      end
c
c
c
c
      subroutine backsb(c,b,ind,n,m,mdim,ndim)
c
      integer i,ind,ind1,ind2,j,m,mdim,n,ndim
      real*8 b(ndim,n),c(mdim,n)
c
c     block back - substitution for one 'row'.
c     parameters are as in subroutine axxbc.
c
      ind1 = ind + 1
      ind2 = ind + 2
      do 10 i = ind2,n
         do 10 j = 1,m
            c(j,ind1) = c(j,ind1) - b(ind1,i) * c(j,i)
10    continue
      return
      end
c
c
c
c
c
      integer function irow1(i,m)
c
      integer i,m
c
c     this function computes the index (for the vector d) one before
c     the beginning of row i in the m*m matrix.
c
      irow1 = (i-1) * m - (i-2) * (i-3) / 2
      if (i.eq.1) irow1 = 0
      return
      end
c
c
c
c
c
      subroutine n2solv(a,b,c,d,ndim,n,mdim,m,ind,ipr,reps,ierr)
c
      integer i,i1,ierr,ind,ipr(1),irow2,j,j1,j2,k,lrow2,m,m1,
     *   mdim,n,ndim,mfin
      real*8 a(mdim,m),b(ndim,n),c(mdim,n),d(1),reps
c
c     this subroutine sets up a double system of equations.
c     it solves (using subroutine h2solv) the set of equations
c
c     ( a+b(ind,ind)*i        b(ind,ind+1) )( x(ind) )   ( c(ind) )
c     (                                    )(        ) = (        )
c     ( b(ind+1,ind)*i  a+b(ind+1,ind+1)*i )(x(ind+1))   (c(ind+1))
c
c     by interchanging rows and columns (to insure that there are
c     zeroes below the sub-sub-diagonal) and then using gaussian
c     elimination.  in order to take advantage of the number of
c     zeroes in this matrix, the matrix is stored in the vector
c     d in packed form. (entries below the sub-sub-diagonal are
c     ignored) the right hand side and solution are also stored in d.
c     the parameters are as in the subroutine axxbc.
c
c     ------------------------------------------------------------
c
c     perform block back-substitution if necessary
c
      if (ind.lt.n-1) call backs2(c,b,ind,n,m,mdim,ndim)
c
c     set up the system of equations for h2solv
c
      m2 = 2 * m
      mfin = (m2 * (m2 + 1)) / 2 + 4 * m
      do 20 i = 1,m
c
c        find beginning and length of row 2i-1 in the vector d.
c
         m1 = irow2(2*i-1,m)
         k = lrow2(2*i-1,m)
         i1 = i - 1
         if (i.eq.1) i1 = 1
         do 10 j = i1,m
            j1 = 2 * (j - i1 + 1)
            j2 = 1
            if (m1.eq.0) j2 = 0
            d(m1+j1-1) = a(i,j)
            d(m1+j1) = 0.d0
            d(m1+k+j1-j2) = a(i,j)
            d(m1+k+j1-1-j2) = 0.d0
10       continue
         j1 = 3
         if (i.eq.1) j1 = 1
         d(j1+m1) = d(j1+m1) + b(ind,ind)
         d(j1+m1+1) = d(j1+m1+1) + b(ind,ind+1)
         if (i.ne.1) j1 = 2
         d(j1+m1+k) = d(j1+m1+k) + b(ind+1,ind)
         d(j1+m1+k+1) = d(j1+m1+k+1) + b(ind+1,ind+1)
c
c        store right hand side
c
         d(2*i+mfin) = c(i,ind+1)
         d(2*i-1+mfin) = c(i,ind)
20    continue
c
c     solve the system of equations and store the result back in c
c
      call h2solv(d,ipr,m,reps,ierr)
      if (ierr.ne.0) go to 40
      do 30 i = 1,m
         c(i,ind) = d(ipr(2*i-1))
         c(i,ind+1) = d(ipr(2*i))
30    continue
      ind = ind - 2
      return
40    ierr = -ind - 1
      return
      end
c
c
c
c
c
      subroutine h2solv(d,ipr,m,reps,ierr)
c
      integer i,i1,i2,ierr,ipr(1),irow2,j,j1,k,k1,l,n,n2,n21,mfin
      real*8 reps,d(1),max,dabs
c
c     this subroutine solves a system of 2m * 2m equations
c     where the matrix has zeroes below the sub - sub - diagonal
c     and where the matrix is stored as a vector in packed form.
c     the method used is gaussian elimination.
c     parameters:
c     d      -  matrix of coefficients, right hand side (on input),
c               and solution (on output).
c     ipr    -  vector used to record row permutations
c     m      -  size of system
c     reps   -  error tolerance
c     ierr   -  error code (ierr=0 => normal return)
c                          (ierr=-1 => singular matrix)
c
c     --------------------------------------------------------------
c
c     initialize pivot vectors and size parameters.
c
      ierr = 0
      m2 = 2 * m
      mfin = (m2 * (m2 + 1)) / 2 + 4 * m
      do 10 i = 1,m2
         ipr(m2+i) = irow2(i,m)
         ipr(i) = i + mfin
10    continue
      m21 = m2 - 1
c
c     transform matrix to triangular form
c
      do 40 i = 1,m21
         i1 = 2
         if (i.eq.m21) i1 = 1
         l = 0
c
c        interchange rows if necessary
c
         max = dabs(d(ipr(m2+i) + 1))
         do 20 j = 1,i1
            if (dabs(d(ipr(m2+j+i) + 1)).le.max) go to 20
            max = dabs(d(ipr(m2+j+i) + 1))
            l = j
20       continue
c
c        check for computationally singular matrix
c
         if (max.le.reps) go to 80
         if (l.eq.0) go to 30
         k = ipr(m2+i)
         ipr(m2+i) = ipr(m2+l+i)
         ipr(m2+l+i) = k
         k = ipr(i)
         ipr(i) = ipr(i+l)
         ipr(i+l) = k
30       continue
c
c        adjust pointers to beginnings of rows
c
         ipr(m2+i+1) = ipr(m2+i+1) + 1
         if (i.ne.m21) ipr(m2+i+2) = ipr(m2+i+2) + 1
         ip1 = i + 1
c
c        eliminate subdiagonal elements in the matrix
c
         do 40 j = 1,i1
            max = d(ipr(m2+i+j)) / d(ipr(m2+i)+1)
            d(ipr(i+j)) = d(ipr(i+j)) - max * d(ipr(i))
            do 40 k1 = ip1,m2
               k = k1 - i
               d(ipr(m2+i+j)+k) = d(ipr(m2+i+j)+k) -
     *                                    max * d(ipr(m2+i)+1+k)
40    continue
      if (dabs(d(ipr(m2+m2)+1)).le.reps) go to 80
c
c     perform back substitution
c
      d(ipr(m2)) = d(ipr(m2)) / d(ipr(m2+m2)+1)
      do 60 i1 = 1,m21
         i = m2 - i1
         i2 = i + 1
         max = 0.d0
         do 50 j1 = i2,m2
            j = j1 - i2 + 2
            max = max + d(ipr(j1)) * d(ipr(m2+i)+j)
50       continue
         d(ipr(i)) = (d(ipr(i)) - max) / d(ipr(m2+i)+1)
60    continue
70    return
80    ierr = -1
      go to 70
      end
c
c
c
c
c
      subroutine backs2(c,b,ind,n,m,mdim,ndim)
c
      integer i,ind,ind1,ind2,j,m,mdim,n,ndim
      real*8 b(ndim,n),c(mdim,n)
c
c     block back - substitution for two 'rows'.
c     parameters are as in subroutine axxbc.
c
      ind1 = ind + 1
      ind2 = ind + 2
      do 10 i = ind2,n
         do 10 j = 1,m
            c(j,ind1) = c(j,ind1) - b(ind1,i) * c(j,i)
            c(j,ind) = c(j,ind) - b(ind,i) * c(j,i)
10    continue
      return
      end
c
c
c
c
c
      integer function irow2(i,m)
c
      integer i,k,m
c
c     this function finds the index (for the vector d) one
c     before the beginning of row i in the 2n*2n matrix.
c
      irow2 = 2 * (i - 1) * m
      k = (i - 4) * (i - 3) / 2
      if (i.le.2) k = 0
      irow2 = irow2 - k
      return
      end
c
c
c
c
c
      integer function lrow2(i,m)
c
      integer i,k,m
c
c     this function finds the length of row i in the
c     double matrix (when it is stored in packed form in the
c     vector d)
c
      k = i - 3
      if (i.le.2) k = 0
      lrow2 = 2 * m - k
      if (i.le.2) lrow2 = 2 * m
      return
      end

