! CJS:
! 1. Put eispack subroutines into a fortran90 module for consistency with the rest of the code.
! 2. USE the type_specifications module to set the KIND of reals and integers
! 3. Remove any TABS in the file and replace with spaces
! 4. end functions and subroutines with the form END SUBROUTINE name 
! 5. Remove all computed GOTO commands and Arithemtic IFs and replace with 
!    structures based on CASE and IF, ELSE IF, ELSE constructs respectively

MODULE eispack

USE type_specifications

CONTAINS
function pythag ( a, b )

!*****************************************************************************80
!
!! PYTHAG computes SQRT ( A * A + B * B ) carefully.
!
!  Discussion:
!
!    The formula
!
!      PYTHAG = sqrt ( A * A + B * B )
!
!    is reasonably accurate, but can fail if, for example, A^2 is larger
!    than the machine overflow.  The formula can lose most of its accuracy
!    if the sum of the squares is very large or very small.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Modified:
!
!    04 February 2003
!
!  Parameters:
!
!    Input, real (dp) A, B, the two legs of a right triangle.
!
!    Output, real (dp) PYTHAG, the length of the hypotenuse.
!
  implicit none

  real (dp) pythag 
  real (dp) a
  real (dp) b
  real (dp) p
  real (dp) r
  real (dp) s
  real (dp) t
  real (dp) u

  p = max ( abs ( a ), abs ( b ) )

  if ( p /= 0.0D+00 ) then

    r = ( min ( abs ( a ), abs ( b ) ) / p )**2

    do

      t = 4.0D+00 + r

      if ( t == 4.0D+00 ) then
        exit
      end if

      s = r / t
      u = 1.0D+00 + 2.0D+00 * s
      p = u * p
      r = ( s / u )**2 * r

    end do

  end if

  pythag = p

  return
end function pythag

subroutine bakvec ( n, t, e, m, z, ierr )

!*****************************************************************************80
!
!! BAKVEC determines eigenvectors by reversing the FIGI transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a nonsymmetric tridiagonal
!    matrix by back transforming those of the corresponding symmetric
!    matrix determined by FIGI.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) T(N,3), contains the nonsymmetric matrix.  Its
!    subdiagonal is stored in the positions 2:N of the first column,
!    its diagonal in positions 1:N of the second column,
!    and its superdiagonal in positions 1:N-1 of the third column.
!    T(1,1) and T(N,3) are arbitrary.
!
!    Input/output, real (dp) E(N).  On input, E(2:N) contains the
!    subdiagonal elements of the symmetric matrix.  E(1) is arbitrary.
!    On output, the contents of E have been destroyed.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M), contains the eigenvectors.
!    On output, they have been transformed as requested.
!
!    Output, integer ( i4 ) IERR, an error flag.
!    0, for normal return,
!    2*N+I, if E(I) is zero with T(I,1) or T(I-1,3) non-zero.
!    In this case, the symmetric matrix is not similar
!    to the original matrix, and the eigenvectors
!    cannot be found by this program.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) e(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) j
  real (dp) t(n,3)
  real (dp) z(n,m)

  ierr = 0

  if ( m == 0 ) then
    return
  end if

  e(1) = 1.0D+00
  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    if ( e(i) == 0.0D+00 ) then
      if ( t(i,1) /= 0.0D+00 .or. t(i-1,3) /= 0.0D+00 ) then
        ierr = 2 * n + i
        return
      end if
      e(i) = 1.0D+00
    else
      e(i) = e(i-1) * e(i) / t(i-1,3)
    end if
  end do

  do j = 1, m
    z(2:n,j) = z(2:n,j) * e(2:n)
  end do

  return
end subroutine bakvec

subroutine balanc ( n, a, low, igh, scale )

!*****************************************************************************80
!
!! BALANC balances a real matrix before eigenvalue calculations.
!
!  Discussion:
!
!    This subroutine balances a real matrix and isolates eigenvalues
!    whenever possible.
!
!    Suppose that the principal submatrix in rows LOW through IGH
!    has been balanced, that P(J) denotes the index interchanged
!    with J during the permutation step, and that the elements
!    of the diagonal matrix used are denoted by D(I,J).  Then
!
!      SCALE(J) = P(J),    J = 1,...,LOW-1,
!               = D(J,J),  J = LOW,...,IGH,
!               = P(J)     J = IGH+1,...,N.
!
!    The order in which the interchanges are made is N to IGH+1,
!    then 1 to LOW-1.
!
!    Note that 1 is returned for LOW if IGH is zero formally.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) A(N,N), the N by N matrix.  On output,
!    the matrix has been balanced.
!
!    Output, integer ( i4 ) LOW, IGH, indicate that A(I,J) is equal to
!    zero if
!    (1) I is greater than J and
!    (2) J=1,...,LOW-1 or I=IGH+1,...,N.
!
!    Output, real (dp) SCALE(N), contains information determining the
!    permutations and scaling factors used.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b2
  real (dp) c
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) iexc
  integer ( i4 ) igh
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) low
  integer ( i4 ) m
  logical noconv
  real (dp) r
  real (dp) radix
  real (dp) s
  real (dp) scale(n)

  radix = 16.0D+00

  iexc = 0
  j = 0
  m = 0

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

20 continue

  scale(m) = j

  if ( j /= m ) then

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

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

  end if

50 continue

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

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

  l = l - 1

100 continue

  do j = l, 1, -1

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

     m = l
     iexc = 1
     go to 20

120  continue

  end do

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

  k = k + 1

140 continue

  do j = k, l

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

    m = k
    iexc = 2
    go to 20

170 continue

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

  do while ( noconv )

    noconv = .false.

    do i = k, l

      c = 0.0D+00
      r = 0.0D+00

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

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

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

        g = r * radix

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

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

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

        end if

      end if

    end do

  end do

  low = k
  igh = l

  return
end subroutine balanc

subroutine balbak ( n, low, igh, scale, m, z )

!*****************************************************************************80
!
!! BALBAK determines eigenvectors by undoing the BALANC transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a real general matrix by
!    back transforming those of the corresponding balanced matrix
!    determined by BALANC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Parlett and Reinsch,
!    Numerische Mathematik,
!    Volume 13, pages 293-304, 1969.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, column indices determined by BALANC.
!
!    Input, real (dp) SCALE(N), contains information determining
!    the permutations and scaling factors used by BALANC.
!
!    Input, integer ( i4 ) M, the number of columns of Z to be
!    back-transformed.
!
!    Input/output, real (dp) Z(N,M), contains the real and imaginary 
!    parts of the eigenvectors, which, on return, have been back-transformed.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  integer ( i4 ) i
  integer ( i4 ) igh
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) low
  real (dp) s
  real (dp) scale(n)
  real (dp) t
  real (dp) z(n,m)

  if ( m <= 0 ) then
    return
  end if

  if ( igh /= low ) then
    do i = low, igh
      z(i,1:m) = z(i,1:m) * scale(i)
    end do
  end if

   do ii = 1, n

     i = ii

     if ( i < low .or. igh < i ) then

       if ( i < low ) then
         i = low - ii
       end if

       k = int ( scale(i) )

       if ( k /= i ) then

         do j = 1, m
           t      = z(i,j)
           z(i,j) = z(k,j)
           z(k,j) = t
         end do

        end if

      end if

  end do

  return
end subroutine balbak

subroutine bandr ( n, mb, a, d, e, e2, matz, z )

!*****************************************************************************80
!
!! BANDR reduces a symmetric band matrix to symmetric tridiagonal form.
!
!  Discussion:
!
!    This subroutine reduces a real symmetric band matrix
!    to a symmetric tridiagonal matrix using and optionally
!    accumulating orthogonal similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    09 November 2012
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) MB, is the (half) band width of the matrix,
!    defined as the number of adjacent diagonals, including the principal
!    diagonal, required to specify the non-zero portion of the
!    lower triangle of the matrix.
!
!    Input/output, real (dp) A(N,MB).  On input, contains the lower
!    triangle of the symmetric band input matrix stored as an N by MB array.
!    Its lowest subdiagonal is stored in the last N+1-MB positions of the first
!    column, its next subdiagonal in the last N+2-MB positions of the second
!    column, further subdiagonals similarly, and finally its principal diagonal
!    in the N positions of the last column.  Contents of storages not part of
!    the matrix are arbitrary.  On output, A has been destroyed, except for
!    its last two columns which contain a copy of the tridiagonal matrix.
!
!    Output, real (dp) D(N), the diagonal elements of the tridiagonal
!    matrix.
!
!    Output, real (dp) E(N), the subdiagonal elements of the tridiagonal
!    matrix in E(2:N).  E(1) is set to zero.
!
!    Output, real (dp) E2(N), contains the squares of the corresponding
!    elements of E.  E2 may coincide with E if the squares are not needed.
!
!    Input, logical MATZ, should be set to TRUE if the transformation matrix is
!    to be accumulated, and to FALSE otherwise.
!
!    Output, real (dp) Z(N,N), the orthogonal transformation matrix
!    produced in the reduction if MATZ has been set to TRUE.  Otherwise, Z is
!    not referenced.
!
  implicit none

  integer ( i4 ) mb
  integer ( i4 ) n

  real (dp) a(n,mb)
  real (dp) b1
  real (dp) b2
  real (dp) c2
  real (dp) d(n)
  real (dp) dmin
  real (dp) dminrt
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f1
  real (dp) f2
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) i1
  integer ( i4 ) i2
  integer ( i4 ) j
  integer ( i4 ) j1
  integer ( i4 ) j2
  integer ( i4 ) k
  integer ( i4 ) kr
  integer ( i4 ) l
  integer ( i4 ) m1
  logical matz
  integer ( i4 ) maxl
  integer ( i4 ) maxr
  integer ( i4 ) mr
  integer ( i4 ) r
  integer ( i4 ) r1
  real (dp) s2
  real (dp) u
  integer ( i4 ) ugl
  real (dp) z(n,n)

  dmin = epsilon ( dmin )
  dminrt = sqrt ( dmin )
!
!  Initialize the diagonal scaling matrix.
!
  d(1:n) = 1.0D+00

  if ( matz ) then

    z(1:n,1:n) = 0.0D+00

    do i = 1, n
      z(i,i) = 1.0D+00
    end do

  end if

  m1 = mb - 1

  if ( m1 < 1 ) then
    d(1:n) = a(1:n,mb)
    e(1:n) = 0.0D+00
    e2(1:n) = 0.0D+00
    return
  end if

  if ( m1 /= 1 ) then

    do k = 1, n - 2

      maxr = min ( m1, n - k )

      do r1 = 2, maxr

        r = maxr + 2 - r1
        kr = k + r
        mr = mb - r
        g = a(kr,mr)
        a(kr-1,1) = a(kr-1,mr+1)
        ugl = k

        do j = kr, n, m1

          j1 = j - 1
          j2 = j1 - 1

          if ( g == 0.0D+00 ) then
            exit
          end if

          b1 = a(j1,1) / g
          b2 = b1 * d(j1) / d(j)
          s2 = 1.0D+00 / ( 1.0D+00 + b1 * b2 )

          if ( s2 < 0.5D+00 ) then

            b1 = g / a(j1,1)
            b2 = b1 * d(j) / d(j1)
            c2 = 1.0D+00 - s2
            d(j1) = c2 * d(j1)
            d(j) = c2 * d(j)
            f1 = 2.0D+00 * a(j,m1)
            f2 = b1 * a(j1,mb)
            a(j,m1) = -b2 * ( b1 * a(j,m1) - a(j,mb) ) - f2 + a(j,m1)
            a(j1,mb) = b2 * ( b2 * a(j,mb) + f1 ) + a(j1,mb)
            a(j,mb) = b1 * ( f2 - f1 ) + a(j,mb)

            do l = ugl, j2
              i2 = mb - j + l
              u = a(j1,i2+1) + b2 * a(j,i2)
              a(j,i2) = -b1 * a(j1,i2+1) + a(j,i2)
              a(j1,i2+1) = u
            end do

            ugl = j
            a(j1,1) = a(j1,1) + b2 * g

            if ( j /= n ) then

              maxl = min ( m1, n - j1 )

              do l = 2, maxl
                i1 = j1 + l
                i2 = mb - l
                u = a(i1,i2) + b2 * a(i1,i2+1)
                a(i1,i2+1) = -b1 * a(i1,i2) + a(i1,i2+1)
                a(i1,i2) = u
              end do

              i1 = j + m1

              if ( i1 <= n ) then
                g = b2 * a(i1,1)
              end if

            end if

            if ( matz ) then

              do l = 1, n
                u = z(l,j1) + b2 * z(l,j)
                z(l,j) = -b1 * z(l,j1) + z(l,j)
                z(l,j1) = u
              end do

            end if

          else

            u = d(j1)
            d(j1) = s2 * d(j)
            d(j) = s2 * u
            f1 = 2.0D+00 * a(j,m1)
            f2 = b1 * a(j,mb)
            u = b1 * ( f2 - f1 ) + a(j1,mb)
            a(j,m1) = b2 * ( b1 * a(j,m1) - a(j1,mb) ) + f2 - a(j,m1)
            a(j1,mb) = b2 * ( b2 * a(j1,mb) + f1 ) + a(j,mb)
            a(j,mb) = u

            do l = ugl, j2
              i2 = mb - j + l
              u = b2 * a(j1,i2+1) + a(j,i2)
              a(j,i2) = -a(j1,i2+1) + b1 * a(j,i2)
              a(j1,i2+1) = u
            end do

            ugl = j
            a(j1,1) = b2 * a(j1,1) + g
 
            if ( j /= n ) then

              maxl = min ( m1, n - j1 )

              do l = 2, maxl
                i1 = j1 + l
                i2 = mb - l
                u = b2 * a(i1,i2) + a(i1,i2+1)
                a(i1,i2+1) = -a(i1,i2) + b1 * a(i1,i2+1)
                a(i1,i2) = u
              end do

              i1 = j + m1

              if ( i1 <= n ) then
                g = a(i1,1)
                a(i1,1) = b1 * a(i1,1)
              end if

            end if

            if ( matz ) then

              do l = 1, n
                u = b2 * z(l,j1) + z(l,j)
                z(l,j) = -z(l,j1) + b1 * z(l,j)
                z(l,j1) = u
              end do

            end if

          end if

        end do

      end do
!
!  Rescale to avoid underflow or overflow.
!
      if ( mod ( k, 64 ) == 0 ) then

        do j = k, n

          if ( d(j) < dmin ) then

            maxl = max ( 1, mb + 1 - j )

            a(j,maxl:m1) = dminrt * a(j,maxl:m1)

            if ( j /= n ) then

              maxl = min ( m1, n - j )

              do l = 1, maxl
                i1 = j + l
                i2 = mb - l
                a(i1,i2) = dminrt * a(i1,i2)
              end do

            end if

            if ( matz ) then
              z(1:n,j) = dminrt * z(1:n,j)
            end if

            a(j,mb) = dmin * a(j,mb)
            d(j) = d(j) / dmin

          end if

        end do

      end if

    end do

  end if
!
!  Form square root of scaling matrix.
!
  e(2:n) = sqrt ( d(2:n) )

  if ( matz ) then

    do k = 2, n
      z(1:n,k) = z(1:n,k) * e(k)
    end do

  end if

  u = 1.0D+00

  do j = 2, n
    a(j,m1) = u * e(j) * a(j,m1)
    u = e(j)
    e2(j) = a(j,m1)**2
    a(j,mb) = d(j) * a(j,mb)
    d(j) = a(j,mb)
    e(j) = a(j,m1)
  end do

  d(1) = a(1,mb)
  e(1) = 0.0D+00
  e2(1) = 0.0D+00

  return
end subroutine bandr

subroutine bandv ( n, mbw, a, e21, m, w, z, ierr )

!*****************************************************************************80
!
!! BANDV finds eigenvectors from eigenvalues, for a real symmetric band matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvectors of a real symmetric
!    band matrix corresponding to specified eigenvalues, using inverse
!    iteration.  The subroutine may also be used to solve systems
!    of linear equations with a symmetric or non-symmetric band
!    coefficient matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) MBW, the number of columns of the array A used
!    to store the band matrix.  If the matrix is symmetric, MBW is its (half)
!    band width, denoted MB and defined as the number of adjacent
!    diagonals, including the principal diagonal, required to
!    specify the non-zero portion of the lower triangle of the
!    matrix.  If the subroutine is being used to solve systems
!    of linear equations and the coefficient matrix is not
!    symmetric, it must however have the same number of adjacent
!    diagonals above the main diagonal as below, and in this
!    case, MBW=2*MB-1.
!
!    Input, real (dp) A(N,MBW), the lower triangle of the symmetric
!    band input matrix stored as an N by MB array.  Its lowest subdiagonal is
!    stored in the last N+1-MB positions of the first column, its next
!    subdiagonal in the last N+2-MB positions of the second column, further
!    subdiagonals similarly, and finally its principal diagonal in the N
!    positions of column MB.  If the subroutine is being used to solve systems
!    of linear equations, and the coefficient matrix is not symmetric, A is
!    N by 2*MB-1 instead, with lower triangle as above and with its first
!    superdiagonal stored in the first N-1 positions of column MB+1, its
!    second superdiagonal in the first N-2 positions of column MB+2, further
!    superdiagonals similarly, and finally its highest superdiagonal in
!    the first N+1-MB positions of the last column.  Contents of storages
!    not part of the matrix are arbitrary.
!
!    Input, real (dp) E21, specifies the ordering of the eigenvalues
!    and contains 0.0 if the eigenvalues are in ascending order, or 2.0 if
!    the eigenvalues are in descending order.  If the subroutine is being used
!    to solve systems of linear equations, E21 should be set to 1.0
!    if the coefficient matrix is symmetric and to -1.0 if not.
!
!    Input, integer ( i4 ) M, the number of specified eigenvalues or the
!    number of systems of linear equations.
!
!    Input, real (dp) W(M), contains the M eigenvalues in ascending or
!    descending order.  If the subroutine is being used to solve systems of
!    linear equations (A-W(1:M)*I) * X(1:M) = B(1:M), where I is the identity
!    matrix, W should be set accordingly.
!
!    Input/output, real (dp) Z(N,M).  On input, the constant matrix
!    columns B(1:M), if the subroutine is used to solve systems of linear
!    equations.  On output, the associated set of orthogonal eigenvectors.
!    Any vector which fails to converge is set to zero.  If the
!    routine is used to solve systems of linear equations,
!    Z contains the solution matrix columns X(1:M).
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    -R, if the eigenvector corresponding to the R-th eigenvalue fails to
!    converge, or if the R-th system of linear equations is nearly singular.
!
  implicit none

  integer ( i4 ) mbw
  integer ( i4 ) n

  real (dp) a(n,mbw)
  real (dp) e21
  real (dp) eps2
  real (dp) eps3
  real (dp) eps4
  integer ( i4 ) group
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ij
  integer ( i4 ) ij1
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) kj
  integer ( i4 ) kj1
  integer ( i4 ) m
  integer ( i4 ) m1
  integer ( i4 ) m21
  integer ( i4 ) maxj
  integer ( i4 ) maxk
  integer ( i4 ) mb
  real (dp) norm
  real (dp) order
  !  real (dp) pythag  ! removed as this is now in the same module
  integer ( i4 ) r
  real (dp) rv(n*(2*mbw-1))
  real (dp) rv6(n)
  real (dp) u
  real (dp) uk
  real (dp) v
  real (dp) w(m)
  real (dp) x0
  real (dp) x1
  real (dp) xu
  real (dp) z(n,m)

  ierr = 0

  if ( m == 0 ) then
    return
  end if

  x0 = 0.0D+00

  if ( e21 < 0.0D+00 ) then
    mb = ( mbw + 1 ) / 2
  else
    mb = mbw
  end if

  m1 = mb - 1
  m21 = m1 + mb
  order = 1.0D+00 - abs ( e21 )
!
!  Find vectors by inverse iteration.
!
  do r = 1, m

    its = 1
    x1 = w(r)

    if ( r /= 1 ) then
      go to 100
    end if
!
!  Compute norm of matrix.
!
    norm = 0.0D+00

    do j = 1, mb

      jj = mb + 1 - j
      kj = jj + m1
      ij = 1
      v = 0.0D+00

      do i = jj, n

        v = v + abs ( a(i,j) )

        if ( e21 < 0.0D+00 ) then
          v = v + abs ( a(ij,kj) )
          ij = ij + 1
        end if

      end do

      norm = max ( norm, v )

    end do

    if ( e21 < 0.0D+00 ) then
      norm = 0.5D+00 * norm
    end if
!
!  EPS2 is the criterion for grouping,
!  EPS3 replaces zero pivots and equal roots are modified by eps3,
!  EPS4 is taken very small to avoid overflow.
!
    if ( norm == 0.0D+00 ) then
      norm = 1.0D+00
    end if

    eps2 = 0.001D+00 * norm * abs ( order)
    eps3 = abs ( norm ) * epsilon ( norm )
    uk = n
    uk = sqrt ( uk )
    eps4 = uk * eps3

80  continue

    group = 0
    go to 120
!
!  Look for close or coincident roots.
!
100 continue

    if ( eps2 <= abs ( x1 - x0 ) ) then
      go to 80
    end if

    group = group + 1

    if ( order * ( x1 - x0 ) <= 0.0D+00 ) then
      x1 = x0 + order * eps3
    end if
!
!  Expand matrix, subtract eigenvalue, and initialize vector.
!
120 continue

    do i = 1, n

      ij = i + min ( 0, i - m1 ) * n
      kj = ij + mb * n
      ij1 = kj + m1 * n

      if ( m1 == 0 ) then
        go to 180
      end if

      do j = 1, m1

        if ( ij <= m1 ) then
          if ( ij <= 0 ) then
            rv(ij1) = 0.0D+00
            ij1 = ij1 + n
          end if
        else
          rv(ij) = a(i,j)
        end if

        ij = ij + n
        ii = i + j

        if ( ii <= n ) then

          jj = mb - j

          if ( e21 < 0.0D+00 ) then
            ii = i
            jj = mb + j
          end if

          rv(kj) = a(ii,jj)
          kj = kj + n

        end if

      end do

180   continue

      rv(ij) = a(i,mb) - x1
      rv6(i) = eps4
      if ( order == 0.0D+00 ) then
        rv6(i) = z(i,r)
      end if

    end do

    if ( m1 /= 0 ) then
!
!  Elimination with interchanges.
!
      do i = 1, n

        ii = i + 1
        maxk = min ( i + m1 - 1, n )
        maxj = min ( n - i, m21 - 2 ) * n

        do k = i, maxk

          kj1 = k
          j = kj1 + n
          jj = j + maxj

          do kj = j, jj, n
            rv(kj1) = rv(kj)
            kj1 = kj
          end do

          rv(kj1) = 0.0D+00

        end do

        if ( i /= n ) then

          u = 0.0D+00
          maxk = min ( i + m1, n )
          maxj = min ( n - ii, m21 - 2 ) * n

          do j = i, maxk
            if ( abs ( u ) <= abs ( rv(j) ) ) then
              u = rv(j)
              k = j
            end if
          end do

          j = i + n
          jj = j + maxj

          if ( k /= i ) then

            kj = k

            do ij = i, jj, n
              call r8_swap ( rv(ij), rv(kj) )
              kj = kj + n
            end do

            if ( order == 0.0D+00 ) then
              call r8_swap ( rv6(i), rv6(k) )
            end if

          end if

          if ( u /= 0.0D+00 ) then

            do k = ii, maxk

              v = rv(k) / u
              kj = k

              do ij = j, jj, n
                kj = kj + n
                rv(kj) = rv(kj) - v * rv(ij)
              end do

              if ( order == 0.0D+00 ) then
                rv6(k) = rv6(k) - v * rv6(i)
              end if

            end do

          end if

        end if

      end do

    end if
!
!  Back substitution.
!
600 continue

    do ii = 1, n

      i = n + 1 - ii
      maxj = min ( ii, m21 )

      if ( maxj /= 1 ) then

        ij1 = i
        j = ij1 + n
        jj = j + ( maxj - 2 ) * n

        do ij = j, jj, n
          ij1 = ij1 + 1
          rv6(i) = rv6(i) - rv(ij) * rv6(ij1)
        end do

      end if

      v = rv(i)
!
!  Error: nearly singular linear system.
!
      if ( abs ( v ) < eps3 ) then
        if ( order == 0.0D+00 ) then
          ierr = -r
        end if
        v = sign ( eps3, v )
      end if

      rv6(i) = rv6(i) / v

    end do

    xu = 1.0D+00

    if ( order == 0.0D+00 ) then
      go to 870
    end if
!
!  Orthogonalize with respect to previous members of group.
!
    do jj = 1, group

      j = r - group - 1 + jj

      xu = dot_product ( rv6(1:n), z(1:n,j) )

      rv6(1:n) = rv6(1:n) - xu * z(1:n,j)

    end do

    norm = sum ( abs ( rv6(1:n) ) )
!
!  Choose a new starting vector.
!
    if ( norm < 0.1D+00 ) then

      if ( its < n ) then
        its = its + 1
        xu = eps4 / ( uk + 1.0D+00 )
        rv6(1) = eps4
        rv6(2:n) = xu
        rv6(its) = rv6(its) - eps4 * uk
        go to 600
      else
        ierr = -r
        xu = 0.0D+00
        go to 870
      end if

    end if
!
!  Normalize so that sum of squares is 1 and expand to full order.
!
    u = 0.0D+00
    do i = 1, n
      u = pythag ( u, rv6(i) )
    end do

    xu = 1.0D+00 / u

870 continue

    z(1:n,r) = rv6(1:n) * xu

    x0 = x1

  end do

  return
end subroutine bandv

subroutine bisect ( n, eps1, d, e, e2, lb, ub, mm, m, w, ind, ierr )

!*****************************************************************************80
!
!! BISECT computes some eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvalues of a real symmetric
!    tridiagonal matrix which lie in a specified interval, using bisection.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) EPS1, is an absolute error tolerance for
!    the computed eigenvalues.  If the input EPS1 is non-positive, it is reset
!    for each submatrix to a default value, namely, minus the product of the
!    relative machine precision and the 1-norm of the submatrix.
!
!    Input, real (dp) D(N), the diagonal elements of the input matrix.
!
!    Input, real (dp) E(N), contains in E(2:N) the subdiagonal elements
!    of the matrix.  E(1) is arbitrary.
!
!    Input/output, real (dp) E2(N).  On input, the squares of the
!    corresponding elements of E.  E2(1) is arbitrary.  On output, elements of 
!    E2, corresponding to elements of E regarded as negligible, have been
!    replaced by zero, causing the matrix to split into a direct sum of
!    submatrices.  E2(1) is also set to zero.
!
!    Input, real (dp) LB, UB, define the interval to be searched for
!    eigenvalues.  If LB is not less than UB, no eigenvalues will be found.
!
!    Input, integer ( i4 ) MM, an upper bound for the number of
!    eigenvalues in the interval.  Warning: if more than MM eigenvalues are
!    determined to lie in the interval, an error return is made with no
!    eigenvalues found.
!
!    Output, integer ( i4 ) M, the number of eigenvalues determined to lie
!    in (LB,UB).
!
!    Output, real (dp) W(M), the eigenvalues in ascending order.
!
!    Output, integer ( i4 ) IND(MM), contains in its first M positions
!    the submatrix indices associated with the corresponding eigenvalues in W:
!    1 for eigenvalues belonging to the first submatrix from the top, 2 for
!    those belonging to the second submatrix, and so on.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    3*N+1, if M exceeds MM.
!
  implicit none

  integer ( i4 ) mm
  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) eps1
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ind(mm)
  integer ( i4 ) isturm
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) lb
  integer ( i4 ) m
  integer ( i4 ) m1
  integer ( i4 ) m2
  integer ( i4 ) p
  integer ( i4 ) q
  integer ( i4 ) r
  real (dp) rv4(n)
  real (dp) rv5(n)
  integer ( i4 ) s
  real (dp) t1
  real (dp) t2
  integer ( i4 ) tag
  real (dp) tst1
  real (dp) tst2
  real (dp) u
  real (dp) ub
  real (dp) v
  real (dp) w(mm)
  real (dp) x0
  real (dp) x1
  real (dp) xu

  ierr = 0
  s = 0
  tag = 0
  t1 = lb
  t2 = ub
!
!  Look for small sub-diagonal entries.
!
  e2(1) = 0.0D+00

  do i = 2, n

    tst1 = abs ( d(i) ) + abs ( d(i-1) )
    tst2 = tst1 + abs ( e(i) )

    if ( tst2 <= tst1 ) then
      e2(i) = 0.0D+00
    end if

  end do
!
!  Determine the number of eigenvalues in the interval.
!
  p = 1
  q = n
  x1 = ub
  isturm = 1
  go to 320

60 continue

  m = s
  x1 = lb
  isturm = 2
  go to 320

80 continue

  m = m - s

  if ( mm < m ) then
    go to 980
  end if

  q = 0
  r = 0
!
!  Establish and process next submatrix, refining
!  interval by the Gerschgorin bounds.
!
100 continue

  if ( r == m ) then
    go to 1001
  end if

  tag = tag + 1
  p = q + 1
  xu = d(p)
  x0 = d(p)
  u = 0.0D+00

  do q = p, n

    x1 = u
    u = 0.0D+00
    v = 0.0D+00

    if ( q /= n ) then
      u = abs ( e(q+1) )
      v = e2(q+1)
    end if

    xu = min ( d(q) - ( x1 + u ), xu )
    x0 = max ( d(q) + ( x1 + u ), x0 )

    if ( v == 0.0D+00 ) then
      exit
    end if

  end do

  x1 = max ( abs ( xu ), abs ( x0 ) ) * epsilon ( x1 )
  if ( eps1 <= 0.0D+00 ) then
    eps1 = -x1
  end if

  if ( p /= q ) then
    go to 180
  end if
!
!  Check for an isolated root within interval.
!
  if ( d(p) < t1 .or. t2 <= d(p) ) then
    go to 940
  end if

  m1 = p
  m2 = p
  rv5(p) = d(p)
  go to 900

  180 continue

  x1 = x1 * ( q - p + 1 )
  lb = max ( t1, xu - x1 )
  ub = min ( t2, x0 + x1 )
  x1 = lb
  isturm = 3
  go to 320

  200 continue

  m1 = s + 1
  x1 = ub
  isturm = 4
  go to 320

  220 continue

  m2 = s
  if ( m2 < m1 ) then
    go to 940
  end if
!
!  Find roots by bisection.
!
  x0 = ub
  isturm = 5
  rv5(m1:m2) = ub
  rv4(m1:m2) = lb
!
!  Loop for the K-th eigenvalue.
!
  k = m2

250 continue

     xu = lb

     do ii = m1, k
       i = m1 + k - ii
       if ( xu < rv4(i) ) then
         xu = rv4(i)
         go to 280
       end if
     end do

  280 continue

   x0 = min ( x0, rv5(k) )
!
!  Next bisection step.
!
  300    continue

     x1 = ( xu + x0 ) * 0.5D+00

     if ( ( x0 - xu ) <= abs ( eps1 ) ) then
       go to 420
     end if

     tst1 = 2.0D+00 * ( abs ( xu ) + abs ( x0 ) )
     tst2 = tst1 + ( x0 - xu )
     if ( tst2 == tst1 ) then
       go to 420
     end if
!
!  Sturm sequence.
!
320  continue

     s = p - 1
     u = 1.0D+00

     do i = p, q

        if ( u == 0.0D+00 ) then
          v = abs ( e(i) ) / epsilon ( v )
          if ( e2(i) == 0.0D+00 ) then
            v = 0.0D+00
          end if
        else
          v = e2(i) / u
        end if

        u = d(i) - x1 - v
        if ( u < 0.0D+00 ) then
          s = s + 1
        end if

     end do

!     go to (60,80,200,220,360), isturm
! Replaced computed GOTO with a select case structure
     select case (isturm)     
     case(1)
       GOTO 60
     case(2)
       GOTO 80
     case(3)
       GOTO 220
     case(4)
       GOTO 360
     case default     
       CONTINUE    
     end select

!
!  Refine intervals.
!
  360 continue

     if ( k <= s ) then
       go to 400
     end if

     xu = x1

     if ( s < m1 ) then
       rv4(m1) = x1
       go to 300
     end if

  380 continue

     rv4(s+1) = x1

     if ( x1 < rv5(s) ) then
       rv5(s) = x1
     end if

     go to 300
400  continue
     x0 = x1
     go to 300
!
!  K-th eigenvalue found.
!
420 continue

  rv5(k) = x1
  k = k - 1

  if ( m1 <= k ) then
    go to 250
  end if
!
!  Order eigenvalues tagged with their submatrix associations.
!
900 continue

  s = r
  r = r + m2 - m1 + 1
  j = 1
  k = m1

  do l = 1, r

    if ( j <= s ) then

      if ( m2 < k ) then
        exit
      end if

      if ( w(l) <= rv5(k) ) then
        j = j + 1
        cycle
      end if

      do ii = j, s
        i = l + s - ii
        w(i+1) = w(i)
        ind(i+1) = ind(i)
      end do

    end if

    w(l) = rv5(k)
    ind(l) = tag
    k = k + 1

  end do

940 continue

  if ( q < n ) then
    go to 100
  end if

  go to 1001
!
!  Set error: underestimate of number of eigenvalues in interval.
!
980 continue

  ierr = 3 * n + 1

 1001 continue

  lb = t1
  ub = t2

  return
end subroutine bisect

subroutine bqr ( n, mb, a, t, r, ierr )

!*****************************************************************************80
!
!! BQR finds the smallest eigenvalue of a real symmetric band matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalue of smallest magnitude of a real
!    symmetric band matrix using the QR algorithm with shifts of origin.
!    Consecutive calls can be made to find further eigenvalues.
!
!    Note that for a subsequent call, N should be replaced by N-1, but
!    MB should not be altered even when it exceeds the current N.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) MB, the (half) band width of the matrix,
!    defined as the number of adjacent diagonals, including the principal
!    diagonal, required to specify the non-zero portion of the
!    lower triangle of the matrix.
!
!    Input/output, real (dp) A(N,MB).  On input, A contains the lower
!    triangle of the symmetric band input matrix stored as an N by MB array.
!    Its lowest subdiagonal is stored in the last N+1-MB positions of the first
!    column, its next subdiagonal in the last N+2-MB positions of the
!    second column, further subdiagonals similarly, and finally its principal
!    diagonal in the N positions of the last column.  Contents of storages
!    not part of the matrix are arbitrary.  On a subsequent call, its output
!    contents from the previous call should be passed.  On output, A contains
!    the transformed band matrix.  The matrix A+T*I derived from the output
!    parameters is similar to the input A+T*I to within rounding errors.
!    Its last row and column are null as long as IERR is zero.
!
!    Input/output, real (dp) T.  On input, T specifies the shift (of
!    eigenvalues) applied to the diagonal of A in forming the input matrix.
!    What is actually determined is the eigenvalue nearest to T of A+T*I, where
!    I is the identity matrix.  On a subsequent call, the output value of T
!    from the previous call should be passed if the next nearest eigenvalue
!    is sought.  On output, T contains the computed eigenvalue of A+T*I,
!    as long as IERR is zero.
!
!    Input/output, real (dp) R.  On input for the first call, R should 
!    be specified as zero, and as its output value from the previous call
!    on a subsequent call.  It is used to determine when the last row and
!    column of the transformed band matrix can be regarded as negligible.
!    On output, R contains the maximum of its input value and the norm of the
!    last column of the input matrix A.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, normal return.
!    N, if the eigenvalue has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) mb
  integer ( i4 ) n

  real (dp) a(n,mb)
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ik
  integer ( i4 ) imult
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jk
  integer ( i4 ) jm
  integer ( i4 ) k
  integer ( i4 ) kj
  integer ( i4 ) kj1
  integer ( i4 ) kk
  integer ( i4 ) km
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) m
  integer ( i4 ) m1
  integer ( i4 ) m2
  integer ( i4 ) m21
  integer ( i4 ) m3
  integer ( i4 ) m31
  integer ( i4 ) m4
  integer ( i4 ) mk
  integer ( i4 ) mn
  integer ( i4 ) mz
  integer ( i4 ) ni
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) q
  real (dp) r
  real (dp) rv(2*mb*mb+4*mb-3)
  real (dp) s
  real (dp) scale
  real (dp) t
  real (dp) tst1
  real (dp) tst2

  ierr = 0
  m1 = min ( mb, n )
  m = m1 - 1
  m2 = m + m
  m21 = m2 + 1
  m3 = m21 + m
  m31 = m3 + 1
  m4 = m31 + m2
  mn = m + n
  mz = mb - m1
  its = 0
!
!  Test for convergence.
!
40 continue

  g = a(n,mb)

  if ( m == 0 ) then
    go to 360
  end if

  f = 0.0D+00
  do k = 1, m
    mk = k + mz
    f = f + abs ( a(n,mk) )
  end do

  if ( its == 0 .and. r < f ) then
    r = f
  end if

  tst1 = r
  tst2 = tst1 + f

  if ( tst2 <= tst1 ) then
    go to 360
  end if

  if ( 30 <= its ) then
    ierr = n
    return
  end if

  its = its + 1
!
!  Form shift from bottom 2 by 2 minor.
!
  if ( f <= 0.25D+00 * r .or. 5 <= its ) then

    f = a(n,mb-1)

    if ( f /= 0.0D+00 ) then
      q = ( a(n-1,mb) - g ) / ( 2.0D+00 * f )
      s = pythag ( q, 1.0D+00 )
      g = g - f / ( q + sign ( s, q ) )
    end if

    t = t + g

    a(1:n,mb) = a(1:n,mb) - g

  end if

  rv(m31:m4) = 0.0D+00

  do ii = 1, mn

     i = ii - m
     ni = n - ii

     if ( ni < 0 ) then
       go to 230
     end if
!
!  Form column of shifted matrix A-G*I.
!
     l = max ( 1, 2-i )

     rv(1:m3) = 0.0D+00

     do k = l, m1
       km = k + m
       mk = k + mz
       rv(km) = a(ii,mk)
     end do

     ll = min ( m, ni )

     do k = 1, ll
       km = k + m21
       ik = ii + k
       mk = mb - k
       rv(km) = a(ik,mk)
     end do
!
!  Pre-multiply with Householder reflections.
!
     ll = m2
     imult = 0
!
!  Multiplication procedure.
!
140  continue

     kj = m4 - m1

     do j = 1, ll

        kj = kj + m1
        jm = j + m3

        if ( rv(jm) /= 0.0D+00 ) then

          f = 0.0D+00

          do k = 1, m1
            kj = kj + 1
            jk = j + k - 1
            f = f + rv(kj) * rv(jk)
          end do

          f = f / rv(jm)
          kj = kj - m1

          do k = 1, m1
            kj = kj + 1
            jk = j + k - 1
            rv(jk) = rv(jk) - rv(kj) * f
          end do

          kj = kj - m1

        end if

     end do

     if ( imult /= 0 ) then
       go to 280
     end if
!
!  Householder reflection.
!
     f = rv(m21)
     s = 0.0D+00
     rv(m4) = 0.0D+00
     scale = sum ( abs ( rv(m21:m3) ) )

     if ( scale == 0.0D+00 ) then
       go to 210
     end if

     do k = m21, m3
       s = s + ( rv(k) / scale )**2
     end do

     s = scale * scale * s
     g = - sign ( sqrt ( s ), f )
     rv(m21) = g
     rv(m4) = s - f * g
     kj = m4 + m2 * m1 + 1
     rv(kj) = f - g

     do k = 2, m1
       kj = kj + 1
       km = k + m2
       rv(kj) = rv(km)
     end do
!
!  Save column of triangular factor R.
!
210  continue

     do k = l, m1
       km = k + m
       mk = k + mz
       a(ii,mk) = rv(km)
     end do

230  continue

     l = max ( 1, m1+1-i )
     if ( i <= 0 ) then
       go to 300
     end if
!
!  Perform additional steps.
!
     rv(1:m21) = 0.0D+00
     ll = min ( m1, ni + m1 )
!
!  Get row of triangular factor R.
!
     do kk = 1, ll
       k = kk - 1
       km = k + m1
       ik = i + k
       mk = mb - k
       rv(km) = a(ik,mk)
     end do
!
!  Post-multiply with Householder reflections.
!
     ll = m1
     imult = 1
     go to 140
!
!  Store column of new a matrix.
!
280  continue

     do k = l, m1
       mk = k + mz
       a(i,mk) = rv(k)
     end do
!
!  Update Householder reflections.
!
300  continue

     if ( 1 < l ) then
       l = l - 1
     end if

     kj1 = m4 + l * m1

     do j = l, m2

       jm = j + m3
       rv(jm) = rv(jm+1)

       do k = 1, m1
         kj1 = kj1 + 1
         kj = kj1 - m1
         rv(kj) = rv(kj1)
       end do

     end do

  end do

  go to 40
!
!  Convergence.
!
360 continue

  t = t + g
  a(1:n,mb) = a(1:n,mb) - g

  do k = 1, m1
    mk = k + mz
    a(n,mk) = 0.0D+00
  end do

  return
end subroutine bqr

subroutine cbabk2 ( n, low, igh, scale, m, zr, zi )

!*****************************************************************************80
!
!! CBABK2 finds eigenvectors by undoing the CBAL transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex general
!    matrix by back transforming those of the corresponding
!    balanced matrix determined by CBAL.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, values determined by CBAL.
!
!    Input, real (dp) SCALE(N), information determining the permutations
!    and scaling factors used by CBAL.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) ZR(N,M), ZI(N,M).  On input, the real
!    and imaginary parts, respectively, of the eigenvectors to be back
!    transformed in their first M columns.  On output, the transformed
!    eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  integer ( i4 ) i
  integer ( i4 ) igh
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) low
  real (dp) s
  real (dp) scale(n)
  real (dp) zi(n,m)
  real (dp) zr(n,m)

  if ( m == 0 ) then
    return
  end if

  if ( igh /= low ) then

    do i = low, igh

      s = scale(i)

      zr(i,1:m) = zr(i,1:m) * s
      zi(i,1:m) = zi(i,1:m) * s

    end do

  end if

  do ii = 1, n

    i = ii

    if ( i < low .or. igh < i ) then

      if ( i < low ) then
        i = low - ii
      end if

      k = scale(i)

      if ( k /= i ) then

        do j = 1, m
          call r8_swap ( zr(i,j), zr(k,j) )
          call r8_swap ( zi(i,j), zi(k,j) )
        end do

      end if

    end if

  end do

  return
end subroutine cbabk2

subroutine cbal ( n, ar, ai, low, igh, scale )

!*****************************************************************************80
!
!! CBAL balances a complex matrix before eigenvalue calculations.
!
!  Discussion:
!
!    This subroutine balances a complex matrix and isolates
!    eigenvalues whenever possible.
!
!    Suppose that the principal submatrix in rows low through igh
!    has been balanced, that P(J) denotes the index interchanged
!    with J during the permutation step, and that the elements
!    of the diagonal matrix used are denoted by D(I,J).  Then
!      SCALE(J) = P(J),    for J = 1,...,LOW-1
!               = D(J,J)       J = LOW,...,IGH
!               = P(J)         J = IGH+1,...,N.
!    The order in which the interchanges are made is N to IGH+1,
!    then 1 to LOW-1.
!
!    Note that 1 is returned for IGH if IGH is zero formally.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real and
!    imaginary parts of the complex matrix to be balanced.  On output,
!    the real and imaginary parts of the balanced matrix.
!
!    Output, integer ( i4 ) LOW, IGH, are values such that AR(I,J)
!    and AI(I,J) are zero if I is greater than J and either J=1,...,LOW-1 or
!    I=IGH+1,...,N.
!
!    Output, real (dp) SCALE(N), information determining the
!    permutations and scaling factors used.
!
  implicit none

  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) b2
  real (dp) c
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) iexc
  integer ( i4 ) igh
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) low
  integer ( i4 ) m
  logical noconv
  real (dp) r
  real (dp) radix
  real (dp) s
  real (dp) scale(n)

  radix = 16.0D+00

  iexc = 0
  j = 0
  m = 0

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

20 continue

  scale(m) = j

  if ( j /= m ) then

    do i = 1, l
      call r8_swap ( ar(i,j), ar(i,m) )
      call r8_swap ( ai(i,j), ai(i,m) )
    end do

    do i = k, n
      call r8_swap ( ar(j,i), ar(m,i) )
      call r8_swap ( ai(j,i), ai(m,i) )
    end do

  end if

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

  if ( l == 1 ) then
    go to 280
  end if

  l = l - 1

100 continue

  do jj = 1, l

     j = l + 1 - jj

     do i = 1, l
       if ( i /= j ) then
         if ( ar(j,i) /= 0.0D+00 .or. ai(j,i) /= 0.0D+00 ) then
           go to 120
         end if
       end if
     end do

     m = l
     iexc = 1
     go to 20

120  continue

  end do

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

  k = k + 1

140 continue

   do j = k, l

     do i = k, l
       if ( i /= j ) then
         if ( ar(i,j) /= 0.0D+00 .or. ai(i,j) /= 0.0D+00 ) then
           go to 170
         end if
       end if
     end do

     m = k
     iexc = 2
     go to 20

170  continue

  end do
!
!  Now balance the submatrix in rows k to l.
!
  scale(k:l) = 1.0D+00
!
!  Iterative loop for norm reduction.
!
190 continue

  noconv = .false.

  do i = k, l

    c = 0.0D+00
    r = 0.0D+00

    do j = k, l
      if ( j /= i ) then
        c = c + abs ( ar(j,i) ) + abs ( ai(j,i) )
        r = r + abs ( ar(i,j) ) + abs ( ai(i,j) )
      end if
    end do
!
!  Guard against zero C or R due to underflow.
!
     if ( c == 0.0D+00 .or. r == 0.0D+00 ) then
       go to 270
     end if

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

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

     g = r * radix

     do while  ( g <= c )
       f = f / radix
       c = c / b2
     end do
!
!  Now balance.
!
     if ( ( c + r ) / f < 0.95D+00 * s ) then

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

       ar(i,k:n) = ar(i,k:n) * g
       ai(i,k:n) = ai(i,k:n) * g

       ar(1:l,i) = ar(1:l,i) * f
       ai(1:l,i) = ai(1:l,i) * f

     end if

270  continue

  end do

  if ( noconv ) then
    go to 190
  end if

  280 continue

  low = k
  igh = l

  return
end subroutine cbal

subroutine cdiv ( ar, ai, br, bi, cr, ci )

!*****************************************************************************80
!
!! CDIV emulates complex division, using real arithmetic.
!
!  Discussion:
!
!    This routine performs complex division:
!
!      (CR,CI) = (AR,AI) / (BR,BI)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, real (dp) AR, AI, the real and imaginary parts of
!    the numerator.
!
!    Input, real (dp) BR, BI, the real and imaginary parts of
!    the denominator.
!
!    Output, real (dp) CR, CI, the real and imaginary parts of
!    the result.
!
  implicit none

  real (dp) ai
  real (dp) ais
  real (dp) ar
  real (dp) ars
  real (dp) bi
  real (dp) bis
  real (dp) br
  real (dp) brs
  real (dp) ci
  real (dp) cr
  real (dp) s

  s = abs ( br ) + abs ( bi )

  ars = ar / s
  ais = ai / s
  brs = br / s
  bis = bi / s

  s = brs**2 + bis**2
  cr = ( ars * brs + ais * bis ) / s
  ci = ( ais * brs - ars * bis ) / s

  return
end subroutine cdiv

subroutine cg ( n, ar, ai, wr, wi, matz, zr, zi, ierr )

!*****************************************************************************80
!
!! CG gets eigenvalues and eigenvectors of a complex general matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of EISPACK subroutines
!    to find the eigenvalues and eigenvectors (if desired)
!    of a complex general matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real and
!    imaginary parts of the complex matrix.  On output, AR and AI
!    have been overwritten by other information.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts
!    of the eigenvalues.
!
!    Input, integer ( i4 ) MATZ, is 0 if only eigenvalues are desired, and
!    nonzero if both eigenvalues and eigenvectors are to be computed.
!
!    Output, real (dp) ZR(N,N), ZI(N,N), the real and imaginary parts,
!    respectively, of the eigenvectors, if MATZ is not zero.
!
!    Output, integer ( i4 ) IERR, an error completion code described in 
!    the documentation for COMQR and COMQR2.  The normal completion code 
!    is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  real (dp) fv3(n)
  integer ( i4 ) ierr
  integer ( i4 ) is1
  integer ( i4 ) is2
  integer ( i4 ) matz
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) zi(n,n)
  real (dp) zr(n,n)

  call cbal ( n, ar, ai, is1, is2, fv1 )

  call corth ( n, is1, is2, ar, ai, fv2, fv3 )

  if ( matz == 0 ) then

    call comqr ( n, is1, is2, ar, ai, wr, wi, ierr )

    if ( ierr /= 0 ) then
      return
    end if

  else

    call comqr2 ( n, is1, is2, fv2, fv3, ar, ai, wr, wi, zr, zi, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CG - Fatal error!'
      write ( *, '(a)' ) '  Nonzero error return from COMQR2.'
      return
    end if

    call cbabk2 ( n, is1, is2, fv1, n, zr, zi )

  end if

  return
end subroutine cg

subroutine ch ( n, ar, ai, w, matz, zr, zi, ierr )

!*****************************************************************************80
!
!! CH gets eigenvalues and eigenvectors of a complex Hermitian matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of subroutines from the
!    EISPACK eigensystem package to find the eigenvalues and eigenvectors
!    of a complex hermitian matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real and
!    imaginary parts of the complex matrix.  On output, AR and AI
!    have been overwritten by other information.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Input, integer ( i4 ) MATZ, is 0 if only eigenvalues are desired, and
!    nonzero if both eigenvalues and eigenvectors are to be computed.
!
!    Output, real (dp) ZR(N,N), ZI(N,N), the real and imaginary parts,
!    respectively, of the eigenvectors, if MATZ is not zero.
!
!    Output, integer ( i4 ) IERR, an error completion code described in 
!    the documentation for TQLRAT and TQL2.  The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) fm1(2,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) zi(n,n)
  real (dp) zr(n,n)

  call htridi ( n, ar, ai, w, fv1, fv2, fm1 )

  if ( matz == 0 ) then

    call tqlrat ( n, w, fv2, ierr )

  else

    zr(1:n,1:n) = 0.0D+00

    do i = 1, n
      zr(i,i) = 1.0D+00
    end do

    call tql2 ( n, w, fv1, zr, ierr )

    if ( ierr /= 0 ) then
      return
    end if

    call htribk ( n, ar, ai, fm1, n, zr, zi )

  end if

  return
end subroutine ch

subroutine cinvit ( n, ar, ai, wr, wi, select, mm, m, zr, zi, ierr )

!*****************************************************************************80
!
!! CINVIT gets eigenvectors from eigenvalues, for a complex Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvectors of a complex upper
!    Hessenberg matrix corresponding to specified eigenvalues,
!    using inverse iteration.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) AR(N,N), AI(N,N), the real and imaginary parts of
!    the complex Hessenberg matrix.
!
!    Input/output, real (dp) WR(N), WI(N).  On input, the real and
!    imaginary parts of the eigenvalues of the matrix.  The eigenvalues must
!    be stored in a manner identical to that of subroutine COMLR, which
!    recognizes possible splitting of the matrix.  On output, WR may have been
!    altered since close eigenvalues are perturbed slightly in searching for
!    independent eigenvectors.
!
!    Input, logical SELECT(N), specifies the eigenvectors to be found.  The
!    eigenvector corresponding to the J-th eigenvalue is specified by
!    setting SELECT(J) to TRUE.
!
!    Input, integer ( i4 ) MM, an upper bound for the number of 
!    eigenvectors to be found.
!
!    Output, integer ( i4 ) M, the number of eigenvectors actually found.
!
!    Output, real (dp) ZR(N,MM), ZI(N,MM), the real and imaginary parts
!    of the eigenvectors.  The eigenvectors are normalized so that the
!    component of largest magnitude is 1.
!    Any vector which fails the acceptance test is set to zero.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    -(2*N+1), if more than MM eigenvectors have been specified,
!    -K, if the iteration corresponding to the K-th value fails,
!    -(N+K), if both error situations occur.
!
  implicit none

  integer ( i4 ) mm
  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) eps3
  real (dp) growto
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  real (dp) ilambd
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) km1
  integer ( i4 ) m
  integer ( i4 ) mp
  real (dp) norm
  real (dp) normv
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) rlambd
  real (dp) rm1(n,n)
  real (dp) rm2(n,n)
  real (dp) rv1(n)
  real (dp) rv2(n)
  integer ( i4 ) s
  logical select(n)
  integer ( i4 ) uk
  real (dp) ukroot
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) x
  real (dp) y
  real (dp) zi(n,mm)
  real (dp) zr(n,mm)

  ierr = 0
  uk = 0
  s = 1

  do k = 1, n

    if ( .not. select(k) ) then
      cycle
    end if

    if ( mm < s ) then
      go to 1000
    end if

    if ( k <= uk ) then
      go to 200
    end if
!
!  Check for possible splitting.
!
     do uk = k, n - 1

       if ( ar(uk+1,uk) == 0.0D+00 .and. ai(uk+1,uk) == 0.0D+00 ) then
         exit
       end if

     end do
!
!  Compute infinity norm of leading UK by UK (Hessenberg) matrix.
!
     norm = 0.0D+00
     mp = 1

     do i = 1, uk

       x = 0.0D+00
       do j = mp, uk
         x = x + pythag ( ar(i,j), ai(i,j) )
       end do

       norm = max ( norm, x )
       mp = i

     end do
!
!  EPS3 replaces zero pivot in decomposition
!  and close roots are modified by EPS3.
!
     if ( norm == 0.0D+00 ) then
       norm = 1.0D+00
     end if

     eps3 = abs ( norm ) * epsilon ( eps3 )
!
!  GROWTO is the criterion for growth.
!
     ukroot = uk
     ukroot = sqrt ( ukroot )
     growto = 0.1D+00 / ukroot

200  continue

     rlambd = wr(k)
     ilambd = wi(k)

     if ( k == 1 ) then
       go to 280
     end if

     km1 = k - 1
     go to 240
!
!  Perturb eigenvalue if it is close to any previous eigenvalue.
!
220  continue

     rlambd = rlambd + eps3

240  continue

     do ii = 1, km1
        i = k - ii
        if ( select(i) .and. abs ( wr(i)-rlambd) < eps3 .and. &
            abs ( wi(i)-ilambd) < eps3 ) then
          go to 220
        end if
     end do

     wr(k) = rlambd
!
!  Form upper Hessenberg (ar,ai)-(rlambd,ilambd) * I
!  and initial complex vector.
!
280  continue

     mp = 1

     do i = 1, uk

        do j = mp, uk
          rm1(i,j) = ar(i,j)
          rm2(i,j) = ai(i,j)
        end do

        rm1(i,i) = rm1(i,i) - rlambd
        rm2(i,i) = rm2(i,i) - ilambd
        mp = i
        rv1(i) = eps3

     end do
!
!  Triangular decomposition with interchanges, replacing zero pivots by eps3.
!
     do i = 2, uk

        mp = i - 1

        if ( pythag ( rm1(i,mp), rm2(i,mp) ) > &
             pythag ( rm1(mp,mp),rm2(mp,mp) ) ) then

          do j = mp, uk
            call r8_swap ( rm1(i,j), rm1(mp,j) )
            call r8_swap ( rm2(i,j), rm2(mp,j) )
          end do

        end if

        if ( rm1(mp,mp) == 0.0D+00 .and. rm2(mp,mp) == 0.0D+00 ) then
          rm1(mp,mp) = eps3
        end if

        call cdiv ( rm1(i,mp), rm2(i,mp), rm1(mp,mp), rm2(mp,mp), x, y )

        if ( x /= 0.0D+00 .or. y /= 0.0D+00 ) then

          do j = i, uk
            rm1(i,j) = rm1(i,j) - x * rm1(mp,j) + y * rm2(mp,j)
            rm2(i,j) = rm2(i,j) - x * rm2(mp,j) - y * rm1(mp,j)
          end do

        end if

     end do

     if ( rm1(uk,uk) == 0.0D+00 .and. rm2(uk,uk) == 0.0D+00 ) then
       rm1(uk,uk) = eps3
     end if

     its = 0
!
!  Back substitution.
!
  660   continue

    do ii = 1, uk

        i = uk + 1 - ii
        x = rv1(i)
        y = 0.0D+00

        do j = i + 1, uk
          x = x - rm1(i,j) * rv1(j) + rm2(i,j) * rv2(j)
          y = y - rm1(i,j) * rv2(j) - rm2(i,j) * rv1(j)
        end do

        call cdiv ( x, y, rm1(i,i), rm2(i,i), rv1(i), rv2(i) )

     end do
!
!  Acceptance test for eigenvector and normalization.
!
     its = its + 1
     norm = 0.0D+00
     normv = 0.0D+00

     do i = 1, uk
        x = pythag ( rv1(i), rv2(i) )
        if ( normv < x ) then
          normv = x
          j = i
        end if
        norm = norm + x
     end do

     if ( norm < growto ) then
       go to 840
     end if
!
!  Accept vector.
!
     x = rv1(j)
     y = rv2(j)

     do i = 1, uk
       call cdiv ( rv1(i), rv2(i), x, y, zr(i,s), zi(i,s) )
     end do

     if ( uk == n ) then
       go to 940
     end if

     j = uk + 1
     go to 900
!
!  Choose a new starting vector.
!
  840    continue

     if ( its < uk ) then

       x = ukroot
       y = eps3 / ( x + 1.0D+00 )

       rv1(1) = eps3
       rv1(2:uk) = y

       j = uk - its + 1
       rv1(j) = rv1(j) - eps3 * x
       go to 660

     end if
!
!  Error: unaccepted eigenvector.
!
  880    continue

     j = 1
     ierr = -k
!
!  Set remaining vector components to zero.
!
900    continue

       zr(j:n,s) = 0.0D+00
       zi(j:n,s) = 0.0D+00

940    continue

       s = s + 1

  end do

  go to 1001
!
!  Set error: underestimate of eigenvector space required.
!
 1000 continue

  if ( ierr /= 0 ) then
    ierr = ierr - n
  end if

  if ( ierr == 0 ) then
    ierr = - ( 2 * n + 1 )
  end if

 1001 continue
  m = s - 1
  return
end subroutine cinvit

subroutine combak ( n, low, igh, ar, ai, int, m, zr, zi )

!*****************************************************************************80
!
!! COMBAK determines eigenvectors by undoing the COMHES transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex general
!    matrix by back transforming those of the corresponding
!    upper Hessenberg matrix determined by COMHES.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = to the order
!    of the matrix.
!
!    Input, real (dp) AR(N,IGH), AI(N,IGH), the multipliers which
!    were used in the reduction by COMHES in their lower triangles below
!    the subdiagonal.
!
!    Input, integer ( i4 ) INT(IGH), information on the rows and
!    columns interchanged in the reduction by COMHES.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) ZR(N,M), ZI(N,M).  On input, the real
!    and imaginary parts of the eigenvectors to be back transformed.  On
!    output, the real and imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) ai(n,igh)
  real (dp) ar(n,igh)
  integer ( i4 ) i
  integer ( i4 ) int(igh)
  integer ( i4 ) j
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) mm
  integer ( i4 ) mp
  real (dp) xi
  real (dp) xr
  real (dp) zi(n,m)
  real (dp) zr(n,m)

  if ( m == 0 ) then
    return
  end if

  la = igh - 1

  if ( igh - 1 < low + 1 ) then
    return
  end if

  do mm = low + 1, la

     mp = low + igh - mm

     do i = mp + 1, igh

        xr = ar(i,mp-1)
        xi = ai(i,mp-1)

        if ( xr /= 0.0D+00 .or. xi /= 0.0D+00 ) then
          zr(i,1:m) = zr(i,1:m) + xr * zr(mp,1:m) - xi * zi(mp,1:m)
          zi(i,1:m) = zi(i,1:m) + xr * zi(mp,1:m) + xi * zr(mp,1:m)
       end if

     end do

     i = int(mp)

     if ( i /= mp ) then

       do j = 1, m
         call r8_swap ( zr(i,j), zr(mp,j) )
         call r8_swap ( zi(i,j), zi(mp,j) )
       end do

     end if

  end do

  return
end subroutine combak

subroutine comhes ( n, low, igh, ar, ai, int )

!*****************************************************************************80
!
!! COMHES transforms a complex general matrix to upper Hessenberg form.
!
!  Discussion:
!
!    Given a complex general matrix, this subroutine
!    reduces a submatrix situated in rows and columns
!    LOW through IGH to upper Hessenberg form by
!    stabilized elementary similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real and
!    imaginary parts of the complex input matrix.  On output, the real and
!    imaginary parts of the Hessenberg matrix.  The multipliers which were
!    used in the reduction are stored in the remaining triangles under the
!    Hessenberg matrix.
!
!    Output, integer ( i4 ) INT(IGH), information on the rows and columns
!    interchanged in the reduction.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  integer ( i4 ) i
  integer ( i4 ) int(igh)
  integer ( i4 ) j
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) m
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr

  la = igh - 1

  do m = low + 1, la

     xr = 0.0D+00
     xi = 0.0D+00
     i = m

     do j = m, igh

       if ( abs ( ar(j,m-1) ) + abs ( ai(j,m-1) ) > &
         abs ( xr ) + abs ( xi ) ) then
         xr = ar(j,m-1)
         xi = ai(j,m-1)
         i = j
       end if

     end do

     int(m) = i
!
!  Interchange rows and columns of AR and AI.
!
     if ( i /= m ) then

       do j = m - 1, n
         call r8_swap ( ar(i,j), ar(m,j) )
         call r8_swap ( ai(i,j), ai(m,j) )
       end do

       do j = 1, igh
         call r8_swap ( ar(j,i), ar(j,m) )
         call r8_swap ( ai(j,i), ai(j,m) )
       end do

     end if

    if ( xr /= 0.0D+00 .or. xi /= 0.0D+00 ) then

      do i = m + 1, igh

        yr = ar(i,m-1)
        yi = ai(i,m-1)

        if ( yr /= 0.0D+00 .or. yi /= 0.0D+00 ) then

          call cdiv ( yr, yi, xr, xi, yr, yi )
          ar(i,m-1) = yr
          ai(i,m-1) = yi

          do j = m, n
            ar(i,j) = ar(i,j) - yr * ar(m,j) + yi * ai(m,j)
            ai(i,j) = ai(i,j) - yr * ai(m,j) - yi * ar(m,j)
          end do

          ar(1:igh,m) = ar(1:igh,m) + yr * ar(1:igh,i) - yi * ai(1:igh,i)
          ai(1:igh,m) = ai(1:igh,m) + yr * ai(1:igh,i) + yi * ar(1:igh,i)

        end if

      end do

    end if

  end do

  return
end subroutine comhes

subroutine comlr ( n, low, igh, hr, hi, wr, wi, ierr )

!*****************************************************************************80
!
!! COMLR gets all eigenvalues of a complex upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a complex upper Hessenberg
!    matrix by the modified LR method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) HR(N,N), HI(N,N).  On input, the real and
!    imaginary parts of the complex upper Hessenberg matrix.  Their lower
!    triangles below the subdiagonal contain the multipliers which were used
!    in the reduction by COMHES if performed.  On output, the upper Hessenberg
!    portions of HR and HI have been destroyed.  Therefore, they must be
!    saved before calling COMLR if subsequent calculation of eigenvectors
!    is to be performed.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be correct
!    for indices IERR+1,...,N.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm1
  real (dp) hi(n,n)
  real (dp) hr(n,n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) igh
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) mm
  real (dp) si
  real (dp) sr
  real (dp) ti
  real (dp) tr
  real (dp) tst1
  real (dp) tst2
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr
  real (dp) zzi
  real (dp) zzr

  ierr = 0
!
!  Store roots isolated by CBAL.
!
  do i = 1, n
    if ( i < low .or. igh < i ) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0D+00
  ti = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
  220 continue

  if ( en < low ) then
    return
  end if

  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
  240 continue

  do ll = low, en

     l = en + low - ll

     if ( l == low ) then
       exit
     end if

     tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
       + abs ( hi(l,l) )
     tst2 = tst1 + abs ( hr(l,l-1) ) + abs ( hi(l,l-1) )

     if ( tst2 == tst1 ) then
       exit
     end if

  end do
!
!  Form shift.
!
300 continue

  if ( l == en ) then
    go to 660
  end if

  if ( itn == 0 ) then
    ierr = en
    return
  end if

  if ( its == 10 .or. its == 20 ) then
    go to 320
  end if

  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1) - hi(enm1,en) * hi(en,enm1)
  xi = hr(enm1,en) * hi(en,enm1) + hi(enm1,en) * hr(en,enm1)

  if ( xr == 0.0D+00 .and. xi == 0.0D+00 ) then
    go to 340
  end if

  yr = ( hr(enm1,enm1) - sr) / 2.0D+00
  yi = ( hi(enm1,enm1) - si) / 2.0D+00
  call csroot ( yr**2-yi**2+xr, 2.0D+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0D+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
  320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = abs ( hi(en,enm1) ) + abs ( hi(enm1,en-2) )

  340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Look for two consecutive small sub-diagonal elements.
!
  xr = abs ( hr(enm1,enm1) ) + abs ( hi(enm1,enm1) )
  yr = abs ( hr(en,enm1) ) + abs ( hi(en,enm1) )
  zzr = abs ( hr(en,en) ) + abs ( hi(en,en) )

  do mm = l, enm1
    m = enm1 + l - mm
    if ( m == l ) then
      exit
    end if
    yi = yr
    yr = abs ( hr(m,m-1) ) + abs ( hi(m,m-1) )
    xi = zzr
    zzr = xr
    xr = abs ( hr(m-1,m-1) ) + abs ( hi(m-1,m-1) )
    tst1 = zzr / yi * (zzr + xr + xi)
    tst2 = tst1 + yr
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Triangular decomposition H=L*R.
!
  do i = m + 1, en

     xr = hr(i-1,i-1)
     xi = hi(i-1,i-1)
     yr = hr(i,i-1)
     yi = hi(i,i-1)

     if ( abs ( xr ) + abs ( xi ) >= abs ( yr ) + abs ( yi ) ) then
       go to 460
     end if
!
!  Interchange rows of HR and HI.
!
     do j = i - 1, en
       call r8_swap ( hr(i-1,j), hr(i,j) )
       call r8_swap ( hi(i-1,j), hi(i,j) )
     end do

     call cdiv ( xr, xi, yr, yi, zzr, zzi )
     wr(i) = 1.0D+00
     go to 480

460 continue

     call cdiv ( yr, yi, xr, xi, zzr, zzi )
     wr(i) = -1.0D+00

480  continue

     hr(i,i-1) = zzr
     hi(i,i-1) = zzi

     do j = i, en
        hr(i,j) = hr(i,j) - zzr * hr(i-1,j) + zzi * hi(i-1,j)
        hi(i,j) = hi(i,j) - zzr * hi(i-1,j) - zzi * hr(i-1,j)
     end do

  end do
!
!  Composition R*L=H.
!
  do j = m + 1, en

    xr = hr(j,j-1)
    xi = hi(j,j-1)
    hr(j,j-1) = 0.0D+00
    hi(j,j-1) = 0.0D+00
!
!  Interchange columns of HR and HI, if necessary.
!
    if ( 0.0D+00 < wr(j) ) then

      do i = l, j
        call r8_swap ( hr(i,j-1), hr(i,j) )
        call r8_swap ( hi(i,j-1), hi(i,j) )
      end do

    end if

    do i = l, j
      hr(i,j-1) = hr(i,j-1) + xr * hr(i,j) - xi * hi(i,j)
      hi(i,j-1) = hi(i,j-1) + xr * hi(i,j) + xi * hr(i,j)
    end do

  end do

  go to 240
!
!  A root found.
!
  660 continue

  wr(en) = hr(en,en) + tr
  wi(en) = hi(en,en) + ti
  en = enm1
  go to 220
end subroutine comlr

subroutine comlr2 ( n, low, igh, int, hr, hi, wr, wi, zr, zi, ierr )

!*****************************************************************************80
!
!! COMLR2 gets eigenvalues/vectors of a complex upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors of a complex
!    upper Hessenberg matrix by the modified LR method.  The eigenvectors
!    of a complex general matrix can also be found if COMHES has been used
!    to reduce this general matrix to Hessenberg form.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input, integer ( i4 ) INT(IGH), information on the rows and columns
!    interchanged in the reduction by COMHES, if performed.  If the
!    eigenvectors of the Hessenberg matrix are desired, set INT(J)=J for these
!    elements.
!
!    Input/output, real (dp) HR(N,N), HI(N,N).  On input, the real
!    and imaginary parts of the complex upper Hessenberg matrix.  Their lower
!    triangles below the subdiagonal contain the multipliers which were used in
!    the reduction by COMHES, if performed.  If the eigenvectors of the
!    Hessenberg matrix are desired, these elements must be set to zero.  On
!    output, the upper Hessenberg portions of HR and HI have been destroyed,
!    but the location HR(1,1) contains the norm of the triangularized matrix.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be
!    correct for indices IERR+1,...,N.
!
!    Output, real (dp) ZR(N,N), ZI(N,N), the real and imaginary parts
!    of the eigenvectors.  The eigenvectors are unnormalized.  If an error exit
!    is made, none of the eigenvectors has been found.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm1
  real (dp) hi(n,n)
  real (dp) hr(n,n)
  integer ( i4 ) i
  integer ( i4 ) iend
  integer ( i4 ) ierr
  integer ( i4 ) igh
  integer ( i4 ) ii
  integer ( i4 ) int(igh)
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) mm
  integer ( i4 ) nn
  real (dp) norm
  real (dp) si
  real (dp) sr
  real (dp) ti
  real (dp) tr
  real (dp) tst1
  real (dp) tst2
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr
  real (dp) zi(n,n)
  real (dp) zr(n,n)
  real (dp) zzi
  real (dp) zzr

  ierr = 0
!
!  Initialize the eigenvector matrix.
!
  zr(1:n,1:n) = 0.0D+00

  do i = 1, n
    zr(i,i) = 1.0D+00
  end do

  zi(1:n,1:n) = 0.0D+00
!
!  Form the matrix of accumulated transformations from the information left
!  by COMHES.
!
  iend = igh - low - 1

  do ii = 1, iend

    i = igh - ii

    do k = i + 1, igh
      zr(k,i) = hr(k,i-1)
      zi(k,i) = hi(k,i-1)
    end do

    j = int(i)

    if ( i /= j ) then

      do k = i, igh
        zr(i,k) = zr(j,k)
        zi(i,k) = zi(j,k)
        zr(j,k) = 0.0D+00
        zi(j,k) = 0.0D+00
      end do

      zr(j,i) = 1.0D+00

    end if

  end do
!
!  Store roots isolated by CBAL.
!
  do i = 1, n
    if ( i < low .or. igh < i ) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0D+00
  ti = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
220 continue

  if ( en < low ) then
    go to 680
  end if

  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
  240 continue

  do ll = low, en

     l = en + low - ll

     if ( l == low ) then
       exit
     end if

     tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
       + abs ( hi(l,l) )
     tst2 = tst1 + abs ( hr(l,l-1) ) + abs ( hi(l,l-1) )

     if ( tst2 == tst1 ) then
       exit
     end if

  end do
!
!  Form shift.
!
  if ( l == en ) then
    go to 660
  end if

  if ( itn == 0 ) then
    ierr = en
    return
  end if

  if ( its == 10 .or. its == 20 ) then
    go to 320
  end if

  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1) - hi(enm1,en) * hi(en,enm1)
  xi = hr(enm1,en) * hi(en,enm1) + hi(enm1,en) * hr(en,enm1)

  if ( xr == 0.0D+00 .and. xi == 0.0D+00 ) then
    go to 340
  end if

  yr = (hr(enm1,enm1) - sr) / 2.0D+00
  yi = (hi(enm1,enm1) - si) / 2.0D+00
  call csroot ( yr**2-yi**2+xr, 2.0D+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0D+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
  320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = abs ( hi(en,enm1) ) + abs ( hi(enm1,en-2) )

  340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Look for two consecutive small sub-diagonal elements.
!
  xr = abs ( hr(enm1,enm1) ) + abs ( hi(enm1,enm1) )
  yr = abs ( hr(en,enm1) ) + abs ( hi(en,enm1) )
  zzr = abs ( hr(en,en) ) + abs ( hi(en,en) )

  do mm = l, enm1
     m = enm1 + l - mm
     if ( m == l ) then
       exit
     end if
     yi = yr
     yr = abs ( hr(m,m-1) ) + abs ( hi(m,m-1) )
     xi = zzr
     zzr = xr
     xr = abs ( hr(m-1,m-1) ) + abs ( hi(m-1,m-1) )
     tst1 = zzr / yi * (zzr + xr + xi)
     tst2 = tst1 + yr
     if ( tst2 == tst1 ) then
       exit
     end if
  end do
!
!  Triangular decomposition H=L*R.
!
  do i = m + 1, en

     xr = hr(i-1,i-1)
     xi = hi(i-1,i-1)
     yr = hr(i,i-1)
     yi = hi(i,i-1)
!
!  Interchange rows of HR and HI.
!
     if ( abs ( xr ) + abs ( xi) < abs ( yr ) + abs ( yi ) ) then

       do j = i - 1, n
         call r8_swap ( hr(i-1,j), hr(i,j) )
         call r8_swap ( hi(i-1,j), hi(i,j) )
       end do

       call cdiv ( xr, xi, yr, yi, zzr, zzi )
       wr(i) = 1.0D+00

     else

       call cdiv ( yr, yi, xr, xi, zzr, zzi )
       wr(i) = -1.0D+00

     end if

     hr(i,i-1) = zzr
     hi(i,i-1) = zzi

     do j = i, n
       hr(i,j) = hr(i,j) - zzr * hr(i-1,j) + zzi * hi(i-1,j)
       hi(i,j) = hi(i,j) - zzr * hi(i-1,j) - zzi * hr(i-1,j)
     end do

  end do
!
!  Composition R*L=H.
!
  do j = m + 1, en

     xr = hr(j,j-1)
     xi = hi(j,j-1)
     hr(j,j-1) = 0.0D+00
     hi(j,j-1) = 0.0D+00
!
!  Interchange columns of HR, HI, ZR, and ZI.
!
     if ( 0.0D+00 < wr(j) ) then

       do i = 1, j
         call r8_swap ( hr(i,j-1), hr(i,j) )
         call r8_swap ( hi(i,j-1), hi(i,j) )
       end do

       do i = low, igh
         call r8_swap ( zr(i,j-1), zr(i,j) )
         call r8_swap ( zi(i,j-1), zi(i,j) )
       end do

    end if

    do i = 1, j
      hr(i,j-1) = hr(i,j-1) + xr * hr(i,j) - xi * hi(i,j)
      hi(i,j-1) = hi(i,j-1) + xr * hi(i,j) + xi * hr(i,j)
    end do
!
!  Accumulate transformations.
!
    do i = low, igh
      zr(i,j-1) = zr(i,j-1) + xr * zr(i,j) - xi * zi(i,j)
      zi(i,j-1) = zi(i,j-1) + xr * zi(i,j) + xi * zr(i,j)
    end do

  end do

  go to 240
!
!  A root found.
!
  660 continue

  hr(en,en) = hr(en,en) + tr
  wr(en) = hr(en,en)
  hi(en,en) = hi(en,en) + ti
  wi(en) = hi(en,en)
  en = enm1
  go to 220
!
!  All roots found.
!  Backsubstitute to find vectors of upper triangular form.
!
  680 continue

  norm = 0.0D+00

  do i = 1, n
    do j = i, n
      tr = abs ( hr(i,j) ) + abs ( hi(i,j) )
      norm = max ( norm, tr )
    end do
  end do

  hr(1,1) = norm
  if ( n == 1 ) then
    return
  end if

  if ( norm == 0.0D+00 ) then
    return
  end if

  do nn = 2, n

     en = n + 2 - nn
     xr = wr(en)
     xi = wi(en)
     hr(en,en) = 1.0D+00
     hi(en,en) = 0.0D+00
     enm1 = en - 1

     do ii = 1, enm1

        i = en - ii
        zzr = 0.0D+00
        zzi = 0.0D+00

        do j = i + 1, en
          zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
          zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
        end do

        yr = xr - wr(i)
        yi = xi - wi(i)

        if ( yr == 0.0D+00 .and. yi == 0.0D+00 ) then

          tst1 = norm
          yr = tst1

          do
            yr = 0.01D+00 * yr
            tst2 = norm + yr
            if ( tst2 <=  tst1 ) then
              exit
            end if
          end do

        end if

        call cdiv ( zzr, zzi, yr, yi, hr(i,en), hi(i,en) )
!
!  Overflow control.
!
        tr = abs ( hr(i,en) ) + abs ( hi(i,en) )

        if ( tr /= 0.0D+00 ) then

          tst1 = tr
          tst2 = tst1 + 1.0D+00 / tst1

          if ( tst2 <= tst1 ) then

            hr(i:en,en) = hr(i:en,en) / tr
            hi(i:en,en) = hi(i:en,en) / tr

          end if

        end if

      end do

  end do
!
!  End backsubstitution.
!
  enm1 = n - 1
!
!  Vectors of isolated roots.
!
  do i = 1, n - 1

    if ( i < low .or. igh < i ) then

      zr(i,i+1:n) = hr(i,i+1:n)
      zi(i,i+1:n) = hi(i,i+1:n)

    end if

  end do
!
!  Multiply by transformation matrix to give vectors of original full matrix.
!
  do jj = low, n - 1

    j = n + low - jj
    m = min ( j, igh )

    do i = low, igh
      zzr = 0.0D+00
      zzi = 0.0D+00
      do k = low, m
        zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
        zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
      end do
      zr(i,j) = zzr
      zi(i,j) = zzi
    end do

  end do

  return
end subroutine comlr2

subroutine comqr ( n, low, igh, hr, hi, wr, wi, ierr )

!*****************************************************************************80
!
!! COMQR gets eigenvalues of a complex upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a complex
!    upper Hessenberg matrix by the QR method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) HR(N,N), HI(N,N).  On input, the real
!    and imaginary parts of the complex upper Hessenberg matrix.  Their lower
!    triangles below the subdiagonal contain information about the unitary
!    transformations used in the reduction by CORTH, if performed.  On output,
!    the upper Hessenberg portions of HR and HI have been destroyed.
!    Therefore, they must be saved before calling COMQR if subsequent
!    calculation of eigenvectors is to be performed.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be
!    correct for indices IERR+1,...,N.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!       eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm1
  real (dp) hi(n,n)
  real (dp) hr(n,n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) igh
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  real (dp) norm
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) si
  real (dp) sr
  real (dp) ti
  real (dp) tr
  real (dp) tst1
  real (dp) tst2
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr
  real (dp) zzi
  real (dp) zzr

  ierr = 0
!
!  Create real subdiagonal elements.
!
  l = low + 1

  do i = l, igh

     ll = min ( i + 1, igh )

     if ( hi(i,i-1) /= 0.0D+00 ) then

     norm = pythag ( hr(i,i-1), hi(i,i-1) )
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0D+00

     do j = i, igh
       si = yr * hi(i,j) - yi * hr(i,j)
       hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
       hi(i,j) = si
     end do

     do j = low, ll
       si = yr * hi(j,i) + yi * hr(j,i)
       hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
       hi(j,i) = si
     end do

    end if

  end do
!
!  Store roots isolated by CBAL.
!
  do i = 1, n
    if ( i < low .or. igh < i ) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0D+00
  ti = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
  220 continue

  if ( en < low ) then
    return
  end if

  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
  240 continue

  do ll = low, en
    l = en + low - ll
    if ( l == low ) then
      exit
    end if
    tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
      + abs ( hi(l,l) )
    tst2 = tst1 + abs ( hr(l,l-1) )
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Form shift.
!
  if ( l == en ) then
    go to 660
  end if

  if ( itn == 0 ) then
    go to 1000
  end if

  if ( its == 10 .or. its == 20 ) then
    go to 320
  end if

  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if ( xr == 0.0D+00 .and. xi == 0.0D+00 ) then
    go to 340
  end if

  yr = (hr(enm1,enm1) - sr) / 2.0D+00
  yi = (hi(enm1,enm1) - si) / 2.0D+00

  call csroot ( yr**2-yi**2+xr, 2.0D+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0D+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = 0.0D+00

340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Reduce to triangle (rows).
!
  do i = l + 1, en

     sr = hr(i,i-1)
     hr(i,i-1) = 0.0D+00
     norm = pythag ( pythag ( hr(i-1,i-1), hi(i-1,i-1) ), sr )
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0D+00
     hi(i,i-1) = sr / norm

     do j = i, en
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
    end do

  end do

  si = hi(en,en)

  if ( si /= 0.0D+00 ) then
    norm = pythag ( hr(en,en), si )
    sr = hr(en,en) / norm
    si = si / norm
    hr(en,en) = norm
    hi(en,en) = 0.0D+00
  end if
!
!  Inverse operation (columns).
!
  do j = l + 1, en

     xr = wr(j-1)
     xi = wi(j-1)

     do i = l, j

        yr = hr(i,j-1)
        yi = 0.0D+00
        zzr = hr(i,j)
        zzi = hi(i,j)
        if ( i /= j ) then
          yi = hi(i,j-1)
          hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
        end if
        hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
        hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
        hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi

     end do

  end do

  if ( si /= 0.0D+00 ) then

    do i = l, en
      yr = hr(i,en)
      yi = hi(i,en)
      hr(i,en) = sr * yr - si * yi
      hi(i,en) = sr * yi + si * yr
    end do

  end if

  go to 240
!
!  A root found.
!
660 continue

  wr(en) = hr(en,en) + tr
  wi(en) = hi(en,en) + ti
  en = enm1
  go to 220
!
!  Set error: all eigenvalues have not converged after 30*n iterations.
!
1000 continue

  ierr = en
  return
end subroutine comqr

subroutine comqr2 ( n, low, igh, ortr, orti, hr, hi, wr, wi, zr, zi, ierr )

!*****************************************************************************80
!
!! COMQR2 gets eigenvalues/vectors of a complex upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors
!    of a complex upper Hessenberg matrix by the QR
!    method.  The eigenvectors of a complex general matrix
!    can also be found if CORTH has been used to reduce
!    this general matrix to Hessenberg form.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) ORTR(N), ORTI(N).  On input, information 
!    about the unitary transformations used in the reduction by CORTH, if 
!    performed.  If the eigenvectors of the Hessenberg matrix are desired, set 
!    ORTR(J) and ORTI(J) to 0.0D+00 for these elements.  On output, these arrays
!    have been overwritten.
!
!    Input/output, real (dp) HR(N,N), HI(N,N).  On input, the real and 
!    imaginary parts of the complex upper Hessenberg matrix.  Their lower 
!    triangles below the subdiagonal contain further information about the
!    transformations which were used in the reduction by CORTH, if performed.
!    If the eigenvectors of the Hessenberg matrix are desired, these elements
!    may be arbitrary.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  If an error exit is made, the eigenvalues should be
!    correct for indices IERR+1,...,N.
!
!    Output, real (dp) ZR(N,N), ZI(N,N), the real and imaginary parts of
!    the eigenvectors.  The eigenvectors are unnormalized.  If an error exit
!    is made, none of the eigenvectors has been found.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm1
  real (dp) hi(n,n)
  real (dp) hr(n,n)
  integer ( i4 ) i
  integer ( i4 ) iend
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) nn
  real (dp) norm
  real (dp) orti(igh)
  real (dp) ortr(igh)
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) si
  real (dp) sr
  real (dp) ti
  real (dp) tr
  real (dp) tst1
  real (dp) tst2
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr
  real (dp) zi(n,n)
  real (dp) zr(n,n)
  real (dp) zzi
  real (dp) zzr

  ierr = 0
!
!  Initialize eigenvector matrix.
!
  zr(1:n,1:n) = 0.0D+00

  do i = 1, n
    zr(i,i) = 1.0D+00
  end do

  zi(1:n,1:n) = 0.0D+00
!
!  Form the matrix of accumulated transformations from the information
!  left by CORTH.
!
  iend = igh - low - 1
!  if ( iend ) 180, 150, 105
! Replaced arithemtif if with if, else if, else structure
  if ( iend.LT.0 ) then
    GOTO 180
  else if (iend.EQ.0) then
    GOTO 150
  else 
    GOTO 105
  end if

105 continue

  do ii = 1, iend

     i = igh - ii

     if ( ortr(i) == 0.0D+00 .and. orti(i) == 0.0D+00 ) then
       go to 140
     end if

     if ( hr(i,i-1) == 0.0D+00 .and. hi(i,i-1) == 0.0D+00 ) then
       go to 140
     end if
!
!  Norm below is negative of H formed in CORTH.
!
     norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)

     do k = i + 1, igh
       ortr(k) = hr(k,i-1)
       orti(k) = hi(k,i-1)
     end do

     do j = i, igh

        sr = 0.0D+00
        si = 0.0D+00

        do k = i, igh
          sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
          si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
        end do

        sr = sr / norm
        si = si / norm

        do k = i, igh
          zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
          zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
        end do

      end do

140 continue

  end do
!
!  Create real subdiagonal elements.
!
150 continue

  l = low + 1

  do i = l, igh

     ll = min ( i + 1, igh )

     if ( hi(i,i-1) == 0.0D+00 ) then
       cycle
     end if

     norm = pythag ( hr(i,i-1), hi(i,i-1) )
     yr = hr(i,i-1) / norm
     yi = hi(i,i-1) / norm
     hr(i,i-1) = norm
     hi(i,i-1) = 0.0D+00

     do j = i, n
       si = yr * hi(i,j) - yi * hr(i,j)
       hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
       hi(i,j) = si
     end do

     do j = 1, ll
       si = yr * hi(j,i) + yi * hr(j,i)
       hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
       hi(j,i) = si
     end do

     do j = low, igh
       si = yr * zi(j,i) + yi * zr(j,i)
       zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
       zi(j,i) = si
     end do

  end do
!
!  Store roots isolated by CBAL.
!
180 continue

  do i = 1, n
    if ( i < low .or. igh < i ) then
      wr(i) = hr(i,i)
      wi(i) = hi(i,i)
    end if
  end do

  en = igh
  tr = 0.0D+00
  ti = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalue.
!
220 continue

  if ( en < low ) then
    go to 680
  end if

  its = 0
  enm1 = en - 1
!
!  Look for single small sub-diagonal element.
!
240 continue

  do ll = low, en
    l = en + low - ll
    if ( l == low ) then
      exit
    end if
    tst1 = abs ( hr(l-1,l-1) ) + abs ( hi(l-1,l-1) ) + abs ( hr(l,l) ) &
      + abs ( hi(l,l) )
    tst2 = tst1 + abs ( hr(l,l-1) )
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Form shift.
!
  if ( l == en ) then
    go to 660
  end if

  if ( itn == 0 ) then
    go to 1000
  end if

  if ( its == 10 .or. its == 20 ) then
    go to 320
  end if

  sr = hr(en,en)
  si = hi(en,en)
  xr = hr(enm1,en) * hr(en,enm1)
  xi = hi(enm1,en) * hr(en,enm1)
  if ( xr == 0.0D+00 .and. xi == 0.0D+00 ) then
    go to 340
  end if

  yr = ( hr(enm1,enm1) - sr ) / 2.0D+00
  yi = ( hi(enm1,enm1) - si ) / 2.0D+00

  call csroot ( yr**2-yi**2+xr, 2.0D+00*yr*yi+xi, zzr, zzi )

  if ( yr * zzr + yi * zzi < 0.0D+00 ) then
    zzr = -zzr
    zzi = -zzi
  end if

  call cdiv ( xr, xi, yr+zzr, yi+zzi, xr, xi )
  sr = sr - xr
  si = si - xi
  go to 340
!
!  Form exceptional shift.
!
320 continue

  sr = abs ( hr(en,enm1) ) + abs ( hr(enm1,en-2) )
  si = 0.0D+00

340 continue

  do i = low, en
    hr(i,i) = hr(i,i) - sr
    hi(i,i) = hi(i,i) - si
  end do

  tr = tr + sr
  ti = ti + si
  its = its + 1
  itn = itn - 1
!
!  Reduce to triangle (rows).
!
  do i = l + 1, en

     sr = hr(i,i-1)
     hr(i,i-1) = 0.0D+00
     norm = pythag ( pythag ( hr(i-1,i-1), hi(i-1,i-1) ), sr )
     xr = hr(i-1,i-1) / norm
     wr(i-1) = xr
     xi = hi(i-1,i-1) / norm
     wi(i-1) = xi
     hr(i-1,i-1) = norm
     hi(i-1,i-1) = 0.0D+00
     hi(i,i-1) = sr / norm

     do j = i, n
        yr = hr(i-1,j)
        yi = hi(i-1,j)
        zzr = hr(i,j)
        zzi = hi(i,j)
        hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
        hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
        hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
        hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
     end do

  end do

  si = hi(en,en)

  if ( si /= 0.0D+00 ) then

    norm = pythag ( hr(en,en), si )
    sr = hr(en,en) / norm
    si = si / norm
    hr(en,en) = norm
    hi(en,en) = 0.0D+00

    do j = en + 1, n
      yr = hr(en,j)
      yi = hi(en,j)
      hr(en,j) = sr * yr + si * yi
      hi(en,j) = sr * yi - si * yr
    end do

  end if
!
!  Inverse operation (columns).
!
  do j = l + 1, en

     xr = wr(j-1)
     xi = wi(j-1)

     do i = 1, j

       yr = hr(i,j-1)
       yi = 0.0D+00
       zzr = hr(i,j)
       zzi = hi(i,j)

       if ( i /= j ) then
         yi = hi(i,j-1)
         hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
       end if

       hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
       hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
       hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi

     end do

     do i = low, igh
       yr = zr(i,j-1)
       yi = zi(i,j-1)
       zzr = zr(i,j)
       zzi = zi(i,j)
       zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
       zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
       zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
       zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
     end do

  end do

  if ( si /= 0.0D+00 ) then

    do i = 1, en
      yr = hr(i,en)
      yi = hi(i,en)
      hr(i,en) = sr * yr - si * yi
      hi(i,en) = sr * yi + si * yr
    end do

    do i = low, igh
      yr = zr(i,en)
      yi = zi(i,en)
      zr(i,en) = sr * yr - si * yi
      zi(i,en) = sr * yi + si * yr
    end do

  end if

  go to 240
!
!  A root found.
!
660 continue

  hr(en,en) = hr(en,en) + tr
  wr(en) = hr(en,en)
  hi(en,en) = hi(en,en) + ti
  wi(en) = hi(en,en)
  en = enm1
  go to 220
!
!  All roots found.
!  Backsubstitute to find vectors of upper triangular form.
!
680 continue

  norm = 0.0D+00

  do i = 1, n
    do j = i, n
      tr = abs ( hr(i,j) ) + abs ( hi(i,j) )
      norm = max ( norm, tr )
    end do
  end do

  if ( n == 1 ) then
    return
  end if

  if ( norm == 0.0D+00 ) then
    return
  end if

  do nn = 2, n

     en = n + 2 - nn
     xr = wr(en)
     xi = wi(en)
     hr(en,en) = 1.0D+00
     hi(en,en) = 0.0D+00
     enm1 = en - 1

     do ii = 1, enm1

        i = en - ii
        zzr = 0.0D+00
        zzi = 0.0D+00

        do j = i + 1, en
          zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
          zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
        end do

        yr = xr - wr(i)
        yi = xi - wi(i)

        if ( yr == 0.0D+00 .and. yi == 0.0D+00 ) then

           tst1 = norm
           yr = tst1
           do
             yr = 0.01D+00 * yr
             tst2 = norm + yr
             if ( tst2 <= tst1 ) then
               exit
             end if
           end do

        end if

        call cdiv ( zzr, zzi, yr, yi, hr(i,en), hi(i,en) )
!
!  Overflow control.
!
        tr = abs ( hr(i,en) ) + abs ( hi(i,en) )

        if ( tr /= 0.0D+00 ) then

          tst1 = tr
          tst2 = tst1 + 1.0D+00 / tst1

          if ( tst2 <= tst1 ) then

            do j = i, en
              hr(j,en) = hr(j,en)/tr
              hi(j,en) = hi(j,en)/tr
            end do

          end if

       end if

     end do

  end do
!
!  End backsubstitution.
!
  enm1 = n - 1
!
!  Vectors of isolated roots.
!
  do i = 1, n - 1

    if ( i < low .or. igh < i ) then

      do j = i + 1, n
        zr(i,j) = hr(i,j)
        zi(i,j) = hi(i,j)
      end do

    end if

  end do
!
!  Multiply by transformation matrix to give vectors of original full matrix.
!
  do jj = low, n - 1

     j = n + low - jj
     m = min ( j, igh )

     do i = low, igh

        zzr = 0.0D+00
        zzi = 0.0D+00
        do k = low, m
          zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
          zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
        end do

        zr(i,j) = zzr
        zi(i,j) = zzi

      end do

  end do

  return
!
!  Set error: all eigenvalues have not converged after 30*n iterations.
!
1000 continue

  ierr = en
  return
end subroutine comqr2

subroutine cortb ( n, low, igh, ar, ai, ortr, orti, m, zr, zi )

!*****************************************************************************80
!
!! CORTB determines eigenvectors by undoing the CORTH transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex general
!    matrix by back transforming those of the corresponding
!    upper Hessenberg matrix determined by CORTH.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH to the order
!    of the matrix.
!
!    Input, real (dp) AR(N,IGH), AI(N,IGH), information about the 
!    unitary transformations used in the reduction by CORTH in their strict 
!    lower triangles.
!
!    Input/output, real (dp) ORTR(IGH), ORTI(IGH).  On input, further 
!    information about the transformations used in the reduction by CORTH.  On 
!    output, ORTR and ORTI have been further altered.
!
!    Input, integer ( i4 ) M, the number of columns of ZR and ZI to be 
!    back transformed.
!
!    Input/output, real (dp) ZR(N,M), ZI(N,M).  On input, the real and 
!    imaginary parts of the eigenvectors to be back transformed.  On output, 
!    the real and imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) ai(n,igh)
  real (dp) ar(n,igh)
  real (dp) gi
  real (dp) gr
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) mm
  integer ( i4 ) mp
  real (dp) orti(igh)
  real (dp) ortr(igh)
  real (dp) zi(n,m)
  real (dp) zr(n,m)

  if ( m == 0 ) then
    return
  end if

  la = igh - 1

  if ( igh - 1 < low + 1 ) then
    return
  end if

  do mm = low + 1, la

    mp = low + igh - mm

    if ( ar(mp,mp-1) /= 0.0D+00 .or. ai(mp,mp-1) /= 0.0D+00 ) then

      h = ar(mp,mp-1) * ortr(mp) + ai(mp,mp-1) * orti(mp)

      ortr(mp+1:igh) = ar(mp+1:igh,mp-1)
      orti(mp+1:igh) = ai(mp+1:igh,mp-1)

      do j = 1, m

        gr = ( dot_product ( ortr(mp:igh), zr(mp:igh,j) ) &
             + dot_product ( orti(mp:igh), zi(mp:igh,j) ) ) / h

        gi = ( dot_product ( ortr(mp:igh), zi(mp:igh,j) ) &
             - dot_product ( orti(mp:igh), zr(mp:igh,j) ) ) / h

        do i = mp, igh
          zr(i,j) = zr(i,j) + gr * ortr(i) - gi * orti(i)
          zi(i,j) = zi(i,j) + gr * orti(i) + gi * ortr(i)
        end do

      end do

    end if

  end do

  return
end subroutine cortb

subroutine corth ( n, low, igh, ar, ai, ortr, orti )

!*****************************************************************************80
!
!! CORTH transforms a complex general matrix to upper Hessenberg form.
!
!  Discussion:
!
!    Given a complex general matrix, this subroutine
!    reduces a submatrix situated in rows and columns
!    LOW through IGH to upper Hessenberg form by
!    unitary similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine CBAL.  If CBAL is not used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real and
!    imaginary parts of the complex input matrix.  On output, the real and 
!    imaginary parts of the Hessenberg matrix.  Information about the unitary
!    transformations used in the reduction is stored in the remaining
!    triangles under the Hessenberg matrix.
!
!    Output, real (dp) ORTR(IGH), ORTI(IGH), further information about 
!    the transformations.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) f
  real (dp) fi
  real (dp) fr
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) la
  integer ( i4 ) m,mp,low
  real (dp) orti(igh)
  real (dp) ortr(igh)
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) scale

  la = igh - 1

  if ( igh - 1 < low + 1 ) then
    return
  end if

  do m = low + 1, la

    h = 0.0D+00
    ortr(m) = 0.0D+00
    orti(m) = 0.0D+00
    scale = 0.0D+00
!
!  Scale column.
!
    do i = m, igh
      scale = scale + abs ( ar(i,m-1) ) + abs ( ai(i,m-1) )
    end do

    if ( scale == 0.0D+00 ) then
      cycle
    end if

    mp = m + igh

    do ii = m, igh
      i = mp - ii
      ortr(i) = ar(i,m-1) / scale
      orti(i) = ai(i,m-1) / scale
      h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
    end do

    g = sqrt ( h )
    f = pythag ( ortr(m), orti(m) )

    if ( f /= 0.0D+00 ) then
      h = h + f * g
      g = g / f
      ortr(m) = ( 1.0D+00 + g ) * ortr(m)
      orti(m) = ( 1.0D+00 + g ) * orti(m)
    else
      ortr(m) = g
      ar(m,m-1) = scale
    end if
!
!  Form (I-(U*Ut)/h) * A.
!
    do j = m, n

      fr = 0.0D+00
      fi = 0.0D+00

      do ii = m, igh
        i = mp - ii
        fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
        fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
      end do

      fr = fr / h
      fi = fi / h

      ar(m:igh,j) = ar(m:igh,j) - fr * ortr(m:igh) + fi * orti(m:igh)
      ai(m:igh,j) = ai(m:igh,j) - fr * orti(m:igh) - fi * ortr(m:igh)

    end do
!
!  Form (I-(U*Ut)/h) * A * (I-(U*Ut)/h)
!
    do i = 1, igh

      fr = 0.0D+00
      fi = 0.0D+00

      do jj = m, igh
        j = mp - jj
        fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
        fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
      end do

      fr = fr / h
      fi = fi / h

      ar(i,m:igh) = ar(i,m:igh) - fr * ortr(m:igh) - fi * orti(m:igh)
      ai(i,m:igh) = ai(i,m:igh) + fr * orti(m:igh) - fi * ortr(m:igh)

    end do

    ortr(m) = scale * ortr(m)
    orti(m) = scale * orti(m)
    ar(m,m-1) = - g * ar(m,m-1)
    ai(m,m-1) = - g * ai(m,m-1)

  end do

  return
end subroutine corth 

subroutine csroot ( xr, xi, yr, yi )

!*****************************************************************************80
!
!! CSROOT computes the complex square root of a complex quantity.
!
!  Discussion:
!
!    The branch of the square function is chosen so that
!      0.0D+00 <= YR
!    and
!      sign ( YI ) == sign ( XI )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, real (dp) XR, XI, the real and imaginary parts of the 
!    quantity whose square root is desired.
!
!    Output, real (dp) YR, YI, the real and imaginary parts of the 
!    square root.
!
  implicit none

  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) s
  real (dp) ti
  real (dp) tr
  real (dp) xi
  real (dp) xr
  real (dp) yi
  real (dp) yr

  tr = xr
  ti = xi
  s = sqrt ( 0.5D+00 * ( pythag ( tr, ti ) + abs ( tr ) ) )

  if ( 0.0D+00 <= tr ) then
    yr = s
  end if

  if ( ti < 0.0D+00 ) then
    s = -s
  end if

  if ( tr <= 0.0D+00 ) then
    yi = s
  end if

  if ( tr < 0.0D+00 ) then
    yr = 0.5D+00 * ( ti / yi )
  else if ( 0.0D+00 < tr ) then
    yi = 0.5D+00 * ( ti / yr )
  end if

  return
end subroutine csroot
 
subroutine elmbak ( n, low, igh, a, ind, m, z )

!*****************************************************************************80
!
!! ELMBAK determines eigenvectors by undoing the ELMHES transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a real general
!    matrix by back transforming those of the corresponding
!    upper Hessenberg matrix determined by ELMHES.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, integers determined by the balancing
!    routine BALANC.  If BALANC has not been used, set LOW = 1 and
!    IGH equal to the order of the matrix.
!
!    Input, real (dp) A(N,IGH), the multipliers which were used in the
!    reduction by ELMHES in its lower triangle below the subdiagonal.
!
!    Input, integer ( i4 ) IND(IGH), information on the rows and columns
!    interchanged in the reduction by ELMHES.
!
!    Input, integer ( i4 ) M, the number of columns of Z to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M).  On input, the real and imaginary 
!    parts of the eigenvectors to be back transformed.  On output, the real and
!    imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(n,igh)
  integer ( i4 ) i
  integer ( i4 ) ind(igh)
  integer ( i4 ) j
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) mm
  integer ( i4 ) mp
  real (dp) x
  real (dp) z(n,m)

  if ( m == 0 ) then
    return
  end if

  la = igh - 1

  if ( la < low + 1 ) then
    return
  end if

  do mm = low + 1, la

     mp = low + igh - mm

     do i = mp + 1, igh

       x = a(i,mp-1)
       if ( x /= 0.0D+00 ) then
         z(i,1:m) = z(i,1:m) + x * z(mp,1:m)
       end if

     end do

     i = ind(mp)

     if ( i /= mp ) then

       do j = 1, m
         call r8_swap ( z(i,j), z(mp,j) )
       end do

     end if

  end do

  return
end subroutine elmbak

subroutine elmhes ( n, low, igh, a, ind )

!*****************************************************************************80
!
!! ELMHES transforms a real general matrix to upper Hessenberg form.
!
!  Discussion:
!
!    Given a real general matrix, this subroutine reduces a submatrix
!    situated in rows and columns LOW through IGH to upper Hessenberg
!    form by stabilized elementary similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Martin, James Wilkinson,
!    ELMHES,
!    Numerische Mathematik,
!    Volume 12, pages 349-368, 1968.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing 
!    routine BALANC.  If BALANC has not been used, set LOW = 1, IGH = N.
!
!    Input/output, real (dp) A(N,N).  On input, the matrix to be 
!    reduced.  On output, the Hessenberg matrix.  The multipliers
!    which were used in the reduction are stored in the
!    remaining triangle under the Hessenberg matrix.
!
!    Output, integer ( i4 ) IND(N), contains information on the rows
!    and columns interchanged in the reduction.  Only elements LOW through
!    IGH are used.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) a(n,n)
  integer ( i4 ) i
  integer ( i4 ) ind(igh)
  integer ( i4 ) j
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) m
  real (dp) x
  real (dp) y

  la = igh - 1

  do m = low + 1, la

    x = 0.0D+00
    i = m

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

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

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

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

    end if

    if ( x /= 0.0D+00 ) then

      do i = m + 1, igh

        y = a(i,m-1)

        if ( y /= 0.0D+00 ) then

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

          a(i,m:n) = a(i,m:n) - y * a(m,m:n)

          a(1:igh,m) = a(1:igh,m) + y * a(1:igh,i)

        end if

      end do

    end if

  end do

  return
end subroutine elmhes

subroutine eltran ( n, low, igh, a, ind, z )

!*****************************************************************************80
!
!! ELTRAN accumulates similarity transformations used by ELMHES.
!
!  Discussion:
!
!    This subroutine accumulates the stabilized elementary
!    similarity transformations used in the reduction of a
!    real general matrix to upper Hessenberg form by ELMHES.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Peters, James Wilkinson,
!    ELMTRANS,
!    Numerische Mathematik,
!    Volume 16, pages 181-204, 1970.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing 
!    routine BALANC.  If BALANC has not been used, set LOW = 1, IGH = N.
!
!    Input, real (dp) A(N,IGH), the multipliers which were used in the
!    reduction by ELMHES in its lower triangle below the subdiagonal.
!
!    Input, integer ( i4 ) IND(IGH), information on the rows and columns
!    interchanged in the reduction by ELMHES.
!
!    Output, real (dp) Z(N,N), the transformation matrix produced in the
!    reduction by ELMHES.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) a(n,igh)
  integer ( i4 ) i
  integer ( i4 ) ind(igh)
  integer ( i4 ) j
  integer ( i4 ) kl
  integer ( i4 ) low
  integer ( i4 ) mm
  integer ( i4 ) mp
  real (dp) z(n,n)
!
!  Initialize Z to the identity matrix.
!
  z(1:n,1:n) = 0.0D+00

  do i = 1, n
    z(i,i) = 1.0D+00
  end do

  kl = igh - low - 1

  if ( kl < 1 ) then
    return
  end if

  do mm = 1, kl

     mp = igh - mm

     z(mp+1:igh,mp) = a(mp+1:igh,mp-1)

     i = ind(mp)

     if ( i /= mp ) then

       z(mp,mp:igh) = z(i,mp:igh)

       z(i,mp) = 1.0D+00
       z(i,mp+1:igh) = 0.0D+00

     end if

  end do

  return
end subroutine eltran 

subroutine figi ( n, t, d, e, e2, ierr )

!*****************************************************************************80
!
!! FIGI transforms a real nonsymmetric tridiagonal matrix to symmetric form.
!
!  Discussion:
!
!    Given a nonsymmetric tridiagonal matrix such that the products
!    of corresponding pairs of off-diagonal elements are all
!    non-negative, this subroutine reduces it to a symmetric
!    tridiagonal matrix with the same eigenvalues.  If, further,
!    a zero product only occurs when both factors are zero,
!    the reduced matrix is similar to the original matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    20 April 2011
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) T(N,3) contains the input matrix.  Its subdiagonal
!    is stored in the last N-1 positions of the first column, its diagonal in
!    the N positions of the second column, and its superdiagonal in the
!    first N-1 positions of the third column.  T(1,1) and T(N,3) are arbitrary.
!
!    Output, real (dp) D(N), the diagonal elements of the symmetric 
!    matrix.
!
!    Output, real (dp) E(N), contains the subdiagonal elements of
!    the symmetric matrix in E(2:N).  E(1) is not set.
!
!    Output, real (dp) E2(N), the squares of the corresponding elements 
!    of E.  E2 may coincide with E if the squares are not needed.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    N+I, if T(I,1) * T(I-1,3) is negative,
!    -(3*N+I), if T(I,1) * T(I-1,3) is zero with one factor non-zero.  In
!      this case, the eigenvectors of the symmetric matrix are not simply
!      related to those of T and should not be sought.
!
  implicit none

  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  real (dp) t(n,3)

  ierr = 0

  do i = 1, n

    if ( 1 < i ) then

      e2(i) = t(i,1) * t(i-1,3)

      if ( e2(i) < 0.0D+00 ) then

        ierr = n + i
        return

      else if ( e2(i) == 0.0D+00 ) then

        if ( t(i,1) /= 0.0D+00 .or. t(i-1,3) /= 0.0D+00 ) then
          ierr = - 3 * n - i
          return
        end if

        e(i) = 0.0D+00

      else

        e(i) = sqrt ( e2(i) )

      end if

    end if

    d(i) = t(i,2)

  end do

  return
end subroutine figi

subroutine figi2 ( n, t, d, e, z, ierr )

!*****************************************************************************80
!
!! FIGI2 transforms a real nonsymmetric tridiagonal matrix to symmetric form.
!
!  Discussion:
!
!    Given a nonsymmetric tridiagonal matrix such that the products
!    of corresponding pairs of off-diagonal elements are all
!    non-negative, and zero only when both factors are zero, this
!    subroutine reduces it to a symmetric tridiagonal matrix
!    using and accumulating diagonal similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) T(N,3) contains the input matrix.  Its subdiagonal
!    is stored in the last N-1 positions of the first column, its diagonal in
!    the N positions of the second column, and its superdiagonal in the
!    first N-1 positions of the third column.  T(1,1) and T(N,3) are arbitrary.
!
!    Output, real (dp) D(N), the diagonal elements of the symmetric 
!    matrix.
!
!    Output, real (dp) E(N), contains the subdiagonal elements of the 
!    symmetric matrix in E(2:N).  E(1) is not set.
!
!    Output, real (dp) Z(N,N), contains the transformation matrix
!    produced in the reduction.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    N+I, if T(I,1) * T(I-1,3) is negative,
!    2*N+I, if T(I,1) * T(I-1,3) is zero with one factor non-zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) j
  real (dp) t(n,3)
  real (dp) z(n,n)

  ierr = 0

  do i = 1, n

    z(i,1:n) = 0.0D+00

    if ( i == 1 ) then

      z(i,i) = 1.0D+00

    else

      h = t(i,1) * t(i-1,3)

      if ( h < 0.0D+00 ) then

        ierr = n + i
        return

      else if ( h == 0 ) then

        if ( t(i,1) /= 0.0D+00 .or. t(i-1,3) /= 0.0D+00 ) then
          ierr = 2 * n + i
          return
        end if

        e(i) = 0.0D+00
        z(i,i) = 1.0D+00

      else

        e(i) = sqrt ( h )
        z(i,i) = z(i-1,i-1) * e(i) / t(i-1,3)

      end if

    end if

    d(i) = t(i,2)

  end do

  return
end subroutine figi2

subroutine hqr ( n, low, igh, h, wr, wi, ierr )

!*****************************************************************************80
!
!! HQR computes all eigenvalues of a real upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a real
!    upper Hessenberg matrix by the QR method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Martin, Peters, James Wilkinson,
!    HQR,
!    Numerische Mathematik,
!    Volume 14, pages 219-231, 1970.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, two integers determined by 
!    BALANC.  If BALANC is not used, set LOW=1, IGH=N.
!
!    Input/output, real (dp) H(N,N), the N by N upper Hessenberg matrix.
!    Information about the transformations used in the reduction to
!    Hessenberg form by ELMHES or ORTHES, if performed, is stored
!    in the remaining triangle under the Hessenberg matrix.
!    On output, the information in H has been destroyed.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  The eigenvalues are unordered, except that complex
!    conjugate pairs of values appear consecutively, with the eigenvalue
!    having positive imaginary part listed first.  If an error exit
!    occurred, then the eigenvalues should be correct for indices
!    IERR+1 through N.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, no error.
!    J, the limit of 30*N iterations was reached while searching for
!      the J-th eigenvalue.
!
  implicit none

  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm2
  real (dp) h(n,n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) igh
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) mm
  integer ( i4 ) na
  real (dp) norm
  logical notlas
  real (dp) p
  real (dp) q
  real (dp) r
  real (dp) s
  real (dp) t
  real (dp) tst1
  real (dp) tst2
  real (dp) w
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) x
  real (dp) y
  real (dp) zz

  ierr = 0
  norm = 0.0D+00
  k = 1
!
!  Store roots isolated by BALANC and compute matrix norm.
!
  do i = 1, n

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

    k = i
    if ( i < low .or. igh < i ) then
      wr(i) = h(i,i)
      wi(i) = 0.0D+00
    end if

  end do

  en = igh
  t = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalues.
!
60 continue

  if ( en < low ) then
    return
  end if

  its = 0
  na = en - 1
  enm2 = na - 1
!
!  Look for a single small sub-diagonal element.
!
70 continue

  do ll = low, en
    l = en + low - ll
    if ( l == low ) then
      exit
    end if
    s = abs ( h(l-1,l-1) ) + abs ( h(l,l) )
    if ( s == 0.0D+00 ) then
      s = norm
    end if
    tst1 = s
    tst2 = tst1 + abs ( h(l,l-1) )
    if ( tst2 == tst1 ) then
      exit
    end if
  end do
!
!  Form shift.
!
  x = h(en,en)

  if ( l == en ) then
    go to 270
  end if

  y = h(na,na)
  w = h(en,na) * h(na,en)

  if ( l == na ) then
    go to 280
  end if

  if ( itn == 0 ) then
    ierr = en
    return
  end if
!
!  Form an exceptional shift.
!
  if ( its == 10 .or. its == 20 ) then

    t = t + x

    do i = low, en
      h(i,i) = h(i,i) - x
    end do

    s = abs ( h(en,na) ) + abs ( h(na,enm2) )
    x = 0.75D+00 * s
    y = x
    w = -0.4375D+00 * s * s

  end if

  its = its + 1
  itn = itn - 1
!
!  Look for two consecutive small sub-diagonal elements.
!
  do mm = l, enm2

    m = enm2 + l - mm
    zz = h(m,m)
    r = x - zz
    s = y - zz
    p = ( r * s - w ) / h(m+1,m) + h(m,m+1)
    q = h(m+1,m+1) - zz - r - s
    r = h(m+2,m+1)
    s = abs ( p ) + abs ( q ) + abs ( r )
    p = p / s
    q = q / s
    r = r / s

    if ( m == l ) then
      exit
    end if

    tst1 = abs ( p ) * ( abs ( h(m-1,m-1) ) + abs ( zz ) + abs ( h(m+1,m+1) ) )
    tst2 = tst1 + abs ( h(m,m-1) ) * ( abs ( q ) + abs ( r ) )

    if ( tst2 == tst1 ) then
      exit
    end if

  end do

  do i = m + 2, en
    h(i,i-2) = 0.0D+00
    if ( i /= m + 2 ) then
      h(i,i-3) = 0.0D+00
    end if
  end do
!
!  Double QR step involving rows l to EN and columns M to EN.
!
  do k = m, na

    notlas = k /= na

    if ( k /= m ) then

      p = h(k,k-1)
      q = h(k+1,k-1)

      if ( notlas ) then
        r = h(k+2,k-1)
      else
        r = 0.0D+00
      end if

      x = abs ( p ) + abs ( q ) + abs ( r )

      if ( x == 0.0D+00 ) then
        cycle
      end if

      p = p / x
      q = q / x
      r = r / x

    end if

    s = sign ( sqrt ( p**2 + q**2 + r**2 ), p )

    if ( k /= m ) then
      h(k,k-1) = - s * x
    else if ( l /= m ) then
      h(k,k-1) = - h(k,k-1)
    end if

    p = p + s
    x = p / s
    y = q / s
    zz = r / s
    q = q / p
    r = r / p

    if ( .not. notlas ) then
!
!  Row modification.
!
      do j = k, n
        p = h(k,j) + q * h(k+1,j)
        h(k,j) = h(k,j) - p * x
        h(k+1,j) = h(k+1,j) - p * y
      end do

      j = min ( en, k + 3 )
!
!  Column modification.
!
      do i = 1, j
        p = x * h(i,k) + y * h(i,k+1)
        h(i,k) = h(i,k) - p
        h(i,k+1) = h(i,k+1) - p * q
      end do

    else
!
!  Row modification.
!
      do j = k, n
        p = h(k,j) + q * h(k+1,j) + r * h(k+2,j)
        h(k,j) = h(k,j) - p * x
        h(k+1,j) = h(k+1,j) - p * y
        h(k+2,j) = h(k+2,j) - p * zz
      end do

      j = min ( en, k + 3 )
!
!  Column modification.
!
      do i = 1, j
        p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2)
        h(i,k) = h(i,k) - p
        h(i,k+1) = h(i,k+1) - p * q
        h(i,k+2) = h(i,k+2) - p * r
      end do

    end if

  end do

  go to 70
!
!  One root found.
!
270 continue

  wr(en) = x + t
  wi(en) = 0.0D+00
  en = na
  go to 60
!
!  Two roots found.
!
280 continue

  p = ( y - x ) / 2.0D+00
  q = p * p + w
  zz = sqrt ( abs ( q ) )
  x = x + t
!
!  Real root, or complex pair.
!
  if ( 0.0D+00 <= q ) then

    zz = p + sign ( zz, p )
    wr(na) = x + zz
    if ( zz == 0.0D+00 ) then
      wr(en) = wr(na)
    else
      wr(en) = x - w / zz
    end if
    wi(na) = 0.0D+00
    wi(en) = 0.0D+00

  else

    wr(na) = x + p
    wr(en) = x + p
    wi(na) = zz
    wi(en) = -zz

  end if

  en = enm2
  go to 60
end subroutine hqr

subroutine hqr2 ( n, low, igh, h, wr, wi, z, ierr )

!*****************************************************************************80
!
!! HQR2 computes eigenvalues and eigenvectors of a real upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors
!    of a real upper Hessenberg matrix by the qr method.  the
!    eigenvectors of a real general matrix can also be found
!    if ELMHES and ELTRAN or ORTHES and ORTRAN have
!    been used to reduce this general matrix to Hessenberg form
!    and to accumulate the similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, determined by the balancing
!    routine BALANC.  If BALANC has not been used, set LOW = 1, IGH = N.
!
!    Input/output, real (dp) H(N,N), the N by N upper Hessenberg matrix.
!    On output, the information in H has been destroyed.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts of the
!    eigenvalues.  The eigenvalues are unordered, except that complex
!    conjugate pairs of values appear consecutively, with the eigenvalue
!    having positive imaginary part listed first.  If an error exit
!    occurred, then the eigenvalues should be correct for indices
!    IERR+1 through N.
!
!    Input/output, real (dp) Z(N,N).  On input, the transformation 
!    matrix produced by ELTRAN after the reduction by ELMHES, or by ORTRAN after
!    the reduction by ORTHES, if performed.  If the eigenvectors of the 
!    Hessenberg matrix are desired, Z must contain the identity matrix.  On 
!    output, Z contains the real and imaginary parts of the eigenvectors.
!    If the I-th eigenvalue is real, the I-th column of Z contains its
!    eigenvector.  If the I-th eigenvalue is complex with positive imaginary
!    part, the I-th and (I+1)-th columns of Z contain the real and imaginary
!    parts of its eigenvector.  The eigenvectors are unnormalized.  If an
!    error exit is made, none of the eigenvectors has been found.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) n

  integer ( i4 ) en
  integer ( i4 ) enm2
  real (dp) h(n,n)
  real (dp) hnorm
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) igh
  integer ( i4 ) ii
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) mm
  integer ( i4 ) na
  integer ( i4 ) nn
  real (dp) norm
  logical notlas
  real (dp) p
  real (dp) q
  real (dp) r
  real (dp) ra
  real (dp) s
  real (dp) sa
  real (dp) t
  real (dp) temp
  real (dp) tst1
  real (dp) tst2
  real (dp) vi
  real (dp) vr
  real (dp) w
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) x
  real (dp) y
  real (dp) z(n,n)
  real (dp) zz

  ierr = 0
  norm = 0.0D+00
  k = 1
!
!  Store roots isolated by BALANC and compute the matrix norm.
!
  do i = 1, n

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

    k = i
    if ( i < low .or. igh < i ) then
      wr(i) = h(i,i)
      wi(i) = 0.0D+00
    end if

  end do

  en = igh
  t = 0.0D+00
  itn = 30 * n
!
!  Search for next eigenvalues.
!
60 continue

  if ( en < low ) then
    go to 340
  end if

  its = 0
  na = en - 1
  enm2 = na - 1
!
!  Look for single small sub-diagonal element.
!
70 continue

  do ll = low, en

    l = en + low - ll

    if ( l == low ) then
      exit
    end if

    s = abs ( h(l-1,l-1) ) + abs ( h(l,l) )
    if ( s == 0.0D+00 ) then
      s = norm
    end if

    tst1 = s
    tst2 = tst1 + abs ( h(l,l-1) )

    if ( tst2 == tst1 ) then
      exit
    end if

  end do
!
!  Form shift.
!
  x = h(en,en)
  if ( l == en ) then
    go to 270
  end if

  y = h(na,na)
  w = h(en,na) * h(na,en)

  if ( l == na ) then
    go to 280
  end if

  if ( itn == 0 ) then
    ierr = en
    return
  end if
!
!  Form exceptional shift.
!
  if ( its == 10 .or. its == 20 ) then

    t = t + x

    do i = low, en
      h(i,i) = h(i,i) - x
    end do

    s = abs ( h(en,na) ) + abs ( h(na,enm2) )
    x = 0.75D+00 * s
    y = x
    w = -0.4375D+00 * s * s

  end if

  its = its + 1
  itn = itn - 1
!
!  Look for two consecutive small sub-diagonal elements.
!
  do mm = l, enm2

    m = enm2 + l - mm
    zz = h(m,m)
    r = x - zz
    s = y - zz
    p = ( r * s - w ) / h(m+1,m) + h(m,m+1)
    q = h(m+1,m+1) - zz - r - s
    r = h(m+2,m+1)
    s = abs ( p ) + abs ( q ) + abs ( r )
    p = p / s
    q = q / s
    r = r / s

    if ( m == l ) then
      exit
    end if

    tst1 = abs ( p ) * ( abs ( h(m-1,m-1) ) + abs ( zz ) + abs ( h(m+1,m+1) ) )
    tst2 = tst1 + abs ( h(m,m-1) ) * ( abs ( q ) + abs ( r ) )

    if ( tst2 == tst1 ) then
      exit
    end if

  end do

  do i = m + 2, en
    h(i,i-2) = 0.0D+00
    if ( i /= m + 2 ) then
      h(i,i-3) = 0.0D+00
    end if
  end do
!
!  Double QR step involving rows L to EN and columns M to EN.
!
  do k = m, na

     notlas = k /= na

     if ( k /= m ) then

       p = h(k,k-1)
       q = h(k+1,k-1)
       r = 0.0D+00
       if ( notlas ) then
         r = h(k+2,k-1)
       end if

       x = abs ( p ) + abs ( q ) + abs ( r )
       if ( x == 0.0D+00 ) then
         cycle
       end if

       p = p / x
       q = q / x
       r = r / x

     end if

     s = sign ( sqrt ( p**2 + q**2 + r**2 ), p )

     if ( k /= m ) then
       h(k,k-1) = - s * x
     else if ( l /= m ) then
       h(k,k-1) = -h(k,k-1)
     end if

     p = p + s
     x = p / s
     y = q / s
     zz = r / s
     q = q / p
     r = r / p

     if ( notlas ) then
       go to 225
     end if
!
!  Row modification.
!
     do j = k, n
       p = h(k,j) + q * h(k+1,j)
       h(k,j) = h(k,j) - p * x
       h(k+1,j) = h(k+1,j) - p * y
     end do

     j = min ( en, k + 3 )
!
!  Column modification.
!
     do i = 1, j
       p = x * h(i,k) + y * h(i,k+1)
       h(i,k) = h(i,k) - p
       h(i,k+1) = h(i,k+1) - p * q
     end do
!
!  Accumulate transformations.
!
     do i = low, igh
       p = x * z(i,k) + y * z(i,k+1)
       z(i,k) = z(i,k) - p
       z(i,k+1) = z(i,k+1) - p * q
     end do

     go to 255

225  continue
!
!  Row modification.
!
     do j = k, n
       p = h(k,j) + q * h(k+1,j) + r * h(k+2,j)
       h(k,j) = h(k,j) - p * x
       h(k+1,j) = h(k+1,j) - p * y
       h(k+2,j) = h(k+2,j) - p * zz
     end do

     j = min ( en, k + 3 )
!
!  Column modification.
!
     do i = 1, j
       p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2)
       h(i,k) = h(i,k) - p
       h(i,k+1) = h(i,k+1) - p * q
       h(i,k+2) = h(i,k+2) - p * r
     end do
!
!  Accumulate transformations.
!
     do i = low, igh
        p = x * z(i,k) + y * z(i,k+1) + zz * z(i,k+2)
        z(i,k) = z(i,k) - p
        z(i,k+1) = z(i,k+1) - p * q
        z(i,k+2) = z(i,k+2) - p * r
     end do

255 continue

260 continue

  end do

  go to 70
!
!  One root found.
!
270 continue

  h(en,en) = x + t
  wr(en) = h(en,en)
  wi(en) = 0.0D+00
  en = na
  go to 60
!
!  Two roots found.
!
280 continue

  p = ( y - x ) / 2.0D+00
  q = p * p + w
  zz = sqrt ( abs ( q ) )
  h(en,en) = x + t
  x = h(en,en)
  h(na,na) = y + t

  if ( q < 0.0D+00 ) then
    go to 320
  end if
!
!  Real pair.
!
  zz = p + sign ( zz, p )
  wr(na) = x + zz
  wr(en) = wr(na)

  if ( zz /= 0.0D+00 ) then
    wr(en) = x - w / zz
  end if

  wi(na) = 0.0D+00
  wi(en) = 0.0D+00
  x = h(en,na)
  s = abs ( x ) + abs ( zz )
  p = x / s
  q = zz / s
  r = sqrt ( p**2 + q**2 )
  p = p / r
  q = q / r
!
!  Row modification.
!
  do 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
  end do
!
!  Column modification.
!
  do 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
  end do
!
!  Accumulate transformations.
!
  do i = low, igh
    zz = z(i,na)
    z(i,na) = q * zz + p * z(i,en)
    z(i,en) = q * z(i,en) - p * zz
  end do

  go to 330
!
!  Complex pair
!
320 continue

  wr(na) = x + p
  wr(en) = x + p
  wi(na) = zz
  wi(en) = -zz

330 continue

  en = enm2
  go to 60
!
!  All roots found.
!  Backsubstitute to find vectors of upper triangular form.
!
340 continue

  if ( norm == 0.0D+00 ) then
    return
  end if

  do nn = 1, n

     en = n + 1 - nn
     p = wr(en)
     q = wi(en)
     na = en - 1
!     if ( q ) 710, 600, 800
! Replaced arithemtif if with if, else if, else structure
     if ( q.LT.0 ) then
       GOTO 710
     else if (q.EQ.0) then
       GOTO 600
     else 
       GOTO 800
     end if
!
!  Real vector
!
600  continue

     m = en
     h(en,en) = 1.0D+00

     if ( na == 0 ) then
       go to 800
     end if

     do ii = 1, na

        i = en - ii
        w = h(i,i) - p
        r = dot_product ( h(i,m:en), h(m:en,en) )

        if ( wi(i) < 0.0D+00 ) then
          zz = w
          s = r
          go to 700
        end if

        m = i

        if ( wi(i) /= 0.0D+00 ) then
          go to 640
        end if

        t = w

        if ( t == 0.0D+00 ) then

          tst1 = norm
          t = tst1

          do
            t = 0.01D+00 * t
            tst2 = norm + t
            if ( tst2 <= tst1 ) then
              exit
            end if
          end do

        end if

        h(i,en) = -r / t
        go to 680
!
!  Solve real equations.
!
640     continue

        x = h(i,i+1)
        y = h(i+1,i)
        q = ( wr(i) - p ) * ( wr(i) - p ) + wi(i) * wi(i)
        t = ( x * s - zz * r ) / q
        h(i,en) = t

        if ( abs ( zz ) < abs ( x ) ) then
          h(i+1,en) = ( - r - w * t ) / x
        else
          h(i+1,en) = (-s - y * t ) / zz
        end if
!
!  Overflow control.
!
680     continue

        t = abs ( h(i,en) )

        if ( t /= 0.0D+00 ) then

          tst1 = t
          tst2 = tst1 + 1.0D+00 / tst1

          if ( tst2 <= tst1 ) then
            h(i:en,en) = h(i:en,en) / t
          end if

        end if

700   continue

    end do
!
!  End real vector
!
     go to 800
!
!  Complex vector
!
710  continue

     m = na
!
!  Last vector component chosen imaginary, so that the eigenvector
!  matrix is triangular.
!
     if ( abs ( h(en,na) ) > abs ( h(na,en) ) ) then

       h(na,na) = q / h(en,na)
       h(na,en) = -(h(en,en) - p) / h(en,na)

     else

       call cdiv ( 0.0D+00, -h(na,en), h(na,na)-p, q, h(na,na), h(na,en) )

     end if

     h(en,na) = 0.0D+00
     h(en,en) = 1.0D+00
     enm2 = na - 1

     do ii = 1, enm2

        i = na - ii
        w = h(i,i) - p
        ra = dot_product ( h(i,m:en), h(m:en,na) )
        sa = dot_product ( h(i,m:en), h(m:en,en) )

        if ( wi(i) < 0.0D+00 ) then
          zz = w
          r = ra
          s = sa
        end if

         m = i

        if ( wi(i) == 0.0D+00 ) then
          call cdiv ( -ra, -sa, w, q, h(i,na), h(i,en) )
          go to 790
        end if
!
!  Solve complex equations.
!
        x = h(i,i+1)
        y = h(i+1,i)
        vr = ( wr(i) - p ) * ( wr(i) - p ) + wi(i) * wi(i) - q * q
        vi = ( wr(i) - p ) * 2.0D+00 * q

        if ( vr == 0.0D+00 .and. vi == 0.0D+00 ) then

          tst1 = norm * ( abs ( w ) + abs ( q ) + abs ( x ) &
            + abs ( y ) + abs ( zz ) )
          vr = tst1

          do
            vr = 0.01D+00 * vr
            tst2 = tst1 + vr
            if ( tst2 <= tst1 ) then
              exit
            end if
          end do

        end if

        call cdiv ( x*r-zz*ra+q*sa, x*s-zz*sa-q*ra, vr, vi, h(i,na), h(i,en) )

        if ( abs ( x ) > abs ( zz ) + abs ( q ) ) then
          h(i+1,na) = ( -ra - w * h(i,na) + q * h(i,en) ) / x
          h(i+1,en) = ( -sa - w * h(i,en) - q * h(i,na) ) / x
        else
          call cdiv ( -r-y*h(i,na), -s-y*h(i,en), zz, q, h(i+1,na), h(i+1,en) )
        end if
!
!  Overflow control.
!
790     continue

        t = max ( abs ( h(i,na) ), abs ( h(i,en) ) )

        if ( t /= 0.0D+00 ) then
          tst1 = t
          tst2 = tst1 + 1.0D+00 / tst1
          if ( tst2 <= tst1 ) then
            h(i:en,na) = h(i:en,na) / t
            h(i:en,en) = h(i:en,en) / t
          end if
        end if

795     continue

      end do
!
!  End complex vector.
!
800 continue

  end do
!
!  End back substitution.
!
!  Vectors of isolated roots.
!
  do i = 1, n

    if ( i < low .or. igh < i ) then
      z(i,i:n) = h(i,i:n)
    end if

  end do
!
!  Multiply by transformation matrix to give vectors of original full matrix.
!
  do jj = low, n

     j = n + low - jj
     m = min ( j, igh )

     do i = low, igh
       z(i,j) = dot_product ( z(i,low:m), h(low:m,j) )
     end do

  end do

  return
end subroutine hqr2

subroutine htrib3 ( n, a, tau, m, zr, zi )

!*****************************************************************************80
!
!! HTRIB3 determines eigenvectors by undoing the HTRID3 transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex hermitian
!    matrix by back transforming those of the corresponding
!    real symmetric tridiagonal matrix determined by HTRID3.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, is the order of the matrix.
!
!    Input, real (dp) A(N,N), contains information about the unitary
!    transformations used in the reduction by HTRID3.
!
!    Input, real (dp) TAU(2,N), contains further information about the
!    transformations.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) ZR(N,M), ZI(N,M).  On input, ZR contains 
!    the eigenvectors to be back transformed.  On output, ZR and ZI contain
!    the real and imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) s
  real (dp) si
  real (dp) tau(2,n)
  real (dp) zi(n,m)
  real (dp) zr(n,m)

  if ( m == 0 ) then
    return
  end if
!
!  Transform the eigenvectors of the real symmetric tridiagonal matrix
!  to those of the hermitian tridiagonal matrix.
!
  do k = 1, n
    do j = 1, m
      zi(k,j) = -zr(k,j) * tau(2,k)
      zr(k,j) = zr(k,j) * tau(1,k)
    end do
  end do
!
!  Recover and apply the Householder matrices.
!
  do i = 2, n

    l = i - 1
    h = a(i,i)

    if ( h /= 0.0D+00 ) then

      do j = 1, m

        s = 0.0D+00
        si = 0.0D+00

        do k = 1, l
          s = s + a(i,k) * zr(k,j) - a(k,i) * zi(k,j)
          si = si + a(i,k) * zi(k,j) + a(k,i) * zr(k,j)
        end do

        s = ( s / h ) / h
        si = ( si / h ) / h

        zr(1:l,j) = zr(1:l,j) - s * a(i,1:l) - si * a(1:l,i)
        zi(1:l,j) = zi(1:l,j) - si * a(i,1:l) + s * a(1:l,i)

      end do

    end if

  end do

  return
end subroutine htrib3

subroutine htribk ( n, ar, ai, tau, m, zr, zi )

!*****************************************************************************80
!
!! HTRIBK determines eigenvectors by undoing the HTRIDI transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a complex hermitian
!    matrix by back transforming those of the corresponding
!    real symmetric tridiagonal matrix determined by HTRIDI.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) AR(N,N), AI(N,N), contain information about
!    the unitary transformations used in the reduction by HTRIDI in their
!    full lower triangles, except for the diagonal of AR.
!
!    Input, real (dp) TAU(2,N), contains further information about the
!    transformations.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) ZR(N,M), ZI(N,M).  On input, ZR contains 
!    the eigenvectors to be back transformed.  On output, ZR and ZI contain
!    the real and imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) s
  real (dp) si
  real (dp) tau(2,n)
  real (dp) zi(n,m)
  real (dp) zr(n,m)

  if ( m == 0 ) then
    return
  end if
!
!  Transform the eigenvectors of the real symmetric tridiagonal matrix to
!  those of the hermitian tridiagonal matrix.
!
  do k = 1, n
    do j = 1, m
      zi(k,j) = -zr(k,j) * tau(2,k)
      zr(k,j) = zr(k,j) * tau(1,k)
    end do
  end do
!
!  Recover and apply the Householder matrices.
!
  do i = 2, n

    l = i - 1
    h = ai(i,i)

    if ( h /= 0.0D+00 ) then

      do j = 1, m

        s = 0.0D+00
        si = 0.0D+00
        do k = 1, l
          s = s + ar(i,k) * zr(k,j) - ai(i,k) * zi(k,j)
          si = si + ar(i,k) * zi(k,j) + ai(i,k) * zr(k,j)
        end do

        s = ( s / h ) / h
        si = ( si / h ) / h

        zr(1:l,j) = zr(1:l,j) - s * ar(i,1:l) - si * ai(i,1:l)
        zi(1:l,j) = zi(1:l,j) - si * ar(i,1:l) + s * ai(i,1:l)

      end do

    end if

  end do

  return
end subroutine htribk

subroutine htrid3 ( n, a, d, e, e2, tau )

!*****************************************************************************80
!
!! HTRID3 tridiagonalizes a complex hermitian packed matrix.
!
!  Discussion:
!
!    This subroutine reduces a complex hermitian matrix, stored as
!    a single square array, to a real symmetric tridiagonal matrix
!    using unitary similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) A(N,N).  On input, the lower triangle of 
!    the complex hermitian input matrix.  The real parts of the matrix elements 
!    are stored in the full lower triangle of A, and the imaginary parts are 
!    stored in the transposed positions of the strict upper triangle of A.  No 
!    storage is required for the zero imaginary parts of the diagonal elements.
!    On output, A contains information about the unitary transformations
!    used in the reduction.
!
!    Output, real (dp) D(N), the diagonal elements of the
!    tridiagonal matrix.
!
!    Output, real (dp) E(N), the subdiagonal elements of the tridiagonal
!    matrix in E(2:N).  E(1) is set to zero.
!
!    Output, real (dp) E2(N), the squares of the corresponding elements 
!    of E.  E2 may coincide with E if the squares are not needed.
!
!    Output, real (dp) TAU(2,N), contains further information about the
!    transformations.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) fi
  real (dp) g
  real (dp) gi
  real (dp) h
  real (dp) hh
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) scale
  real (dp) si
  real (dp) tau(2,n)

  tau(1,n) = 1.0D+00
  tau(2,n) = 0.0D+00

  do ii = 1, n

    i = n + 1 - ii
    l = i - 1
    h = 0.0D+00
    scale = 0.0D+00

    if ( l < 1 ) then
      e(i) = 0.0D+00
      e2(i) = 0.0D+00
      go to 290
    end if
!
!  Scale row.
!
     do k = 1, l
       scale = scale + abs ( a(i,k) ) + abs ( a(k,i) )
     end do

     if ( scale == 0.0D+00 ) then
       tau(1,l) = 1.0D+00
       tau(2,l) = 0.0D+00
       e(i) = 0.0D+00
       e2(i) = 0.0D+00
       go to 290
     end if

      do k = 1, l
        a(i,k) = a(i,k) / scale
        a(k,i) = a(k,i) / scale
        h = h + a(i,k) * a(i,k) + a(k,i) * a(k,i)
     end do

     e2(i) = scale * scale * h
     g = sqrt ( h )
     e(i) = scale * g
     f = pythag ( a(i,l), a(l,i) )
!
!  Form next diagonal element of matrix T.
!
     if ( f /= 0.0D+00 ) then

       tau(1,l) = ( a(l,i) * tau(2,i) - a(i,l) * tau(1,i) ) / f
       si = ( a(i,l) * tau(2,i) + a(l,i) * tau(1,i) ) / f
       h = h + f * g
       g = 1.0D+00 + g / f
       a(i,l) = g * a(i,l)
       a(l,i) = g * a(l,i)

       if ( l == 1 ) then
         go to 270
       end if

     else

       tau(1,l) = -tau(1,i)
       si = tau(2,i)
       a(i,l) = g

     end if

     f = 0.0D+00

     do j = 1, l

        g = 0.0D+00
        gi = 0.0D+00
!
!  Form element of A*U.
!
        do k = 1, j - 1
          g = g + a(j,k) * a(i,k) + a(k,j) * a(k,i)
          gi = gi - a(j,k) * a(k,i) + a(k,j) * a(i,k)
        end do

        g = g + a(j,j) * a(i,j)
        gi = gi - a(j,j) * a(j,i)

        do k = j + 1, l
          g = g + a(k,j) * a(i,k) - a(j,k) * a(k,i)
          gi = gi - a(k,j) * a(k,i) - a(j,k) * a(i,k)
        end do
!
!  Form element of P.
!
        e(j) = g / h
        tau(2,j) = gi / h
        f = f + e(j) * a(i,j) - tau(2,j) * a(j,i)

     end do

     hh = f / ( h + h )
!
!  Form reduced A.
!
     do j = 1, l

        f = a(i,j)
        g = e(j) - hh * f
        e(j) = g
        fi = -a(j,i)
        gi = tau(2,j) - hh * fi
        tau(2,j) = -gi
        a(j,j) = a(j,j) - 2.0D+00 * ( f * g + fi * gi )

        do k = 1, j - 1
          a(j,k) = a(j,k) - f * e(k) - g * a(i,k) + fi * tau(2,k) + gi * a(k,i)
          a(k,j) = a(k,j) - f * tau(2,k) - g * a(k,i) - fi * e(k) - gi * a(i,k)
        end do

     end do

270  continue

     a(i,1:l) = scale * a(i,1:l)
     a(1:l,i) = scale * a(1:l,i)
     tau(2,l) = -si

290  continue

     d(i) = a(i,i)
     a(i,i) = scale * sqrt ( h )

  end do

  return
end subroutine htrid3

subroutine htridi ( n, ar, ai, d, e, e2, tau )

!*****************************************************************************80
!
!! HTRIDI tridiagonalizes a complex hermitian matrix.
!
!  Discussion:
!
!    This subroutine reduces a complex hermitian matrix to a real symmetric
!    tridiagonal matrix using unitary similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) AR(N,N), AI(N,N).  On input, the real
!    and imaginary parts, respectively, of the complex hermitian input matrix.
!    Only the lower triangle of the matrix need be supplied.
!    On output, information about the unitary transformations used in the
!    reduction in their full lower triangles.  Their strict upper triangles
!    and the diagonal of AR are unaltered.
!
!    Output, real (dp) D(N), the diagonal elements of the
!    tridiagonal matrix.
!
!    Output, real (dp) E(N), the subdiagonal elements of the tridiagonal
!    matrix in its last N-1 positions.  E(1) is set to zero.
!
!    Output, real (dp) E2(N), the squares of the corresponding elements 
!    of E.  E2 may coincide with E if the squares are not needed.
!
!    Output, real (dp) TAU(2,N), contains further information about the
!    transformations.
!
  implicit none

  integer ( i4 ) n

  real (dp) ai(n,n)
  real (dp) ar(n,n)
  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) fi
  real (dp) g
  real (dp) gi
  real (dp) h
  real (dp) hh
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) scale
  real (dp) si
  real (dp) tau(2,n)

  tau(1,n) = 1.0D+00
  tau(2,n) = 0.0D+00

  do i = 1, n
    d(i) = ar(i,i)
  end do

  do ii = 1, n

    i = n + 1 - ii
    l = i - 1
    h = 0.0D+00
    scale = 0.0D+00

    if ( l < 1 ) then
      e(i) = 0.0D+00
      e2(i) = 0.0D+00
      go to 290
    end if
!
!  Scale row.
!
    do k = 1, l
      scale = scale + abs ( ar(i,k) ) + abs ( ai(i,k) )
    end do

    if ( scale == 0.0D+00 ) then
      tau(1,l) = 1.0D+00
      tau(2,l) = 0.0D+00
      e(i) = 0.0D+00
      e2(i) = 0.0D+00
      go to 290
    end if

    ar(i,1:l) = ar(i,1:l) / scale
    ai(i,1:l) = ai(i,1:l) / scale

    do k = 1, l
      h = h + ar(i,k) * ar(i,k) + ai(i,k) * ai(i,k)
    end do

    e2(i) = scale * scale * h
    g = sqrt ( h )
    e(i) = scale * g
    f = pythag ( ar(i,l), ai(i,l) )
!
!  Form next diagonal element of matrix T.
!
    if ( f /= 0.0D+00 ) then
      tau(1,l) = ( ai(i,l) * tau(2,i) - ar(i,l) * tau(1,i) ) / f
      si = ( ar(i,l) * tau(2,i) + ai(i,l) * tau(1,i) ) / f
      h = h + f * g
      g = 1.0D+00 + g / f
      ar(i,l) = g * ar(i,l)
      ai(i,l) = g * ai(i,l)
      if ( l == 1 ) then
        go to 270
      end if
    else
      tau(1,l) = -tau(1,i)
      si = tau(2,i)
      ar(i,l) = g
    end if

    f = 0.0D+00

    do j = 1, l

      g = 0.0D+00
      gi = 0.0D+00
!
!  Form element of A*U.
!
      do k = 1, j
        g = g + ar(j,k) * ar(i,k) + ai(j,k) * ai(i,k)
        gi = gi - ar(j,k) * ai(i,k) + ai(j,k) * ar(i,k)
      end do

      do k = j + 1, l
        g = g + ar(k,j) * ar(i,k) - ai(k,j) * ai(i,k)
        gi = gi - ar(k,j) * ai(i,k) - ai(k,j) * ar(i,k)
      end do
!
!  Form element of P.
!
      e(j) = g / h
      tau(2,j) = gi / h
      f = f + e(j) * ar(i,j) - tau(2,j) * ai(i,j)

    end do

    hh = f / ( h + h )
!
!  Form the reduced A.
!
    do j = 1, l

      f = ar(i,j)
      g = e(j) - hh * f
      e(j) = g
      fi = - ai(i,j)
      gi = tau(2,j) - hh * fi
      tau(2,j) = -gi

      do k = 1, j
        ar(j,k) = ar(j,k) - f * e(k) - g * ar(i,k) + fi * tau(2,k) &
          + gi * ai(i,k)
        ai(j,k) = ai(j,k) - f * tau(2,k) - g * ai(i,k) - fi * e(k) &
          - gi * ar(i,k)
      end do

    end do

270 continue

    ar(i,1:l) = scale * ar(i,1:l)
    ai(i,1:l) = scale * ai(i,1:l)
    tau(2,l) = -si

290 continue

    hh = d(i)
    d(i) = ar(i,i)
    ar(i,i) = hh
    ai(i,i) = scale * sqrt ( h )

  end do

  return
end subroutine htridi

subroutine imtql1 ( n, d, e, ierr )

!*****************************************************************************80
!
!! IMTQL1 computes all eigenvalues of a symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a symmetric
!    tridiagonal matrix by the implicit QL method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) D(N).  On input, the diagonal elements of
!    the matrix.  On output, the eigenvalues in ascending order.  If an error
!    exit is made, the eigenvalues are correct and ordered for indices
!    1,2,...IERR-1, but may not be the smallest eigenvalues.
!
!    Input/output, real (dp) E(N).  On input, the subdiagonal elements
!    of the matrix in its last N-1 positions.  E(1) is arbitrary.  On output,
!    E has been overwritten.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, normal return,
!    J, if the J-th eigenvalue has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) b
  real (dp) c
  real (dp) d(n)
  real (dp) e(n)
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) l
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) s
  real (dp) tst1
  real (dp) tst2

  ierr = 0

  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    e(i-1) = e(i)
  end do
  e(n) = 0.0D+00

  do l = 1, n

    j = 0
!
!  Look for a small sub-diagonal element.
!
105 continue

    do m = l, n

      if ( m == n ) then
        exit
      end if

      tst1 = abs ( d(m) ) + abs ( d(m+1) )
      tst2 = tst1 + abs ( e(m) )

      if ( tst2 == tst1 ) then
        exit
      end if

    end do

    p = d(l)

    if ( m == l ) then
      go to 215
    end if

    if ( 30 <= j ) then
      ierr = l
      return
    end if

    j = j + 1
!
!  Form shift.
!
    g = ( d(l+1) - p ) / ( 2.0D+00 * e(l) )
    r = pythag ( g, 1.0D+00 )
    g = d(m) - p + e(l) / ( g + sign ( r, g ) )
    s = 1.0D+00
    c = 1.0D+00
    p = 0.0D+00
    mml = m - l

    do ii = 1, mml

      i = m - ii
      f = s * e(i)
      b = c * e(i)
      r = pythag ( f, g )
      e(i+1) = r
!
!  Recover from underflow.
!
      if ( r == 0.0D+00 ) then
        d(i+1) = d(i+1) - p
        e(m) = 0.0D+00
        go to 105
      end if

      s = f / r
      c = g / r
      g = d(i+1) - p
      r = ( d(i) - g ) * s + 2.0D+00 * c * b
      p = s * r
      d(i+1) = g + p
      g = c * r - b

    end do

    d(l) = d(l) - p
    e(l) = g
    e(m) = 0.0D+00
    go to 105
!
!  Order the eigenvalues.
!
215 continue

    do ii = 2, l
      i = l + 2 - ii
      if ( d(i-1) <= p ) then
        go to 270
      end if
      d(i) = d(i-1)
    end do

    i = 1

270 continue

    d(i) = p

  end do

  return
end subroutine imtql1

subroutine imtql2 ( n, d, e, z, ierr )

!*****************************************************************************80
!
!! IMTQL2 computes all eigenvalues/vectors of a symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors
!    of a symmetric tridiagonal matrix by the implicit QL method.
!    The eigenvectors of a full symmetric matrix can also
!    be found if TRED2 has been used to reduce this
!    full matrix to tridiagonal form.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) D(N).  On input, the diagonal elements of
!    the input matrix.  On output, the eigenvalues in ascending order.  If an
!    error exit is made, the eigenvalues are correct but
!    unordered for indices 1,2,...,IERR-1.
!
!    Input/output, real (dp) E(N).  On input, the subdiagonal elements
!    of the input matrix in E(2:N).  E(1) is arbitrary.  On output, E is
!    overwritten.
!
!    Input/output, real (dp) Z(N,N).  On input, the transformation
!    matrix produced in the reduction by TRED2, if performed.  If the
!    eigenvectors of the tridiagonal matrix are desired, Z must contain the
!    identity matrix.  On output, Z contains orthonormal eigenvectors of the
!    symmetric tridiagonal (or full) matrix.  If an error exit is made, Z
!    contains the eigenvectors associated with the stored eigenvalues.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the J-th eigenvalue has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) b
  real (dp) c
  real (dp) d(n)
  real (dp) e(n)
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) s
  real (dp) t(n)
  real (dp) tst1
  real (dp) tst2
  real (dp) z(n,n)

  ierr = 0

  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    e(i-1) = e(i)
  end do
  e(n) = 0.0D+00

  do l = 1, n

    j = 0
!
!  Look for a small sub-diagonal element.
!
105 continue

    do m = l, n

      if ( m == n ) then
        exit
      end if

      tst1 = abs ( d(m) ) + abs ( d(m+1) )
      tst2 = tst1 + abs ( e(m) )

      if ( tst2 == tst1 ) then
        exit
      end if

    end do

    p = d(l)

    if ( m == l ) then
      cycle
    end if

    if ( 30 <= j ) then
      ierr = l
      return
    end if

    j = j + 1
!
!  Form shift.
!
    g = ( d(l+1) - p ) / ( 2.0D+00 * e(l) )
    r = pythag ( g, 1.0D+00 )
    g = d(m) - p + e(l) / ( g + sign ( r, g ) )
    s = 1.0D+00
    c = 1.0D+00
    p = 0.0D+00
    mml = m - l

    do ii = 1, mml

      i = m - ii
      f = s * e(i)
      b = c * e(i)
      r = pythag ( f, g )
      e(i+1) = r
!
!  Recover from underflow.
!
      if ( r == 0.0D+00 ) then
        d(i+1) = d(i+1) - p
        e(m) = 0.0D+00
        go to 105
      end if

      s = f / r
      c = g / r
      g = d(i+1) - p
      r = ( d(i) - g ) * s + 2.0D+00 * c * b
      p = s * r
      d(i+1) = g + p
      g = c * r - b
!
!  Form vector.
!
      do k = 1, n
        f = z(k,i+1)
        z(k,i+1) = s * z(k,i) + c * f
        z(k,i) = c * z(k,i) - s * f
      end do

    end do

    d(l) = d(l) - p
    e(l) = g
    e(m) = 0.0D+00
    go to 105

  end do
!
!  Order eigenvalues and eigenvectors.
!
  do ii = 2, n

    i = ii - 1
    k = i
    p = d(i)

    do j = ii, n
      if ( d(j) < p ) then
        k = j
        p = d(j)
      end if
    end do

    if ( k /= i ) then

      d(k) = d(i)
      d(i) = p

      t(1:n)   = z(1:n,i)
      z(1:n,i) = z(1:n,k)
      z(1:n,k) = t(1:n)

    end if

  end do

  return
end subroutine imtql2

subroutine imtqlv ( n, d, e, e2, w, ind, ierr )

!*****************************************************************************80
!
!! IMTQLV computes all eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a symmetric tridiagonal
!    matrix by the implicit QL method and associates with them
!    their corresponding submatrix indices.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) D(N), the diagonal elements of the input matrix.
!
!    Input, real (dp) E(N), the subdiagonal elements of the input matrix
!    in E(2:N).  E(1) is arbitrary.
!
!    Input/output, real (dp) E2(N).  On input, the squares of the
!    corresponding elements of E.  E2(1) is arbitrary.  On output, elements of 
!    E2 corresponding to elements of E regarded as negligible have been
!    replaced by zero, causing the matrix to split into a direct sum of
!    submatrices.  E2(1) is also set to zero.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.  If an
!    error exit is made, the eigenvalues are correct and ordered for
!    indices 1,2,...IERR-1, but may not be the smallest eigenvalues.
!
!    Output, integer ( i4 ) IND(N), the submatrix indices associated with 
!    the corresponding eigenvalues in W: 1 for eigenvalues belonging to the
!    first submatrix from the top, 2 for those belonging to the second
!    submatrix, and so on.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the J-th eigenvalue has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) b
  real (dp) c
  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ind(n)
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
!  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) rv1(n)
  real (dp) s
  integer ( i4 ) tag
  real (dp) tst1
  real (dp) tst2
  real (dp) w(n)

  ierr = 0
  k = 0
  tag = 0
  w(1:n) = d(1:n)
  e2(1) = 0.0D+00
  rv1(1:n-1) = e(2:n)
  rv1(n) = 0.0D+00

  do l = 1, n

    j = 0
!
!  Look for a small sub-diagonal element.
!
105 continue

     do m = l, n

       if ( m == n ) then
         exit
       end if

       tst1 = abs ( w(m) ) + abs ( w(m+1) )
       tst2 = tst1 + abs ( rv1(m) )

       if ( tst2 == tst1 ) then
         exit
       end if
!
!  Guard against underflowed element of E2.
!
       if ( e2(m+1) == 0.0D+00 ) then
         go to 125
       end if

     end do

120  continue

     if ( m <= k ) then
       go to 130
     end if

     if ( m /= n ) then
       e2(m+1) = 0.0D+00
     end if

125  continue

     k = m
     tag = tag + 1

130  continue

     p = w(l)

     if ( m == l ) then
       go to 215
     end if

     if ( 30 <= j ) then
       ierr = l
       return
     end if

     j = j + 1
!
!  Form shift.
!
     g = ( w(l+1) - p ) / ( 2.0D+00 * rv1(l) )
     r = pythag ( g, 1.0D+00 )
     g = w(m) - p + rv1(l) / ( g + sign ( r, g ) )
     s = 1.0D+00
     c = 1.0D+00
     p = 0.0D+00
     mml = m - l

     do ii = 1, mml
       i = m - ii
       f = s * rv1(i)
       b = c * rv1(i)
       r = pythag ( f, g )
       rv1(i+1) = r

       if ( r == 0.0D+00 ) then
         go to 210
       end if

       s = f / r
       c = g / r
       g = w(i+1) - p
       r = ( w(i) - g ) * s + 2.0D+00 * c * b
       p = s * r
       w(i+1) = g + p
       g = c * r - b
     end do

     w(l) = w(l) - p
     rv1(l) = g
     rv1(m) = 0.0D+00
     go to 105
!
!  Recover from underflow.
!
210  continue

     w(i+1) = w(i+1) - p
     rv1(m) = 0.0D+00
     go to 105
!
!  Order the eigenvalues.
!
215  continue

     do ii = 2, l
        i = l + 2 - ii
        if ( w(i-1) <= p ) then
          go to 270
        end if
        w(i) = w(i-1)
        ind(i) = ind(i-1)
     end do

     i = 1

  270   continue

     w(i) = p
     ind(i) = tag

  end do

  return
end subroutine imtqlv

subroutine invit ( n, a, wr, wi, select, mm, m, z, ierr )

!*****************************************************************************80
!
!! INVIT computes eigenvectors of a real upper Hessenberg matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvectors of a real upper Hessenberg
!    matrix corresponding to specified eigenvalues, using inverse iteration.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), the Hessenberg matrix.
!
!    Input/output, real (dp) WR(N), WI(N).  On input, the real and 
!    imaginary parts, respectively, of the eigenvalues of the matrix.  The 
!    eigenvalues must be stored in a manner identical to that of subroutine HQR,
!    which recognizes possible splitting of the matrix.  On output,
!    WR may have been altered since close eigenvalues are perturbed
!    slightly in searching for independent eigenvectors.
!
!    Input/output, logical SELECT(N).  On input, specifies the eigenvectors
!    to be found.  The eigenvector corresponding to the J-th eigenvalue is
!    specified by setting SELECT(J) to TRUE.  On output, SELECT may have been
!    altered.  If the elements corresponding to a pair of conjugate complex
!    eigenvalues were each initially set to TRUE, the program resets the
!    second of the two elements to FALSE.
!
!    Input, integer ( i4 ) MM, an upper bound for the number of columns
!    required to store the eigenvectors to be found.  Note that two columns are
!    required to store the eigenvector corresponding to a complex eigenvalue.
!
!    Input, integer ( i4 ) M, the number of columns actually used to store
!    the eigenvectors.
!
!    Output, real (dp) Z(N,MM), the real and imaginary parts of the 
!    eigenvectors.  If the next selected eigenvalue is real, the next column
!    of Z contains its eigenvector.  If the eigenvalue is complex, the next
!    two columns of Z contain the real and imaginary parts of its eigenvector.
!    The eigenvectors are normalized so that the component of largest
!    magnitude is 1.  Any vector which fails the acceptance test is set to zero.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    -(2*N+1), if more than MM columns of Z are necessary to store the
!      eigenvectors corresponding to the specified eigenvalues.
!    -K, if the iteration corresponding to the K-th value fails,
!    -(N+K), if both error situations occur.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) eps3
  real (dp) growto
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  real (dp) ilambd
  integer ( i4 ) ip
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) km1
  integer ( i4 ) l
  integer ( i4 ) m
  integer ( i4 ) mm
  integer ( i4 ) mp
  integer ( i4 ) n1
  real (dp) norm
  real (dp) normv
  integer ( i4 ) ns
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) rlambd
  real (dp) rm1(n,n)
  real (dp) rv1(n)
  real (dp) rv2(n)
  integer ( i4 ) s
  logical select(n)
  real (dp) t
  integer ( i4 ) uk
  real (dp) ukroot
  real (dp) w
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) x
  real (dp) y
  real (dp) z(n,mm)

  ierr = 0
  uk = 0
  s = 1
!
!  The value of IP is:
!
!   0, real eigenvalue;
!   1, first of conjugate complex pair;
!  -1, second of conjugate complex pair.
!
  ip = 0
  n1 = n - 1

  do k = 1, n

     if ( wi(k) /= 0.0D+00 .and. 0 <= ip ) then
       ip = 1
       if ( select(k) .and. select(k+1) ) then
         select(k+1) = .false.
       end if
     end if

     if ( .not. select(k) ) then
       go to 960
     end if

     if ( wi(k) /= 0.0D+00 ) then
       s = s + 1
     end if

     if ( mm < s ) then
       go to 1000
     end if

     if ( k <= uk ) then
       go to 200
     end if
!
!  Check for possible splitting.
!
     do uk = k, n
       if ( uk == n ) then
         exit
       end if
       if ( a(uk+1,uk) == 0.0D+00 ) then
         exit
       end if
     end do
!
!  Compute infinity norm of leading UK by UK (Hessenberg) matrix.
!
     norm = 0.0D+00
     mp = 1

     do i = 1, uk

       x = sum ( abs ( a(i,mp:uk) ) )
       norm = max ( norm, x )
       mp = i

     end do
!
!  EPS3 replaces zero pivot in decomposition and close roots are modified
!  by EPS3.
!
     if ( norm == 0.0D+00 ) then
       norm = 1.0D+00
     end if

     eps3 = abs ( norm ) * epsilon ( eps3 )
!
!  GROWTO is the criterion for the growth.
!
     ukroot = uk
     ukroot = sqrt ( ukroot )
     growto = 0.1D+00 / ukroot

200  continue

     rlambd = wr(k)
     ilambd = wi(k)

     if ( k == 1 ) then
       go to 280
     end if

     km1 = k - 1
     go to 240
!
!  Perturb eigenvalue if it is close to any previous eigenvalue.
!
220 continue

     rlambd = rlambd + eps3

240  continue

     do ii = 1, km1
       i = k - ii
       if ( select(i) .and. &
            abs ( wr(i) - rlambd ) < eps3 .and. &
            abs ( wi(i) - ilambd ) < eps3 ) then
        go to 220
       end if
     end do

     wr(k) = rlambd
!
!  Perturb conjugate eigenvalue to match.
!
     wr(k+ip) = rlambd
!
!  Form upper Hessenberg A - rlambd*I (transposed) and initial real vector.
!
280  continue

     mp = 1

     do i = 1, uk

        rm1(mp:uk,i) = a(i,mp:uk)

        rm1(i,i) = rm1(i,i) - rlambd
        mp = i
        rv1(i) = eps3

     end do

     its = 0

     if ( ilambd /= 0.0D+00 ) then
       go to 520
     end if
!
!  Real eigenvalue.
!
!  Triangular decomposition with interchanges, replacing zero pivots by eps3.
!
     do i = 2, uk

        mp = i - 1

        if ( abs ( rm1(mp,i) ) > abs ( rm1(mp,mp) ) ) then

          do j = mp, uk
            call r8_swap ( rm1(j,i), rm1(j,mp) )
          end do

        end if

        if ( rm1(mp,mp) == 0.0D+00 ) then
          rm1(mp,mp) = eps3
        end if

        x = rm1(mp,i) / rm1(mp,mp)

        if ( x /= 0.0D+00 ) then
          rm1(i:uk,i) = rm1(i:uk,i) - x * rm1(i:uk,mp)
        end if

      end do

      if ( rm1(uk,uk) == 0.0D+00 ) then
        rm1(uk,uk) = eps3
      end if
!
!  Back substitution for real vector.
!
440   continue

      do ii = 1, uk

        i = uk + 1 - ii
        y = rv1(i)

        do j = i + 1, uk
          y = y - rm1(j,i) * rv1(j)
        end do

        rv1(i) = y / rm1(i,i)

     end do

     go to 740
!
!  Complex eigenvalue.
!
!  Triangular decomposition with interchanges,
!  replacing zero pivots by EPS3.
!  Store imaginary parts in upper triangle starting at (1,3)
!
520  continue

     ns = n - s
     z(1,s-1) = - ilambd
     z(1,s) = 0.0D+00

     if ( n /= 2 ) then
       rm1(1,3) = - ilambd
       z(1,s-1) = 0.0D+00
       rm1(1,4:n) = 0.0D+00
     end if

     do i = 2, uk

        mp = i - 1
        w = rm1(mp,i)

        if ( i < n ) then
          t = rm1(mp,i+1)
        else if ( i == n ) then
          t = z(mp,s-1)
        end if

        x = rm1(mp,mp) * rm1(mp,mp) + t * t

        if ( w * w <= x ) then
          go to 580
        end if

        x = rm1(mp,mp) / w
        y = t / w
        rm1(mp,mp) = w

        if ( i < n ) then
          rm1(mp,i+1) = 0.0D+00
        else if ( i == n ) then
          z(mp,s-1) = 0.0D+00
        end if

        do j = i, uk

          w = rm1(j,i)
          rm1(j,i) = rm1(j,mp) - x * w
          rm1(j,mp) = w

          if ( n1 <= j ) then
            l = j - ns
            z(i,l) = z(mp,l) - y * w
            z(mp,l) = 0.0D+00
          else
            rm1(i,j+2) = rm1(mp,j+2) - y * w
            rm1(mp,j+2) = 0.0D+00
          end if

        end do

        rm1(i,i) = rm1(i,i) - y * ilambd

        if ( n1 <= i ) then
          l = i - ns
          z(mp,l) = -ilambd
          z(i,l) = z(i,l) + x * ilambd
        else
          rm1(mp,i+2) = -ilambd
          rm1(i,i+2) = rm1(i,i+2) + x * ilambd
        end if

        go to 640

580     continue

        if ( x == 0.0D+00 ) then
          rm1(mp,mp) = eps3
          if ( i < n ) then
            rm1(mp,i+1) = 0.0D+00
          else if ( i == n ) then
            z(mp,s-1) = 0.0D+00
          end if
          t = 0.0D+00
          x = eps3**2
        end if

        w = w / x
        x = rm1(mp,mp) * w
        y = - t * w

        do j = i, uk

          if ( n1 <= j ) then
            l = j - ns
            t = z(mp,l)
            z(i,l) = - x * t - y * rm1(j,mp)
          else
            t = rm1(mp,j+2)
            rm1(i,j+2) = - x * t - y * rm1(j,mp)
          end if

          rm1(j,i) = rm1(j,i) - x * rm1(j,mp) + y * t

        end do

        if ( n1 <= i ) then
          l = i - ns
          z(i,l) = z(i,l) - ilambd
        else
          rm1(i,i+2) = rm1(i,i+2) - ilambd
        end if

640    continue

     end do

     if ( n1 <= uk ) then
       l = uk - ns
       t = z(uk,l)
     else
       t = rm1(uk,uk+2)
     end if

     if ( rm1(uk,uk) == 0.0D+00 .and. t == 0.0D+00 ) then
       rm1(uk,uk) = eps3
     end if
!
!  Back substitution for complex vector.
!
660  continue

     do ii = 1, uk

        i = uk + 1 - ii
        x = rv1(i)
        y = 0.0D+00

        do j = i + 1, uk

          if ( j >= n1 ) then
            t = z(i,j-ns)
          else
            t = rm1(i,j+2)
          end if

          x = x - rm1(j,i) * rv1(j) + t * rv2(j)
          y = y - rm1(j,i) * rv2(j) - t * rv1(j)

        end do

        if ( i >= n1 ) then
          t = z(i,i-ns)
        else
          t = rm1(i,i+2)
        end if

       call cdiv ( x, y, rm1(i,i), t, rv1(i), rv2(i) )

     end do
!
!  Acceptance test for real or complex eigenvector and normalization.
!
740  continue

     its = its + 1
     norm = 0.0D+00
     normv = 0.0D+00

     do i = 1, uk

       if ( ilambd == 0.0D+00 ) then
         x = abs ( rv1(i) )
       else
         x = pythag ( rv1(i), rv2(i) )
       end if

       if ( normv < x )  then
         normv = x
         j = i
       end if

       norm = norm + x

     end do

     if ( norm < growto ) then
       go to 840
     end if
!
!  Accept vector.
!
     x = rv1(j)
     if ( ilambd == 0.0D+00 ) then
       x = 1.0D+00 / x
     else
       y = rv2(j)
     end if

     do i = 1, uk
       if ( ilambd == 0.0D+00 ) then
         z(i,s) = rv1(i) * x
       else
         call cdiv ( rv1(i), rv2(i), x, y, z(i,s-1), z(i,s) )
       end if
     end do

     if ( uk == n ) then
       go to 940
     end if

     j = uk + 1
     go to 900
!
!  Choose a new starting vector.
!
840  continue

     if ( its >= uk ) then
       go to 880
     end if

     x = ukroot
     y = eps3 / ( x + 1.0D+00 )

     rv1(1) = eps3
     rv1(2:uk) = y

     j = uk - its + 1
     rv1(j) = rv1(j) - eps3 * x
     if ( ilambd == 0.0D+00 ) then
       go to 440
     end if
     go to 660
!
!  Set error: unaccepted eigenvector.
!
880  continue

     j = 1
     ierr = - k
!
!  Set remaining vector components to zero.
!
900  continue

     do i = j, n
       z(i,s) = 0.0D+00
       if ( ilambd /= 0.0D+00 ) then
         z(i,s-1) = 0.0D+00
       end if
     end do

940  continue

     s = s + 1

960  continue

     if ( ip == (-1) ) then
       ip = 0
     end if

     if ( ip == 1 ) then
       ip = -1
     end if

  end do

  go to 1001
!
!  Set error: underestimate of eigenvector space required.
!
1000 continue

  if ( ierr /= 0 ) then
    ierr = ierr - n
  end if

  if ( ierr == 0 ) then
    ierr = - ( 2 * n + 1 )
  end if

1001 continue

  m = s - 1 - abs ( ip )

  return
end subroutine invit

subroutine minfit ( nm, m, n, a, w, ip, b, ierr )

!*****************************************************************************80
!
!! MINFIT: least squares problem for a real overdetermined linear system.
!
!  Discussion:
!
!    This subroutine is part of an algorithm for solving general linear
!    systems of the form A*X=B.
!
!    It determines the singular value decomposition
!      A = U * S * V'
!    of a real M by N rectangular matrix, forming U' * B
!    rather than U.  Householder bidiagonalization and a variant of the
!    QR algorithm are used.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) NM, the leading dimension of the
!    two-dimensional arrays.  NM must be at least as large as the maximum
!    of M and N.
!
!    Input, integer ( i4 ) M, the number of rows of A and B.
!
!    Input, integer ( i4 ) N, the number of columns of A, and the order
!    of V.
!
!    Input/output, real (dp) A(NM,N). On input, the rectangular
!    coefficient matrix.  On output, A has been overwritten by the orthogonal
!    matrix V of the decomposition in its first N rows and columns.  If an
!    error exit is made, the columns of V corresponding to indices of correct
!    singular values should be correct.
!
!    Output, real (dp) W(N), the singular values of A.  These are 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.
!
!    Input, integer ( i4 ) IP, is the number of columns of B.  IP can
!    be zero.
!
!    Input/output, real (dp) B(NM,IP).  On input, the constant column
!    matrix.  On output, B has been overwritten by U'*B.  If an error exit is
!    made, the rows of U'*B corresponding to indices of correct singular values
!    should be correct.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    K, if the K-th singular value has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) ip
  integer ( i4 ) n
  integer ( i4 ) nm

  real (dp) a(nm,n)
  real (dp) b(nm,ip)
  real (dp) c
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) i1
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) k1
  integer ( i4 ) kk
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) ll
  integer ( i4 ) m
  integer ( i4 ) m1
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) rv1(n)
  real (dp) s
  real (dp) scale
  real (dp) tst1
  real (dp) tst2
  real (dp) w(n)
  real (dp) x
  real (dp) y
  real (dp) z

  ierr = 0
!
!  Householder reduction to bidiagonal form.
!
  g = 0.0D+00
  scale = 0.0D+00
  x = 0.0D+00

  do i = 1, n

    l = i + 1
    rv1(i) = scale * g
    g = 0.0D+00
    s = 0.0D+00
    scale = 0.0D+00

    if ( i <= m ) then

      scale = sum ( abs ( a(i:m,i) ) )

      if ( scale /= 0.0D+00 ) then

        a(i:m,i) = a(i:m,i) / scale

        s = s + sum ( a(i:m,i)**2 )

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

        do j = l, n

          s = dot_product ( a(i:m,i), a(i:m,j) )

          f = s / h
          a(i:m,j) = a(i:m,j) + f * a(i:m,i)

        end do

        do j = 1, ip

          s = dot_product ( a(i:m,i), b(i:m,j) )

          b(i:m,j) = b(i:m,j) + s * a(i:m,i) / h

        end do

        a(i:m,i) = scale * a(i:m,i)

      end if

    end if

    w(i) = scale * g
    g = 0.0D+00
    s = 0.0D+00
    scale = 0.0D+00

    if ( i <= m .and. i /= n ) then

      scale = scale + sum ( abs ( a(i,l:n) ) )

      if ( scale /= 0.0D+00 ) then

        a(i,l:n) = a(i,l:n) / scale

        s = s + sum ( a(i,l:n)**2 )

        f = a(i,l)
        g = - sign ( sqrt ( s ), f )
        h = f * g - s
        a(i,l) = f - g
        rv1(l:n) = a(i,l:n) / h

        do j = l, m

          s = dot_product ( a(j,l:n), a(i,l:n) )

          a(j,l:n) = a(j,l:n) + s * rv1(l:n)

        end do

        a(i,l:n) = scale * a(i,l:n)

      end if

    end if

    x = max ( x, abs ( w(i) ) + abs ( rv1(i) ) )

  end do
!
!  Accumulation of right-hand transformations.
!
  do ii = 1, n

    i = n + 1 - ii

    if ( i /= n ) then

      if ( g /= 0.0D+00 ) then

        a(l:n,i) = ( a(i,l:n) / a(i,l) ) / g

        do j = l, n

          s = dot_product ( a(i,l:n), a(l:n,j) )

          a(l:n,j) = a(l:n,j) + s * a(l:n,i)

        end do

      end if

      a(i,l:n) = 0.0D+00
      a(l:n,i) = 0.0D+00

    end if

    a(i,i) = 1.0D+00
    g = rv1(i)
    l = i

  end do

  if ( m < n .and. ip /= 0 ) then
    m1 = m + 1
    b(m+1:n,1:ip) = 0.0D+00
  end if
!
!  Diagonalization of the bidiagonal form.
!
  tst1 = x

  do kk = 1, n

    k1 = n - kk
    k = k1 + 1
    its = 0
!
!  Test for splitting.
!
520 continue

    do ll = 1, k

      l1 = k - ll
      l = l1 + 1
      tst2 = tst1 + abs ( rv1(l) )

      if ( tst2 == tst1 ) then
        go to 565
      end if

      tst2 = tst1 + abs ( w(k-ll) )

      if ( tst2 == tst1 ) then
        exit
      end if

    end do
!
!  Cancellation of RV1(l) if l greater than 1.
!
540 continue

    c = 0.0D+00
    s = 1.0D+00

    do i = l, k

      f = s * rv1(i)
      rv1(i) = c * rv1(i)
      tst2 = tst1 + abs ( f)

      if ( tst2 == tst1 ) then
        exit
      end if

      g = w(i)
      h = pythag ( f, g )
      w(i) = h
      c = g / h
      s = -f / h

      do j = 1, ip
        y = b(l1,j)
        z = b(i,j)
        b(l1,j) = y * c + z * s
        b(i,j) = -y * s + z * c
      end do

    end do
!
!  Test for convergence.
!
565 continue

    z = w(k)

    if ( l == k ) then
      go to 650
    end if
!
!  Shift from bottom 2 by 2 minor.
!
     if ( its >= 30 ) then
       ierr = k
       return
     end if

     its = its + 1
     x = w(l)
     y = w(k1)
     g = rv1(k1)
     h = rv1(k)
     f = 0.5D+00 * ( ( ( g + z ) / h ) * ( ( g - z ) / y ) + y / h - h / y )
     g = pythag ( f, 1.0D+00 )
     f = x - ( z / x ) * z + ( h / x ) * ( y / ( f + sign ( g, f ) ) - h )
!
!  Next QR transformation.
!
     c = 1.0D+00
     s = 1.0D+00

     do i1 = l, k1

        i = i1 + 1
        g = rv1(i)
        y = w(i)
        h = s * g
        g = c * g
        z = pythag ( f, 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

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

        z = pythag ( f, h )
        w(i1) = z

        if ( z /= 0.0D+00 ) then
          c = f / z
          s = h / z
        end if

        f = c * g + s * y
        x = -s * g + c * y

        do j = 1, ip
          y = b(i1,j)
          z = b(i,j)
          b(i1,j) = y * c + z * s
          b(i,j) = -y * s + z * c
        end do

     end do

     rv1(l) = 0.0D+00
     rv1(k) = f
     w(k) = x
     go to 520
!
!  Convergence.
!
650 continue

    if ( z < 0.0D+00 ) then
      w(k) = - z
      a(1:n,k) = - a(1:n,k)
    end if

  end do

  return
end subroutine minfit

subroutine ortbak ( n, low, igh, a, ort, m, z )

!*****************************************************************************80
!
!! ORTBAK determines eigenvectors by undoing the ORTHES transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a real general
!    matrix by back transforming those of the corresponding
!    upper Hessenberg matrix determined by ORTHES.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine BALANC.  If BALANC has not been used, set LOW = 1 and IGH equal
!    to the order of the matrix.
!
!    Input, real (dp) A(N,IGH), contains information about the 
!    orthogonal transformations used in the reduction by ORTHES in its strict
!    lower triangle.
!
!    Input/output, real (dp) ORT(IGH), contains further information
!    about the transformations used in the reduction by ORTHES.  On output, ORT
!    has been altered.
!
!    Input, integer ( i4 ) M, the number of columns of Z to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,N).  On input, the real and imaginary
!    parts of the eigenvectors to be back transformed in the first M columns.
!    On output, the real and imaginary parts of the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(n,igh)
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) low
  integer ( i4 ) mp
  real (dp) ort(igh)
  real (dp) z(n,m)

  if ( m == 0 ) then
    return
  end if

  do mp = igh - 1, low + 1, -1

    if ( a(mp,mp-1) /= 0.0D+00 ) then

      ort(mp+1:igh) = a(mp+1:igh,mp-1)

      do j = 1, m

        g = dot_product ( ort(mp:igh), z(mp:igh,j) )

        g = ( g / ort(mp) ) / a(mp,mp-1)

        do i = mp, igh
          z(i,j) = z(i,j) + g * ort(i)
        end do

      end do

    end if

  end do

  return
end subroutine ortbak

subroutine orthes ( n, low, igh, a, ort )

!*****************************************************************************80
!
!! ORTHES transforms a real general matrix to upper Hessenberg form.
!
!  Discussion:
!
!    Given a real general matrix, this subroutine reduces a submatrix
!    situated in rows and columns LOW through IGH to upper Hessenberg form by
!    orthogonal similarity transformations.
!
!  Modified:
!
!    04 February 2003
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine BALANC.  If BALANC has not been used, set LOW = 1 and IGH = N.
!
!    Input/output, real (dp) A(N,N).  On input, the matrix.  On output,
!    the Hessenberg matrix.  Information about the orthogonal transformations
!    used in the reduction is stored in the remaining triangle under the
!    Hessenberg matrix.
!
!    Output, real (dp) ORT(IGH), contains further information about the
!    transformations.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) la
  integer ( i4 ) low
  integer ( i4 ) m
  integer ( i4 ) mp
  real (dp) ort(igh)
  real (dp) scale

  la = igh - 1

  do m = low + 1, la

     h = 0.0D+00
     ort(m) = 0.0D+00
     scale = 0.0D+00
!
!  Scale the column.
!
     do i = m, igh
       scale = scale + abs ( a(i,m-1) )
     end do

     if ( scale /= 0.0D+00 ) then

     mp = m + igh

     do ii = m, igh
       i = mp - ii
       ort(i) = a(i,m-1) / scale
       h = h + ort(i) * ort(i)
     end do

     g = - sign ( sqrt ( h ), ort(m) )
     h = h - ort(m) * g
     ort(m) = ort(m) - g
!
!  Form (I-(U*Ut)/h) * A.
!
     do j = m, n

        f = 0.0D+00

        do ii = m, igh
          i = mp - ii
          f = f + ort(i) * a(i,j)
        end do

        f = f / h

        do i = m, igh
          a(i,j) = a(i,j) - f * ort(i)
        end do

     end do
!
!  Form (I-(u*ut)/h) * A * (I-(u*ut)/h).
!
     do i = 1, igh

        f = 0.0D+00
        do jj = m, igh
          j = mp - jj
          f = f + ort(j) * a(i,j)
        end do

        a(i,m:igh) = a(i,m:igh) - f * ort(m:igh) / h

     end do

     ort(m) = scale * ort(m)
     a(m,m-1) = scale * g

    end if

  end do

  return
end subroutine orthes

subroutine ortran ( n, low, igh, a, ort, z )

!*****************************************************************************80
!
!! ORTRAN accumulates similarity transformations generated by ORTHES.
!
!  Discussion:
!
!    This subroutine accumulates the orthogonal similarity
!    transformations used in the reduction of a real general
!    matrix to upper Hessenberg form by ORTHES.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) LOW, IGH, are determined by the balancing
!    routine BALANC.  If BALANC has not been used, set LOW = 1, IGH = N.
!
!    Input, real (dp) A(N,IGH), contains information about the 
!    orthogonal transformations used in the reduction by ORTHES in its strict 
!    lower triangle.
!
!    Input/output, real (dp) ORT(IGH), contains further information
!    about the transformations used in the reduction by ORTHES.  On output, ORT
!    has been further altered.
!
!    Output, real (dp) Z(N,N), contains the transformation matrix
!    produced in the reduction by ORTHES.
!
  implicit none

  integer ( i4 ) igh
  integer ( i4 ) n

  real (dp) a(n,igh)
  real (dp) g
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) kl
  integer ( i4 ) low
  integer ( i4 ) mm
  integer ( i4 ) mp
  real (dp) ort(igh)
  real (dp) z(n,n)
!
!  Initialize Z to the identity matrix.
!
  z(1:n,1:n) = 0.0D+00

  do i = 1, n
    z(i,i) = 1.0D+00
  end do

  kl = igh - low - 1

  if ( kl < 1 ) then
    return
  end if

  do mm = 1, kl

    mp = igh - mm

    if ( a(mp,mp-1) /= 0.0D+00 ) then

      ort(mp+1:igh) = a(mp+1:igh,mp-1)

      do j = mp, igh

        g = dot_product ( ort(mp:igh), z(mp:igh,j) )

        g = ( g / ort(mp) ) / a(mp,mp-1)

        z(mp:igh,j) = z(mp:igh,j) + g * ort(mp:igh)

      end do

    end if

  end do

  return
end subroutine ortran

subroutine qzhes ( n, a, b, matz, z )

!*****************************************************************************80
!
!! QZHES carries out transformations for a generalized eigenvalue problem.
!
!  Discussion:
!
!    This subroutine is the first step of the QZ algorithm
!    for solving generalized matrix eigenvalue problems.
!
!    This subroutine accepts a pair of real general matrices and
!    reduces one of them to upper Hessenberg form and the other
!    to upper triangular form using orthogonal transformations.
!    it is usually followed by QZIT, QZVAL and, possibly, QZVEC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices.
!
!    Input/output, real (dp) A(N,N).  On input, the first real general
!    matrix.  On output, A has been reduced to upper Hessenberg form.  The
!    elements below the first subdiagonal have been set to zero.
!
!    Input/output, real (dp) B(N,N).  On input, a real general matrix.
!    On output, B has been reduced to upper triangular form.  The elements
!    below the main diagonal have been set to zero.
!
!    Input, logical MATZ, should be TRUE if the right hand transformations
!    are to be accumulated for later use in computing eigenvectors.
!
!    Output, real (dp) Z(N,N), contains the product of the right hand
!    transformations if MATZ is TRUE.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) lb
  logical matz
  integer ( i4 ) nk1
  integer ( i4 ) nm1
  real (dp) r
  real (dp) rho
  real (dp) s
  real (dp) t
  real (dp) u1
  real (dp) u2
  real (dp) v1
  real (dp) v2
  real (dp) z(n,n)
!
!  Set Z to the identity matrix.
!
  if ( matz ) then

    z(1:n,1:n) = 0.0D+00

    do i = 1, n
      z(i,i) = 1.0D+00
    end do

  end if
!
!  Reduce B to upper triangular form.
!
  if ( n <= 1 ) then
    return
  end if

  nm1 = n - 1

  do l = 1, n - 1

    l1 = l + 1

    s = sum ( abs ( b(l+1:n,l) ) )

    if ( s /= 0.0D+00 ) then

      s = s + abs ( b(l,l) )
      b(l:n,l) = b(l:n,l) / s

      r = sqrt ( sum ( b(l:n,l)**2 ) )
      r = sign ( r, b(l,l) )
      b(l,l) = b(l,l) + r
      rho = r * b(l,l)

      do j = l + 1, n

        t = dot_product ( b(l:n,l), b(l:n,j) )

        b(l:n,j) = b(l:n,j) - t * b(l:n,l) / rho

      end do

      do j = 1, n

        t = dot_product ( b(l:n,l), a(l:n,j) )

        a(l:n,j) = a(l:n,j) - t * b(l:n,l) / rho

      end do

      b(l,l) = - s * r
      b(l+1:n,l) = 0.0D+00

    end if

  end do
!
!  Reduce A to upper Hessenberg form, while keeping B triangular.
!
  if ( n == 2 ) then
    return
  end if

  do k = 1, n - 2

     nk1 = nm1 - k

     do lb = 1, nk1

        l = n - lb
        l1 = l + 1
!
!  Zero A(l+1,k).
!
        s = abs ( a(l,k) ) + abs ( a(l1,k) )

        if ( s /= 0.0D+00 ) then

        u1 = a(l,k) / s
        u2 = a(l1,k) / s
        r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
        v1 = - ( u1 + r) / r
        v2 = - u2 / r
        u2 = v2 / v1

        do j = k, n
          t = a(l,j) + u2 * a(l1,j)
          a(l,j) = a(l,j) + t * v1
          a(l1,j) = a(l1,j) + t * v2
        end do

        a(l1,k) = 0.0D+00

        do j = l, n
          t = b(l,j) + u2 * b(l1,j)
          b(l,j) = b(l,j) + t * v1
          b(l1,j) = b(l1,j) + t * v2
        end do
!
!  Zero B(l+1,l).
!
        s = abs ( b(l1,l1) ) + abs ( b(l1,l) )

        if ( s /= 0.0 ) then

          u1 = b(l1,l1) / s
          u2 = b(l1,l) / s
          r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
          v1 =  -( u1 + r ) / r
          v2 = -u2 / r
          u2 = v2 / v1

          do i = 1, l1
            t = b(i,l1) + u2 * b(i,l)
            b(i,l1) = b(i,l1) + t * v1
            b(i,l) = b(i,l) + t * v2
          end do

          b(l1,l) = 0.0D+00

          do i = 1, n
            t = a(i,l1) + u2 * a(i,l)
            a(i,l1) = a(i,l1) + t * v1
            a(i,l) = a(i,l) + t * v2
          end do

          if ( matz ) then

            do i = 1, n
              t = z(i,l1) + u2 * z(i,l)
              z(i,l1) = z(i,l1) + t * v1
              z(i,l) = z(i,l) + t * v2
            end do

          end if

        end if

      end if

    end do

  end do

  return
end subroutine qzhes

subroutine qzit ( n, a, b, eps1, matz, z, ierr )

!*****************************************************************************80
!
!! QZIT carries out iterations to solve a generalized eigenvalue problem.
!
!  Discussion:
!
!    This subroutine is the second step of the QZ algorithm
!    for solving generalized matrix eigenvalue problems.
!
!    This subroutine accepts a pair of real matrices, one of them
!    in upper Hessenberg form and the other in upper triangular form.
!    It reduces the Hessenberg matrix to quasi-triangular form using
!    orthogonal transformations while maintaining the triangular form
!    of the other matrix.  It is usually preceded by QZHES and
!    followed by QZVAL and, possibly, QZVEC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices.
!
!    Input/output, real (dp) A(N,N).  On input, a real upper Hessenberg 
!    matrix.  On output, A has been reduced to quasi-triangular form.  The 
!    elements below the first subdiagonal are still zero and no two consecutive
!    subdiagonal elements are nonzero.
!
!    Input/output, real (dp) B(N,N).  On input, a real upper triangular 
!    matrix.  On output, B is still in upper triangular form, although its 
!    elements have been altered.  The location B(N,1) is used to store EPS1 
!    times the norm of B for later use by QZVAL and QZVEC.
!
!    Input, real (dp) EPS1, a tolerance used to determine negligible
!    elements.  EPS1 = 0.0 (or negative) may be input, in which case an element
!    will be neglected only if it is less than roundoff error times the
!    norm of its matrix.  If the input EPS1 is positive, then an element
!    will be considered negligible if it is less than EPS1 times the norm
!    of its matrix.  A positive value of EPS1 may result in faster execution,
!    but less accurate results.
!
!    Input, logical MATZ, should be TRUE if the right hand transformations
!    are to be accumulated for later use in computing eigenvectors.
!
!    Input/output, real (dp) Z(N,N).  If MATZ is FALSE, Z is not 
!    referenced.  Otherwise, on input, the transformation matrix produced in the
!    reduction by QZHES, if performed, or else the identity matrix.  On output, 
!    Z contains the product of the right hand transformations for both steps.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    J, if the limit of 30*N iterations is exhausted while the J-th
!      eigenvalue is being sought.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) a1
  real (dp) a11
  real (dp) a12
  real (dp) a2
  real (dp) a21
  real (dp) a22
  real (dp) a3
  real (dp) a33
  real (dp) a34
  real (dp) a43
  real (dp) a44
  real (dp) ani
  real (dp) anorm
  real (dp) b(n,n)
  real (dp) b11
  real (dp) b12
  real (dp) b22
  real (dp) b33
  real (dp) b34
  real (dp) b44
  real (dp) bni
  real (dp) bnorm
  integer ( i4 ) en
  integer ( i4 ) enm2
  integer ( i4 ) enorn
  real (dp) ep
  real (dp) eps1
  real (dp) epsa
  real (dp) epsb
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ish
  integer ( i4 ) itn
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) k1
  integer ( i4 ) k2
  integer ( i4 ) km1
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) ld
  integer ( i4 ) ll
  integer ( i4 ) lm1
  integer ( i4 ) lor1
  logical matz
  integer ( i4 ) na
  logical notlas
  real (dp) r
  real (dp) s
  real (dp) sh
  real (dp) t
  real (dp) u1
  real (dp) u2
  real (dp) u3
  real (dp) v1
  real (dp) v2
  real (dp) v3
  real (dp) z(n,n)

  ierr = 0
!
!  Compute EPSA and EPSB.
!
  anorm = 0.0D+00
  bnorm = 0.0D+00

  do i = 1, n

    if ( i == 1 ) then
      ani = 0.0D+00
    else
      ani = abs ( a(i,i-1) )
    end if

    bni = 0.0D+00

    do j = i, n
      ani = ani + abs ( a(i,j) )
      bni = bni + abs ( b(i,j) )
    end do

    anorm = max ( anorm, ani )
    bnorm = max ( bnorm, bni )

  end do

  if ( anorm == 0.0D+00 ) then
    anorm = 1.0D+00
  end if

  if ( bnorm == 0.0D+00 ) then
    bnorm = 1.0D+00
  end if

  ep = eps1

  if ( ep > 0.0D+00 ) then
    go to 50
  end if
!
!  Use roundoff level if EPS1 is 0.
!
  ep = epsilon ( ep )

50 continue

  epsa = ep * anorm
  epsb = ep * bnorm
!
!  Reduce A to quasi-triangular form, while keeping B triangular.
!
  lor1 = 1
  enorn = n
  en = n
  itn = 30 * n
!
!  Begin QZ step.
!
60 continue

  if ( en <= 2 ) then
    go to 1001
  end if

  if ( .not. matz ) then
    enorn = en
  end if

  its = 0
  na = en - 1
  enm2 = na - 1

70 continue

  ish = 2
!
!  Check for convergence or reducibility.
!
  do ll = 1, en
    lm1 = en - ll
    l = lm1 + 1
    if ( l == 1 ) then
      go to 95
    end if
    if ( abs ( a(l,lm1) ) <= epsa ) then
      exit
    end if
  end do

90 continue

  a(l,lm1) = 0.0D+00

  if ( l < na ) then
    go to 95
  end if
!
!  1-by-1 or 2-by-2 block isolated.
!
  en = lm1
  go to 60
!
!  Check for small top of B.
!
95 continue

  ld = l

100 continue

  l1 = l + 1
  b11 = b(l,l)

  if ( abs ( b11 ) > epsb ) then
    go to 120
  end if

  b(l,l) = 0.0D+00
  s = abs ( a(l,l) ) + abs ( a(l1,l) )
  u1 = a(l,l) / s
  u2 = a(l1,l) / s
  r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
  v1 = - ( u1 + r ) / r
  v2 = -u2 / r
  u2 = v2 / v1

  do j = l, enorn
    t = a(l,j) + u2 * a(l1,j)
    a(l,j) = a(l,j) + t * v1
    a(l1,j) = a(l1,j) + t * v2
    t = b(l,j) + u2 * b(l1,j)
    b(l,j) = b(l,j) + t * v1
    b(l1,j) = b(l1,j) + t * v2
  end do

  if ( l /= 1 ) then
    a(l,lm1) = -a(l,lm1)
  end if
  lm1 = l
  l = l1
  go to 90

120 continue

  a11 = a(l,l) / b11
  a21 = a(l1,l) / b11
  if ( ish == 1 ) then
    go to 140
  end if
!
!  Iteration strategy.
!
  if ( itn == 0 ) then
    go to 1000
  end if

  if ( its == 10 ) then
    go to 155
  end if
!
!  Determine type of shift.
!
  b22 = b(l1,l1)
  if ( abs ( b22 ) < epsb ) then
    b22 = epsb
  end if

  b33 = b(na,na)
  if ( abs ( b33 ) < epsb ) then
    b33 = epsb
  end if

  b44 = b(en,en)
  if ( abs ( b44 ) < epsb ) then
    b44 = epsb
  end if

  a33 = a(na,na) / b33
  a34 = a(na,en) / b44
  a43 = a(en,na) / b33
  a44 = a(en,en) / b44
  b34 = b(na,en) / b44
  t = 0.5D+00 * (a43 * b34 - a33 - a44)
  r = t * t + a34 * a43 - a33 * a44

  if ( r < 0.0D+00 ) then
    go to 150
  end if
!
!  Determine single shift zeroth column of A.
!
  ish = 1
  r = sqrt ( r )
  sh = -t + r
  s = -t - r
  if ( abs ( s - a44 ) < abs ( sh - a44 ) ) then
    sh = s
  end if
!
!  Look for two consecutive small sub-diagonal elements of A.
!
  do ll = ld, enm2
    l = enm2 + ld - ll
    if ( l == ld ) then
      exit
    end if
    lm1 = l - 1
    l1 = l + 1
    t = a(l,l)

    if ( abs ( b(l,l) ) > epsb ) then
      t = t - sh * b(l,l)
    end if

    if ( abs ( a(l,lm1) ) <= abs ( t / a(l1,l) ) * epsa ) then
      go to 100
    end if

  end do

140 continue

  a1 = a11 - sh
  a2 = a21

  if ( l /= ld ) then
    a(l,lm1) = -a(l,lm1)
  end if

  go to 160
!
!  Determine double shift zeroth column of A.
!
150 continue

  a12 = a(l,l1) / b22
  a22 = a(l1,l1) / b22
  b12 = b(l,l1) / b22
  a1 = ( ( a33 - a11 ) * ( a44 - a11 ) - a34 * a43 + a43 * b34 * a11 ) &
    / a21 + a12 - a11 * b12
  a2 = (a22 - a11) - a21 * b12 - (a33 - a11) - (a44 - a11) + a43 * b34
  a3 = a(l1+1,l1) / b22
  go to 160
!
!  Ad hoc shift.
!
155 continue

  a1 = 0.0D+00
  a2 = 1.0D+00
  a3 = 1.1605D+00

  160 continue
  its = its + 1
  itn = itn - 1
  if ( .not. matz ) then
    lor1 = ld
  end if
!
!  Main loop.
!
  do k = l, na

     notlas = ( k /= na .and. ish == 2 )
     k1 = k + 1
     k2 = k + 2
     km1 = max ( k - 1, l )
     ll = min ( en, k1 + ish )

     if ( notlas ) then
       go to 190
     end if
!
!  Zero A(k+1,k-1).
!
     if ( k /= l ) then
       a1 = a(k,km1)
       a2 = a(k1,km1)
     end if

     s = abs ( a1 ) + abs ( a2 )

     if ( s == 0.0D+00 ) then
       go to 70
     end if

     u1 = a1 / s
     u2 = a2 / s
     r = sign ( sqrt ( u1**2 + u1**2 ), u1 )
     v1 = -( u1 + r ) / r
     v2 = -u2 / r
     u2 = v2 / v1

     do j = km1, enorn
       t = a(k,j) + u2 * a(k1,j)
       a(k,j) = a(k,j) + t * v1
       a(k1,j) = a(k1,j) + t * v2
       t = b(k,j) + u2 * b(k1,j)
       b(k,j) = b(k,j) + t * v1
       b(k1,j) = b(k1,j) + t * v2
     end do

     if ( k /= l ) then
       a(k1,km1) = 0.0D+00
     end if

     go to 240
!
!  Zero A(k+1,k-1) and A(k+2,k-1).
!
190  continue

     if ( k /= l ) then
       a1 = a(k,km1)
       a2 = a(k1,km1)
       a3 = a(k2,km1)
     end if

     s = abs ( a1 ) + abs ( a2 ) + abs ( a3 )

     if ( s == 0.0D+00 ) then
       go to 260
     end if

     u1 = a1 / s
     u2 = a2 / s
     u3 = a3 / s
     r = sign ( sqrt ( u1**2 + u2**2 + u3**2 ), u1 )
     v1 = -(u1 + r) / r
     v2 = -u2 / r
     v3 = -u3 / r
     u2 = v2 / v1
     u3 = v3 / v1

     do j = km1, enorn
       t = a(k,j) + u2 * a(k1,j) + u3 * a(k2,j)
       a(k,j) = a(k,j) + t * v1
       a(k1,j) = a(k1,j) + t * v2
       a(k2,j) = a(k2,j) + t * v3
       t = b(k,j) + u2 * b(k1,j) + u3 * b(k2,j)
       b(k,j) = b(k,j) + t * v1
       b(k1,j) = b(k1,j) + t * v2
       b(k2,j) = b(k2,j) + t * v3
     end do

     if ( k /= l ) then
       a(k1,km1) = 0.0D+00
       a(k2,km1) = 0.0D+00
     end if
!
!  Zero B(k+2,k+1) and B(k+2,k).
!
     s = abs ( b(k2,k2) ) + abs ( b(k2,k1) ) + abs ( b(k2,k) )
     if ( s == 0.0D+00 ) then
       go to 240
     end if

     u1 = b(k2,k2) / s
     u2 = b(k2,k1) / s
     u3 = b(k2,k) / s
     r = sign ( sqrt ( u1**2 + u2**2 + u3**2 ), u1 )
     v1 = -(u1 + r) / r
     v2 = -u2 / r
     v3 = -u3 / r
     u2 = v2 / v1
     u3 = v3 / v1

     do i = lor1, ll
       t = a(i,k2) + u2 * a(i,k1) + u3 * a(i,k)
       a(i,k2) = a(i,k2) + t * v1
       a(i,k1) = a(i,k1) + t * v2
       a(i,k) = a(i,k) + t * v3
       t = b(i,k2) + u2 * b(i,k1) + u3 * b(i,k)
       b(i,k2) = b(i,k2) + t * v1
       b(i,k1) = b(i,k1) + t * v2
       b(i,k) = b(i,k) + t * v3
     end do

     b(k2,k) = 0.0D+00
     b(k2,k1) = 0.0D+00

     if ( matz ) then

       do i = 1, n
         t = z(i,k2) + u2 * z(i,k1) + u3 * z(i,k)
         z(i,k2) = z(i,k2) + t * v1
         z(i,k1) = z(i,k1) + t * v2
         z(i,k) = z(i,k) + t * v3
       end do

     end if
!
!  Zero B(k+1,k).
!
240  continue

     s = abs ( b(k1,k1) ) + abs ( b(k1,k) )

     if ( s /= 0.0D+00 ) then

       u1 = b(k1,k1) / s
       u2 = b(k1,k) / s
       r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
       v1 = -( u1 + r ) / r
       v2 = -u2 / r
       u2 = v2 / v1
  
       do i = lor1, ll
         t = a(i,k1) + u2 * a(i,k)
         a(i,k1) = a(i,k1) + t * v1
         a(i,k) = a(i,k) + t * v2
         t = b(i,k1) + u2 * b(i,k)
         b(i,k1) = b(i,k1) + t * v1
         b(i,k) = b(i,k) + t * v2
       end do

       b(k1,k) = 0.0D+00

       if ( matz ) then

         do i = 1, n
           t = z(i,k1) + u2 * z(i,k)
           z(i,k1) = z(i,k1) + t * v1
           z(i,k) = z(i,k) + t * v2
         end do

       end if

     end if

260  continue

  end do

  go to 70
!
!  Set error: not all eigenvalues have converged after 30*N iterations.
!
1000 continue

  ierr = en
!
!  Save EPSB for use by QZVAL and QZVEC.
!
 1001 continue

  if ( n > 1 ) then
    b(n,1) = epsb
  end if

  return
end subroutine qzit

subroutine qzval ( n, a, b, alfr, alfi, beta, matz, z )

!*****************************************************************************80
!
!! QZVAL computes eigenvalues for a generalized eigenvalue problem.
!
!  Discussion:
!
!    This subroutine is the third step of the QZ algorithm
!    for solving generalized matrix eigenvalue problems.
!
!    This subroutine accepts a pair of real matrices, one of them
!    in quasi-triangular form and the other in upper triangular form.
!    It reduces the quasi-triangular matrix further, so that any
!    remaining 2-by-2 blocks correspond to pairs of complex
!    eigenvalues, and returns quantities whose ratios give the
!    generalized eigenvalues.  It is usually preceded by QZHES
!    and QZIT and may be followed by QZVEC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices.
!
!    Input/output, real (dp) A(N,N).  On input, a real upper
!    quasi-triangular matrix.  On output, A has been reduced further to a
!    quasi-triangular matrix in which all nonzero subdiagonal elements
!    correspond to pairs of complex eigenvalues.
!
!    Input/output, real (dp) B(N,N).  On input, a real upper triangular 
!    matrix.  In addition, location B(n,1) contains the tolerance quantity EPSB
!    computed and saved in QZIT.  On output, B is still in upper triangular
!    form, although its elements have been altered.  B(N,1) is unaltered.
!
!    Output, real (dp) ALFR(N), ALFI(N), the real and imaginary parts of
!    the diagonal elements of the triangular matrix that would be obtained
!    if A were reduced completely to triangular form by unitary
!    transformations.  Non-zero values of ALFI occur in pairs, the first
!    member positive and the second negative.
!
!    Output, real (dp) BETA(N), the diagonal elements of the 
!    corresponding B, normalized to be real and non-negative.  The generalized 
!    eigenvalues are then the ratios (ALFR + I * ALFI) / BETA.
!
!    Input, logical MATZ, should be TRUE if the right hand transformations
!    are to be accumulated for later use in computing eigenvectors, and
!    to FALSE otherwise.
!
!    Input/output, real (dp) Z(N,N), is only used if MATZ is TRUE.
!    On input, the transformation matrix produced in the reductions by QZHES
!    and QZIT, if performed, or else the identity matrix.  On output,
!    the product of the right hand transformations for all three steps.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) a1
  real (dp) a11
  real (dp) a11i
  real (dp) a11r
  real (dp) a12
  real (dp) a12i
  real (dp) a12r
  real (dp) a1i
  real (dp) a2
  real (dp) a21
  real (dp) a22
  real (dp) a22i
  real (dp) a22r
  real (dp) a2i
  real (dp) an
  real (dp) alfi(n)
  real (dp) alfr(n)
  real (dp) b(n,n)
  real (dp) b11
  real (dp) b12
  real (dp) b22
  real (dp) beta(n)
  real (dp) bn
  real (dp) c
  real (dp) cq
  real (dp) cz
  real (dp) d
  real (dp) di
  real (dp) dr
  real (dp) e
  real (dp) ei
  integer ( i4 ) en
  real (dp) epsb
  integer ( i4 ) i
  integer ( i4 ) isw
  integer ( i4 ) j
  logical matz
  integer ( i4 ) na
  integer ( i4 ) nn
  real (dp) r
  real (dp) s
  real (dp) sqi
  real (dp) sqr
  real (dp) ssi
  real (dp) ssr
  real (dp) szi
  real (dp) szr
  real (dp) t
  real (dp) ti
  real (dp) tr
  real (dp) u1
  real (dp) u2
  real (dp) v1
  real (dp) v2
  real (dp) z(n,n)

  epsb = b(n,1)
  isw = 1
!
!  Find eigenvalues of quasi-triangular matrices.
!
  do nn = 1, n

     en = n + 1 - nn
     na = en - 1

     if ( isw == 2 ) then
       go to 505
     end if

     if ( en == 1 ) then
       go to 410
     end if

     if ( a(en,na) /= 0.0D+00 ) then
       go to 420
     end if
!
!  1-by-1 block, one real root.
!
410  continue

     alfr(en) = a(en,en)
     if ( b(en,en) < 0.0D+00 ) then
       alfr(en) = -alfr(en)
     end if

     beta(en) = abs ( b(en,en) )
     alfi(en) = 0.0D+00
     go to 510
!
!  2-by-2 block.
!
420  continue

     if ( abs ( b(na,na) ) <= epsb ) then
       a1 = a(na,na)
       a2 = a(en,na)
       go to 460
     end if

     if ( abs ( b(en,en) ) <= epsb ) then
       a1 = a(en,en)
       a2 = a(en,na)
       bn = 0.0D+00
       go to 435
     end if

     an = abs ( a(na,na) ) + abs ( a(na,en) ) + abs ( a(en,na) ) &
       + abs ( a(en,en) )
     bn = abs ( b(na,na) ) + abs ( b(na,en) ) + abs ( b(en,en) )
     a11 = a(na,na) / an
     a12 = a(na,en) / an
     a21 = a(en,na) / an
     a22 = a(en,en) / an
     b11 = b(na,na) / bn
     b12 = b(na,en) / bn
     b22 = b(en,en) / bn
     e = a11 / b11
     ei = a22 / b22
     s = a21 / ( b11 * b22 )
     t = ( a22 - e * b22 ) / b22

     if ( abs ( e ) > abs ( ei ) ) then
       e = ei
       t = ( a11 - e * b11 ) / b11
     end if

     c = 0.5D+00 * ( t - s * b12 )
     d = c**2 + s * ( a12 - e * b12 )

     if ( d < 0.0D+00 ) then
       go to 480
     end if
!
!  Two real roots.
!  Zero both A(EN,NA) and B(EN,NA).
!
     e = e + ( c + sign ( sqrt ( d ), c ) )
     a11 = a11 - e * b11
     a12 = a12 - e * b12
     a22 = a22 - e * b22

     if ( abs ( a11 ) + abs ( a12 ) >= abs ( a21 ) + abs ( a22 ) ) then
       a1 = a12
       a2 = a11
     else
       a1 = a22
       a2 = a21
     end if
!
!  Choose and apply real Z.
!
435  continue

     s = abs ( a1 ) + abs ( a2 )
     u1 = a1 / s
     u2 = a2 / s
     r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
     v1 = - ( u1 + r ) / r
     v2 = - u2 / r
     u2 = v2 / v1

     do i = 1, en
       t = a(i,en) + u2 * a(i,na)
       a(i,en) = a(i,en) + t * v1
       a(i,na) = a(i,na) + t * v2
       t = b(i,en) + u2 * b(i,na)
       b(i,en) = b(i,en) + t * v1
       b(i,na) = b(i,na) + t * v2
     end do

     if ( matz ) then

       do i = 1, n
         t = z(i,en) + u2 * z(i,na)
         z(i,en) = z(i,en) + t * v1
         z(i,na) = z(i,na) + t * v2
       end do

     end if

450  continue

     if ( bn == 0.0D+00 ) then
       go to 475
     end if

     if ( abs ( e ) * bn <= an ) then
       a1 = b(na,na)
       a2 = b(en,na)
     else
       a1 = a(na,na)
       a2 = a(en,na)
     end if
!
!  Choose and apply real Q.
!
460  continue

     s = abs ( a1 ) + abs ( a2 )
     if ( s == 0.0D+00 ) then
       go to 475
     end if

     u1 = a1 / s
     u2 = a2 / s
     r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
     v1 = -(u1 + r) / r
     v2 = -u2 / r
     u2 = v2 / v1

     do j = na, n
       t = a(na,j) + u2 * a(en,j)
       a(na,j) = a(na,j) + t * v1
       a(en,j) = a(en,j) + t * v2
       t = b(na,j) + u2 * b(en,j)
       b(na,j) = b(na,j) + t * v1
       b(en,j) = b(en,j) + t * v2
     end do

475  continue

     a(en,na) = 0.0D+00
     b(en,na) = 0.0D+00
     alfr(na) = a(na,na)
     alfr(en) = a(en,en)
     if ( b(na,na) < 0.0D+00 ) then 
       alfr(na) = -alfr(na)
     end if

     if ( b(en,en) < 0.0D+00 ) then
       alfr(en) = -alfr(en)
     end if

     beta(na) = abs ( b(na,na) )
     beta(en) = abs ( b(en,en) )
     alfi(en) = 0.0D+00
     alfi(na) = 0.0D+00
     go to 505
!
!  Two complex roots.
!
480  continue

     e = e + c
     ei = sqrt ( -d )
     a11r = a11 - e * b11
     a11i = ei * b11
     a12r = a12 - e * b12
     a12i = ei * b12
     a22r = a22 - e * b22
     a22i = ei * b22

     if ( abs ( a11r ) + abs ( a11i ) + abs ( a12r ) + abs ( a12i ) >= &
            abs ( a21 ) + abs ( a22r ) + abs ( a22i ) ) then
       a1 = a12r
       a1i = a12i
       a2 = -a11r
       a2i = -a11i
     else
       a1 = a22r
       a1i = a22i
       a2 = -a21
       a2i = 0.0D+00
     end if
!
!  Choose complex Z.
!
     cz = sqrt ( a1**2 + a1i**2 )

     if ( cz /= 0.0D+00 ) then
       szr = ( a1 * a2 + a1i * a2i) / cz
       szi = ( a1 * a2i - a1i * a2) / cz
       r = sqrt ( cz**2 + szr**2 + szi**2 )
       cz = cz / r
       szr = szr / r
       szi = szi / r
     else
       szr = 1.0D+00
       szi = 0.0D+00
     end if

     if ( an >= ( abs ( e ) + ei ) * bn ) then
       a1 = cz * b11 + szr * b12
       a1i = szi * b12
       a2 = szr * b22
       a2i = szi * b22
     else
       a1 = cz * a11 + szr * a12
       a1i = szi * a12
       a2 = cz * a21 + szr * a22
       a2i = szi * a22
     end if
!
!  Choose complex Q.
!
     cq = sqrt ( a1**2 + a1i**2 )

     if ( cq /= 0.0D+00 ) then
       sqr = ( a1 * a2 + a1i * a2i ) / cq
       sqi = ( a1 * a2i - a1i * a2 ) / cq
       r = sqrt ( cq**2 + sqr**2 + sqi**2 )
       cq = cq / r
       sqr = sqr / r
       sqi = sqi / r
     else
       sqr = 1.0D+00
       sqi = 0.0D+00
     end if
!
!  Compute diagonal elements that would result if transformations were applied.
!
     ssr = sqr * szr + sqi * szi
     ssi = sqr * szi - sqi * szr
     i = 1
     tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21 + ssr * a22
     ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22
     dr = cq * cz * b11 + cq * szr * b12 + ssr * b22
     di = cq * szi * b12 + ssi * b22
     go to 503

502  continue

     i = 2
     tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21 + cq * cz * a22
     ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21
     dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22
     di = -ssi * b11 - sqi * cz * b12

503  continue

     t = ti * dr - tr * di

     if ( t < 0.0D+00 ) then
       j = en
     else
       j = na
     end if

     r = sqrt ( dr**2 + di**2 )
     beta(j) = bn * r
     alfr(j) = an * (tr * dr + ti * di) / r
     alfi(j) = an * t / r

     if ( i == 1 ) then
       go to 502
     end if

505  continue

     isw = 3 - isw

510  continue

  end do

  b(n,1) = epsb

  return
end subroutine qzval

subroutine qzvec ( n, a, b, alfr, alfi, beta, z )

!*****************************************************************************80
!
!! QZVEC computes eigenvectors for a generalized eigenvalue problem.
!
!  Discussion:
!
!    This subroutine is the optional fourth step of the QZ algorithm
!    for solving generalized matrix eigenvalue problems.
!
!    This subroutine accepts a pair of real matrices, one of them in
!    quasi-triangular form (in which each 2-by-2 block corresponds to
!    a pair of complex eigenvalues) and the other in upper triangular
!    form.  It computes the eigenvectors of the triangular problem and
!    transforms the results back to the original coordinate system.
!    it is usually preceded by QZHES, QZIT, and QZVAL.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices.
!
!    Input, real (dp) A(N,N), contains a real upper quasi-triangular 
!    matrix.  Its subdiagonal elements provide information about the storage of
!    the complex eigenvectors.
!
!    Input/output, real (dp) B(N,N).  On input, a real upper triangular
!    matrix.  In addition, location B(N,1) contains the tolerance quantity EPSB
!    computed and saved in QZIT.  On output, B has been destroyed.
!
!    Input, real (dp) ALFR(N), ALFI(N), BETA(N), vectors whose ratios
!      ( ALFR + I * ALFI ) / BETA
!    are the generalized eigenvalues.  They are usually obtained from QZVAL.
!
!    Input/output, real (dp) Z(N,N).  On input, the transformation
!    matrix produced in the reductions by QZHES, QZIT, and QZVAL, if performed.
!    If the eigenvectors of the triangular problem are desired, Z must contain
!    the identity matrix.  On output, Z contains the real and imaginary parts of
!    the eigenvectors:
!    If ALFI(I) == 0.0, the I-th eigenvalue is real and the I-th column of Z
!    contains its eigenvector.
!    If ALFI(I) > 0.0, the eigenvalue is the first of a complex pair and the
!    I-th and (I+1)-th columns of Z contain its eigenvector.
!    If ALFI(I) < 0.0, the eigenvalue is the second of a complex pair and the
!    (I-1)-th and I-th columns of Z contain the conjugate of its eigenvector.
!    Each eigenvector is normalized so that the modulus of its largest
!    component is 1.0D+00 .
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) alfi(n)
  real (dp) alfm
  real (dp) alfr(n)
  real (dp) almi
  real (dp) almr
  real (dp) b(n,n)
  real (dp) beta(n)
  real (dp) betm
  real (dp) d
  real (dp) di
  real (dp) dr
  integer ( i4 ) en
  integer ( i4 ) enm2
  real (dp) epsb
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) isw
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) m
  integer ( i4 ) na
  integer ( i4 ) nn
  real (dp) q
  real (dp) r
  real (dp) ra
  real (dp) rr
  real (dp) s
  real (dp) sa
  real (dp) t
  real (dp) t1
  real (dp) t2
  real (dp) ti
  real (dp) tr
  real (dp) w
  real (dp) w1
  real (dp) x
  real (dp) x1
  real (dp) y
  real (dp) z(n,n)
  real (dp) z1
  real (dp) zz

  epsb = b(n,1)
  isw = 1

  do nn = 1, n

     en = n + 1 - nn
     na = en - 1

     if ( isw == 2 ) then
       go to 795
     end if

     if ( alfi(en) /= 0.0D+00 ) then
       go to 710
     end if
!
!  Real vector.
!
     m = en
     b(en,en) = 1.0D+00

     if ( na == 0 ) then
       go to 800
     end if

     alfm = alfr(m)
     betm = beta(m)

     do ii = 1, na

        i = en - ii
        w = betm * a(i,i) - alfm * b(i,i)
        r = 0.0D+00

        do j = m, en
          r = r + ( betm * a(i,j) - alfm * b(i,j) ) * b(j,en)
        end do

        if ( i == 1 .or. isw == 2 ) then
          go to 630
        end if

        if ( betm * a(i,i-1) == 0.0D+00 ) then
          go to 630
        end if

        zz = w
        s = r
        go to 690

630     continue

        m = i

        if ( isw == 2 ) then
          go to 640
        end if
!
!  Real 1-by-1 block.
!
        if ( w == 0.0D+00 ) then
          t = epsb
        else
          t = w
        end if

        b(i,en) = - r / t
        go to 700
!
!  Real 2-by-2 block.
!
640     continue

        x = betm * a(i,i+1) - alfm * b(i,i+1)
        y = betm * a(i+1,i)
        q = w * zz - x * y
        t = ( x * s - zz * r ) / q
        b(i,en) = t

        if ( abs ( x ) <= abs ( zz ) ) then
          go to 650
        end if

        b(i+1,en) = (-r - w * t) / x

        go to 690

650     continue

        b(i+1,en) = (-s - y * t) / zz

690     continue

        isw = 3 - isw

700     continue

     end do
!
!  End real vector.
!
     go to 800
!
!  Complex vector.
!
710  continue

     m = na
     almr = alfr(m)
     almi = alfi(m)
     betm = beta(m)
!
!  Last vector component chosen imaginary so eigenvector matrix is triangular.
!
     y = betm * a(en,na)
     b(na,na) = -almi * b(en,en) / y
     b(na,en) = ( almr * b(en,en) - betm * a(en,en) ) / y
     b(en,na) = 0.0D+00
     b(en,en) = 1.0D+00
     enm2 = na - 1

     do ii = 1, enm2

        i = na - ii
        w = betm * a(i,i) - almr * b(i,i)
        w1 = -almi * b(i,i)
        ra = 0.0D+00
        sa = 0.0D+00

        do j = m, en
          x = betm * a(i,j) - almr * b(i,j)
          x1 = -almi * b(i,j)
          ra = ra + x * b(j,na) - x1 * b(j,en)
          sa = sa + x * b(j,en) + x1 * b(j,na)
        end do

        if ( i == 1 .or. isw == 2 ) then
          go to 770
        end if

        if ( betm * a(i,i-1) == 0.0D+00 ) then
          go to 770
        end if

        zz = w
        z1 = w1
        r = ra
        s = sa
        isw = 2
        go to 790
770     continue

        m = i
        if ( isw == 2 ) then
          go to 780
        end if
!
!  Complex 1-by-1 block.
!
        tr = -ra
        ti = -sa

773     continue

        dr = w
        di = w1
!
!  Complex divide (t1,t2) = (tr,ti) / (dr,di),
!
775     continue

        if ( abs ( di ) > abs ( dr ) ) then
          go to 777
        end if

        rr = di / dr
        d = dr + di * rr
        t1 = (tr + ti * rr) / d
        t2 = (ti - tr * rr) / d
!        go to ( 787, 782 ), isw
! Replaced computed GOTO with a select case structure
        select case (isw)     
        case(1)
          GOTO 787
        case(2)
          GOTO 782
        case default     
          CONTINUE    
        end select

777     continue

        rr = dr / di
        d = dr * rr + di
        t1 = ( tr * rr + ti ) / d
        t2 = ( ti * rr - tr ) / d
!        go to ( 787, 782 ), isw
! Replaced computed GOTO with a select case structure
        select case (isw)     
        case(1)
          GOTO 787
        case(2)
          GOTO 782
        case default     
          CONTINUE    
        end select
!
!  Complex 2-by-2 block.
!
780     continue

        x = betm * a(i,i+1) - almr * b(i,i+1)
        x1 = -almi * b(i,i+1)
        y = betm * a(i+1,i)
        tr = y * ra - w * r + w1 * s
        ti = y * sa - w * s - w1 * r
        dr = w * zz - w1 * z1 - x * y
        di = w * z1 + w1 * zz - x1 * y
        if ( dr == 0.0D+00 .and. di == 0.0D+00 ) then
          dr = epsb
        end if
        go to 775

782     continue

        b(i+1,na) = t1
        b(i+1,en) = t2
        isw = 1

        if ( abs ( y ) > abs ( w ) + abs ( w1 ) ) then
          go to 785
        end if

        tr = -ra - x * b(i+1,na) + x1 * b(i+1,en)
        ti = -sa - x * b(i+1,en) - x1 * b(i+1,na)
        go to 773

785     continue

        t1 = (-r - zz * b(i+1,na) + z1 * b(i+1,en) ) / y
        t2 = (-s - zz * b(i+1,en) - z1 * b(i+1,na) ) / y

787     continue

        b(i,na) = t1
        b(i,en) = t2

790     continue

     end do
!
!  End complex vector.
!
795   continue

      isw = 3 - isw

800   continue

  end do
!
!  End back substitution.
!  Transform to original coordinate system.
!
  do jj = 1, n

     j = n + 1 - jj

     do i = 1, n

        zz = 0.0D+00

        do k = 1, j
          zz = zz + z(i,k) * b(k,j)
        end do

        z(i,j) = zz

      end do

  end do
!
!  Normalize so that modulus of largest component of each vector is 1.
!  (ISW is 1 initially from before).
!
  do j = 1, n

     d = 0.0D+00
     if ( isw == 2 ) then
       go to 920
     end if

     if ( alfi(j) /= 0.0D+00 ) then
       go to 945
     end if

     do i = 1, n
       d = max ( d, abs ( z(i,j) ) )
     end do

     z(1:n,j) = z(1:n,j) / d

     go to 950

920  continue

     do i = 1, n
       r = abs ( z(i,j-1) ) + abs ( z(i,j) )
       if ( r /= 0.0D+00 ) then
         r = r * sqrt ( ( z(i,j-1) / r )**2 + ( z(i,j) / r )**2 )
       end if
       d = max ( d, r )
     end do

     z(1:n,j-1) = z(1:n,j-1) / d
     z(1:n,j) = z(1:n,j) / d

945  continue

     isw = 3 - isw

950  continue

  end do

  return
end subroutine qzvec

subroutine r8_swap ( x, y )

!*****************************************************************************80
!
!! R8_SWAP swaps two R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 December 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real (dp) X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none

  real (dp) x
  real (dp) y
  real (dp) z

  z = x
  x = y
  y = z

  return
end subroutine r8_swap

subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( i4 ) M, the number of rows in A.
!
!    Input, integer ( i4 ) N, the number of columns in A.
!
!    Input, real (dp) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end subroutine r8mat_print

subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( i4 ) M, N, the number of rows and columns.
!
!    Input, real (dp) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( i4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( i4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( i4 ), parameter :: incx = 5
  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( i4 ) i
  integer ( i4 ) i2hi
  integer ( i4 ) i2lo
  integer ( i4 ) ihi
  integer ( i4 ) ilo
  integer ( i4 ) inc
  integer ( i4 ) j
  integer ( i4 ) j2
  integer ( i4 ) j2hi
  integer ( i4 ) j2lo
  integer ( i4 ) jhi
  integer ( i4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = dp ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end subroutine r8mat_print_some

subroutine r8mat_uniform_01 ( m, n, seed, r )

!*****************************************************************************80
!
!! R8MAT_UNIFORM_01 fills an R8MAT with unit pseudorandom numbers.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 August 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( i4 ) M, N, the number of rows and columns in
!    the array.
!
!    Input/output, integer ( i4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real (dp) R(M,N), the array of pseudorandom values.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  integer ( i4 ) i
  integer ( i4 ), parameter :: i4_huge = 2147483647
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) seed
  real (dp) r(m,n)

  do j = 1, n

    do i = 1, m

      k = seed / 127773

      seed = 16807 * ( seed - k * 127773 ) - k * 2836

      if ( seed < 0 ) then
        seed = seed + i4_huge
      end if

      r(i,j) = real ( seed, kind = dp ) * 4.656612875D-10

    end do
  end do

  return
end subroutine r8mat_uniform_01

subroutine r8vec_print ( n, a, title )

!*****************************************************************************80
!
!! R8VEC_PRINT prints an R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8 values.
!
!  Modified:
!
!    22 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the number of components of the vector.
!
!    Input, real (dp) A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n)
  integer ( i4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '
  do i = 1, n
    write ( *, '(2x,i8,2x,g16.8)' ) i, a(i)
  end do

  return
end subroutine r8vec_print

subroutine r8vec2_print ( n, a1, a2, title )

!*****************************************************************************80
!
!! R8VEC2_PRINT prints an R8VEC2.
!
!  Discussion:
!
!    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
!    as two separate vectors A1 and A2.
!
!  Modified:
!
!    13 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the number of components of the vector.
!
!    Input, real (dp) A1(N), A2(N), the vectors to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( i4 ) n

  real (dp) a1(n)
  real (dp) a2(n)
  integer ( i4 ) i
  character ( len = * )  title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '

  if ( all ( a1(1:n) == aint ( a1(1:n) ) ) .and. &
       all ( a2(1:n) == aint ( a2(1:n) ) ) ) then
    do i = 1, n
      write ( *, '(i8,2i8)' ) i, int ( a1(i) ), int ( a2(i) )
    end do
  else if ( all ( abs ( a1(1:n) ) < 1000000.0D+00 ) .and. &
            all ( abs ( a2(1:n) ) < 1000000.0D+00 ) ) then
    do i = 1, n
      write ( *, '(i8,2f14.6)' ) i, a1(i), a2(i)
    end do
  else
    do i = 1, n
      write ( *, '(i8,2g14.6)' ) i, a1(i), a2(i)
    end do
  end if

  return
end subroutine r8vec2_print

subroutine ratqr ( n, eps1, d, e, e2, m, w, ind, bd, type, idef, ierr )

!*****************************************************************************80
!
!! RATQR computes selected eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the algebraically smallest or largest
!    eigenvalues of a symmetric tridiagonal matrix by the
!    rational QR method with Newton corrections.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) EPS1.  On input, a theoretical absolute
!    error tolerance for the computed eigenvalues.  If the input EPS1 is
!    non-positive, or indeed smaller than its default value, it is reset at
!    each iteration to the respective default value, namely, the product of
!    the relative machine precision and the magnitude of the current eigenvalue
!    iterate.  The theoretical absolute error in the K-th eigenvalue is usually
!    not greater than K times EPS1.  On output, EPS1 is unaltered unless it has
!    been reset to its (last) default value.
!
!    Input, real (dp) D(N), the diagonal elements of the input matrix.
!
!    Input, real (dp) E(N), the subdiagonal elements of the input matrix
!    in E(2:N).  E(1) is arbitrary.
!
!    Input/output, real (dp) E2(N).  On input, E2(2:N-1) contains the
!    squares of the corresponding elements of E, and E2(1) is arbitrary.  On
!    output, elements of E2 corresponding to elements of E regarded as
!    negligible have been replaced by zero, causing the matrix to split into
!    a direct sum of submatrices.  E2(1) is set to 0.0D+00 if the smallest
!    eigenvalues have been found, and to 2.0D+00 if the largest eigenvalues
!    have been found.  E2 is otherwise unaltered (unless overwritten by BD).
!
!    Input, integer ( i4 ) M, the number of eigenvalues to be found.
!
!    Output, real (dp) W(M), the M algebraically smallest eigenvalues in
!    ascending order, or the M largest eigenvalues in descending order.
!    If an error exit is made because of an incorrect specification of IDEF,
!    no eigenvalues are found.  If the Newton iterates for a particular
!    eigenvalue are not monotone, the best estimate obtained is returned
!    and IERR is set.  W may coincide with D.
!
!    Outpt, integer IND(N), contains in its first M positions the submatrix
!    indices associated with the corresponding eigenvalues in W:
!    1 for eigenvalues belonging to the first submatrix from the top, 2 for
!    those belonging to the second submatrix, and so on.
!
!    Output, real (dp) BD(N), contains refined bounds for the
!    theoretical errors of the corresponding eigenvalues in W.  These bounds
!    are usually within the tolerance specified by EPS1.  BD may coincide
!    with E2.
!
!    Input, integer ( i4 ) IDEF, should be set to 1 if the input matrix
!    is known to be positive definite, to -1 if the input matrix is known to
!    be negative  definite, and to 0 otherwise.
!
!    Input, logical TYPE, should be set to TRUE if the smallest eigenvalues
!    are to be found, and to FALSE if the largest eigenvalues are to be found.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    6*N+1, if IDEF is set to 1 and TYPE to .true. when the matrix is not
!      positive definite, or if IDEF is set to -1 and TYPE to .false.
!      when the matrix is not negative definite,
!    5*N+K, if successive iterates to the K-th eigenvalue are not monotone
!      increasing, where K refers to the last such occurrence.
!
  implicit none

  integer ( i4 ) n

  real (dp) bd(n)
  real (dp) d(n)
  real (dp) delta
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) ep
  real (dp) eps1
  real (dp) err
  real (dp) f
  integer ( i4 ) i
  integer ( i4 ) idef
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ind(n)
  integer ( i4 ) j
  integer ( i4 ) jdef
  integer ( i4 ) jj
  integer ( i4 ) k
  integer ( i4 ) k1
  integer ( i4 ) m
  real (dp) p
  real (dp) q
  real (dp) qp
  real (dp) r
  real (dp) s
  real (dp) tot
  logical type
  real (dp) w(n)

  ierr = 0
  jdef = idef
  w(1:n) = d(1:n)

  if ( .not. type ) then
    j = 1
    go to 400
  end if

40 continue

  err = 0.0D+00
  s = 0.0D+00
!
!  Look for small sub-diagonal entries and define initial shift
!  from lower Gerschgorin bound.
!
!  Copy E2 array into BD.
!
  tot = w(1)
  q = 0.0D+00
  j = 0

  do i = 1, n

     p = q

     if ( i == 1 ) then
       go to 60
     end if

     if ( p > ( abs ( d(i) ) + abs (  d(i-1) ) ) * epsilon ( p ) ) then
       go to 80
     end if

60   continue

     e2(i) = 0.0D+00

80   continue

     bd(i) = e2(i)
!
!  Count also if element of E2 has underflowed.
!
     if ( e2(i) == 0.0D+00 ) then
       j = j + 1
     end if

     ind(i) = j
     q = 0.0D+00
     if ( i /= n ) then
       q = abs ( e(i+1) )
     end if

     tot = min ( w(i) - p - q, tot )

  end do

  if ( jdef == 1 .and. tot < 0.0D+00 ) then
    go to 140
  end if

  w(1:n) = w(1:n) - tot

  go to 160

140 continue

  tot = 0.0D+00

160 continue

  do k = 1, m
!
!  Next QR transformation.
!
180  continue

     tot = tot + s
     delta = w(n) - s
     i = n
     f = abs ( tot ) * epsilon ( f )
     if ( eps1 < f ) then
       eps1 = f
     end if

     if ( delta > eps1 ) then
       go to 190
     end if

     if ( delta < (-eps1) ) then
       ierr = 6 * n + 1
       return
     end if

     go to 300
!
!  Replace small sub-diagonal squares by zero to reduce the incidence of
!  underflows.
!
190  continue

     do j = k + 1, n
       if ( bd(j) <= ( abs (  w(j) + w(j-1) ) * epsilon ( bd(j) ) ) ** 2 ) then
         bd(j) = 0.0D+00
       end if
     end do

     f = bd(n) / delta
     qp = delta + f
     p = 1.0D+00

     do ii = 1, n - k

       i = n - ii
       q = w(i) - s - f
       r = q / qp
       p = p * r + 1.0D+00
       ep = f * r
       w(i+1) = qp + ep
       delta = q - ep

       if ( delta > eps1 ) then
         go to 220
       end if

       if ( delta < (-eps1) ) then
         ierr = 6 * n + 1
         return
       end if

       go to 300

220    continue

       f = bd(i) / q
       qp = delta + f
       bd(i+1) = qp * ep

     end do

     w(k) = qp
     s = qp / p

     if ( tot + s > tot ) then
       go to 180
     end if
!
!  Set error: irregular end of iteration.
!  Deflate minimum diagonal element.
!
     ierr = 5 * n + k
     s = 0.0D+00
     delta = qp

     do j = k, n
       if ( w(j) <= delta ) then
         i = j
         delta = w(j)
       end if
     end do
!
!  Convergence.
!
300  continue

     if ( i < n ) then
       bd(i+1) = bd(i) * f / qp
     end if

     ii = ind(i)

     do jj = 1, i - k
       j = i - jj
       w(j+1) = w(j) - s
       bd(j+1) = bd(j)
       ind(j+1) = ind(j)
     end do

     w(k) = tot
     err = err + abs ( delta)
     bd(k) = err
     ind(k) = ii

  end do

  if ( type ) then
    return
  end if

  f = bd(1)
  e2(1) = 2.0D+00
  bd(1) = f
  j = 2
!
!  Negate elements of W for largest values.
!
400 continue

  w(1:n) = - w(1:n)
  jdef = -jdef

  if ( j == 1 ) then
    go to 40
  end if

  return
end subroutine ratqr

subroutine rebak ( n, b, dl, m, z )

!*****************************************************************************80
!
!! REBAK determines eigenvectors by undoing the REDUC transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a generalized
!    symmetric eigensystem by back transforming those of the
!    derived symmetric matrix determined by REDUC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) B(N,N), contains information about the similarity
!    transformation (Cholesky decomposition) used in the reduction by REDUC
!    in its strict lower triangle.
!
!    Input, real (dp) DL(N), further information about the 
!    transformation.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M).  On input, the eigenvectors to be
!    back transformed in its first M columns.  On output, the transformed
!    eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) b(n,n)
  real (dp) dl(n)
  integer ( i4 ) i
  integer ( i4 ) j
  real (dp) z(n,m)

  do j = 1, m
    do i = n, 1, -1
      z(i,j) = ( z(i,j) - dot_product ( b(i+1:n,i), z(i+1:n,j) ) ) / dl(i)
    end do
  end do

  return
end subroutine rebak

subroutine rebakb ( n, b, dl, m, z )

!*****************************************************************************80
!
!! REBAKB determines eigenvectors by undoing the REDUC2 transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a generalized
!    symmetric eigensystem by back transforming those of the
!    derived symmetric matrix determined by REDUC2.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) B(N,N), contains information about the similarity
!    transformation (Cholesky decomposition) used in the reduction by REDUC2
!    in its strict lower triangle.
!
!    Input, real (dp) DL(N), further information about the 
!    transformation.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M).  On input, the eigenvectors to be 
!    back transformed in its first M columns.  On output, the transformed
!    eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) b(n,n)
  real (dp) dl(n)
  integer ( i4 ) i
  integer ( i4 ) j
  real (dp) z(n,m)

  do j = 1, m

    do i = n, 1, -1

      z(i,j) = dl(i) * z(i,j) + dot_product ( b(i,1:i-1), z(1:i-1,j) )

    end do

  end do

  return
end subroutine rebakb

subroutine reduc ( n, a, b, dl, ierr )

!*****************************************************************************80
!
!! REDUC reduces the eigenvalue problem A*x=lambda*B*x to A*x=lambda*x.
!
!  Discussion:
!
!    This subroutine reduces the generalized symmetric eigenproblem
!    ax=(lambda)bx, where B is positive definite, to the standard
!    symmetric eigenproblem using the Cholesky factorization of B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.  If the
!    Cholesky factor L of B is already available, N should be prefixed with a
!    minus sign.
!
!    Input/output, real (dp) A(N,N).  On input, A contains a real
!    symmetric matrix.  Only the full upper triangle of the matrix need be
!    supplied.  On output, A contains in its full lower triangle the full lower
!    triangle of the symmetric matrix derived from the reduction to the
!    standard form.  The strict upper triangle of a is unaltered.
!
!    Input/output, real (dp) B(N,N).  On input, the real symmetric
!    input matrix.  Only the full upper triangle of the matrix need be supplied.
!    If N is negative, the strict lower triangle of B contains, instead, the
!    strict lower triangle of its Cholesky factor L.  In any case, on output,
!    B contains in its strict lower triangle the strict lower triangle of
!    its Cholesky factor L.  The full upper triangle of B is unaltered.
!
!    Input/output, real (dp) DL(N).  If N is negative, then the DL
!    contains the diagonal elements of L on input.  In any case, DL will contain
!    the diagonal elements of L on output,
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    7*N+1, if B is not positive definite.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  real (dp) dl(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) nn
  real (dp) x
  real (dp) y

  ierr = 0
  nn = abs ( n )
!
!  Form L in the arrays B and DL.
!
  do i = 1, n

     do j = i, n

        x = b(i,j)

        do k = 1, i - 1
          x = x - b(i,k) * b(j,k)
        end do

        if ( j == i ) then

          if ( x <= 0.0D+00 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'REDUC - Fatal error!'
            write ( *, '(a)' ) '  The matrix is not positive definite.'
            ierr = 7 * n + 1
            return
          end if

          y = sqrt ( x )
          dl(i) = y
        else
          b(j,i) = x / y
        end if

    end do

  end do
!
!  Form the transpose of the upper triangle of INV(L)*A
!  in the lower triangle of the array A.
!
  do i = 1, nn

     y = dl(i)

     do j = i, nn

        x = a(i,j)

        do k = 1, i - 1
          x = x - b(i,k) * a(j,k)
        end do

        a(j,i) = x / y

      end do

  end do
!
!  Pre-multiply by INV(L) and overwrite.
!
  do j = 1, nn

     do i = j, nn

        x = a(i,j)

        do k = j, i - 1
          x = x - a(k,j) * b(i,k)
        end do

        do k = 1, j - 1
          x = x - a(j,k) * b(i,k)
        end do

        a(i,j) = x / dl(i)

    end do

  end do

  return
end subroutine reduc

subroutine reduc2 ( n, a, b, dl, ierr )

!*****************************************************************************80
!
!! REDUC2 reduces the eigenvalue problem A*B*x=lamdba*x to A*x=lambda*x.
!
!  Discussion:
!
!    This subroutine reduces the generalized symmetric eigenproblems
!    abx=(lambda)x or bay=(lambda)y, where B is positive definite,
!    to the standard symmetric eigenproblem using the Cholesky
!    factorization of B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.  If the
!    Cholesky factor L of B is already available, N should be prefixed with a
!    minus sign.
!
!    Input/output, real (dp) A(N,N).  On input, A contains a real
!    symmetric matrix.  Only the full upper triangle of the matrix need be
!    supplied.  On output, A contains in its full lower triangle the full lower
!    triangle of the symmetric matrix derived from the reduction to the
!    standard form.  The strict upper triangle of a is unaltered.
!
!    Input/output, real (dp) B(N,N).  On input, the real symmetric
!    input matrix.  Only the full upper triangle of the matrix need be supplied.
!    If N is negative, the strict lower triangle of B contains, instead, the
!    strict lower triangle of its Cholesky factor L.  In any case, on output,
!    B contains in its strict lower triangle the strict lower triangle of
!    its Cholesky factor L.  The full upper triangle of B is unaltered.
!
!    Input/output, real (dp) DL(N).  If N is negative, then the DL
!    contains the diagonal elements of L on input.  In any case, DL will contain
!    the diagonal elements of L on output,
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    7*N+1, if B is not positive definite.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  real (dp) dl(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) nn
  real (dp) x
  real (dp) y

  ierr = 0
  nn = abs ( n )
!
!  Form L in the arrays B and DL.
!
  do i = 1, n

     do j = i, n

        x = b(i,j)

        do k = 1, i - 1
          x = x - b(i,k) * b(j,k)
        end do

        if ( j == i ) then

          if ( x <= 0.0D+00 ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'REDUC2 - Fatal error!'
            write ( *, '(a)' ) '  The matrix is not positive definite.'
            ierr = 7 * n + 1
            return
          end if

          y = sqrt ( x )
          dl(i) = y

        else

          b(j,i) = x / y

        end if

    end do

  end do
!
!  Form the lower triangle of A*L in the lower triangle of A.
!
  do i = 1, nn

     do j = 1, i

        x = a(j,i) * dl(j)

        do k = j + 1, i
          x = x + a(k,i) * b(k,j)
        end do

        do k = i + 1, nn
          x = x + a(i,k) * b(k,j)
        end do

        a(i,j) = x

     end do

  end do
!
!  Pre-multiply by L' and overwrite.
!
  do i = 1, nn

    y = dl(i)

    do j = 1, i

      x = y * a(i,j)

      do k = i + 1, nn
        x = x + a(k,j) * b(k,i)
      end do

      a(i,j) = x

    end do

  end do

  return
end subroutine reduc2 

subroutine rg ( n, a, wr, wi, matz, z, ierr )

!*****************************************************************************80
!
!! RG computes eigenvalues and eigenvectors of a real general matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    of a real general matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) A(N,N), the real general matrix.  On 
!    output, A has been overwritten.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) WR(N), WI(N), the real and imaginary parts,
!    respectively, of the eigenvalues.  Complex conjugate pairs of eigenvalues
!    appear consecutively with the eigenvalue having the positive imaginary
!    part first.
!
!    Output, real (dp) Z(N,N), contains the real and imaginary parts of 
!    the eigenvectors if MATZ is not zero.  If the J-th eigenvalue is real, the
!    J-th column of Z contains its eigenvector.  If the J-th eigenvalue is
!    complex with positive imaginary part, the J-th and (J+1)-th columns of
!    Z contain the real and imaginary parts of its eigenvector.  The
!    conjugate of this vector is the eigenvector for the conjugate eigenvalue.
!
!    Output, integer ( i4 ) IERR, an error completion code described in 
!    the documentation for HQR and HQR2.  The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) fv1(n)
  integer ( i4 ) ierr
  integer ( i4 ) is1
  integer ( i4 ) is2
  integer ( i4 ) iv1(n)
  integer ( i4 ) matz
  real (dp) wi(n)
  real (dp) wr(n)
  real (dp) z(n,n)

  call balanc ( n, a, is1, is2, fv1 )

  call elmhes ( n, is1, is2, a, iv1 )

  if ( matz == 0 ) then

    call hqr ( n, is1, is2, a, wr, wi, ierr )

    if ( ierr /= 0 ) then
      return
    end if

  else

    call eltran ( n, is1, is2, a, iv1, z )

    call hqr2 ( n, is1, is2, a, wr, wi, z, ierr )

    if ( ierr /= 0 ) then
      return
    end if

    call balbak ( n, is1, is2, fv1, n, z )

  end if

  return
end subroutine rg

subroutine rgg ( n, a, b, alfr, alfi, beta, matz, z, ierr )

!*****************************************************************************80
!
!! RGG: eigenvalues/vectors for the generalized problem A*x = lambda*B*x.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    for the real general generalized eigenproblem
!
!      A * x = lambda * B * x.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.
!
!    Input/output, real (dp) A(N,N), B(N,N), the two real general 
!    matrices.  On output, A and B have been overwritten.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) ALFR(N), ALFI(N), the real and imaginary parts,
!    respectively, of the numerators of the eigenvalues.
!
!    Output, real (dp) BETA(N), the denominators of the eigenvalues,
!    which are thus given by the ratios (ALFR + I * ALFI ) / BETA.
!    Complex conjugate pairs of eigenvalues appear consecutively
!    with the eigenvalue having the positive imaginary part first.
!
!    Output, real (dp) Z(N,N), contains the real and imaginary parts of 
!    the eigenvectors if MATZ is not zero.  If the J-th eigenvalue is real, the
!    J-th column of Z contains its eigenvector.  If the J-th eigenvalue is
!    complex with positive imaginary part, the J-th and (J+1)-th columns of
!    Z contain the real and imaginary parts of its eigenvector.  The
!    conjugate of this vector is the eigenvector for the conjugate eigenvalue.
!
!    Output, integer ( i4 ) IERR, is set equal to an error completion code
!    described in the documentation for QZIT.  The normal completion
!    code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) alfi(n)
  real (dp) alfr(n)
  real (dp) b(n,n)
  real (dp) beta(n)
  real (dp) eps1
  integer ( i4 ) ierr
  integer ( i4 ) matz
  logical tf
  real (dp) z(n,n)

  eps1 = 0.0D+00

  if ( matz == 0 ) then
    tf = .false.
  else
    tf = .true.
  end if

  call qzhes ( n, a, b, tf, z )

  call qzit ( n, a, b, eps1, tf, z, ierr )

  if ( ierr /= 0 ) then
    return
  end if

  call qzval ( n, a, b, alfr, alfi, beta, tf, z )

  if ( matz /= 0 ) then
    call qzvec ( n, a, b, alfr, alfi, beta, z )
  end if

  return
end subroutine rgg

subroutine rs ( n, a, w, matz, z, ierr )

!*****************************************************************************80
!
!! RS computes eigenvalues and eigenvectors of real symmetric matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    of a real symmetric matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), the real symmetric matrix.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set equal to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  if ( matz == 0 ) then

    call tred1 ( n, a, w, fv1, fv2 )

    call tqlrat ( n, w, fv2, ierr )

  else

    call tred2 ( n, a, w, fv1, z )

    call tql2 ( n, w, fv1, z, ierr )

  end if

  return
end subroutine rs 

subroutine rsb ( n, mb, a, w, matz, z, ierr )

!*****************************************************************************80
!
!! RSB computes eigenvalues and eigenvectors of a real symmetric band matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    of a real symmetric band matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) MB, the half band width of the matrix,
!    defined as the number of adjacent diagonals, including the principal
!    diagonal, required to specify the non-zero portion of the lower triangle
!    of the matrix.
!
!    Input, real (dp) A(N,MB), contains the lower triangle of the real
!    symmetric band matrix.  Its lowest subdiagonal is stored in the last N+1-MB
!    positions of the first column, its next subdiagonal in the last
!    N+2-MB positions of the second column, further subdiagonals similarly,
!    and finally its principal diagonal in the N positions of the last
!    column.  Contents of storages not part of the matrix are arbitrary.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired,
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) mb
  integer ( i4 ) n

  real (dp) a(n,mb)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  logical tf
  real (dp) w(n)
  real (dp) z(n,n)

  if ( mb <= 0 ) then
    ierr = 12 * n
    return
  end if

  if ( n < mb ) then
    ierr = 12 * n
    return
  end if

  if ( matz == 0 ) then

    tf = .false.

    call bandr ( n, mb, a, w, fv1, fv2, tf, z )

    call tqlrat ( n, w, fv2, ierr )

  else

    tf = .true.

    call bandr ( n, mb, a, w, fv1, fv1, tf, z )

    call tql2 ( n, w, fv1, z, ierr )

  end if

  return
end subroutine rsb

subroutine rsg ( n, a, b, w, matz, z, ierr )

!*****************************************************************************80
!
!! RSG computes eigenvalues/vectors, A*x=lambda*B*x, A symmetric, B pos-def.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    for the real symmetric generalized eigenproblem  ax = (lambda)bx.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Modified:
!
!    04 February 2003
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.
!
!    Input, real (dp) A(N,N), contains a real symmetric matrix.
!
!    Input, real (dp) B(N,N), contains a positive definite real
!    symmetric matrix.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  call reduc ( n, a, b, fv2, ierr )

  if ( ierr /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'RSG - Fatal error!'
    write ( *, '(a)' ) '  Error return from REDUC.'
    return
  end if

  if ( matz == 0 ) then

    call tred1 ( n, a, w, fv1, fv2 )

    call tqlrat ( n, w, fv2, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RSG - Warning!'
      write ( *, '(a)' ) '  Error return from TQLRAT!'
      return
    end if

  else

    call tred2 ( n, a, w, fv1, z )

    call tql2 ( n, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RSG - Fatal error!'
      write ( *, '(a)' ) '  Error return from TQL2!'
      return
    end if

    call rebak ( n, b, fv2, n, z )

  end if

  return
end subroutine rsg

subroutine rsgab ( n, a, b, w, matz, z, ierr )

!*****************************************************************************80
!
!! RSGAB computes eigenvalues/vectors, A*B*x=lambda*x, A symmetric, B pos-def.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    for the real symmetric generalized eigenproblem  abx = (lambda)x.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.
!
!    Input, real (dp) A(N,N), contains a real symmetric matrix.
!
!    Input, real (dp) B(N,N), contains a positive definite real
!    symmetric matrix.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ 
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  call reduc2 ( n, a, b, fv2, ierr )

  if ( ierr /= 0 ) then
    return
  end if

  if ( matz == 0 ) then

    call tred1 ( n, a, w, fv1, fv2 )

    call tqlrat ( n, w, fv2, ierr )

  else

    call tred2 ( n, a, w, fv1, z )

    call tql2 ( n, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      return
    end if

    call rebak ( n, b, fv2, n, z )

  end if

  return
end subroutine rsgab

subroutine rsgba ( n, a, b, w, matz, z, ierr )

!*****************************************************************************80
!
!! RSGBA computes eigenvalues/vectors, B*A*x=lambda*x, A symmetric, B pos-def.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    for the real symmetric generalized eigenproblem:
!
!      B * A * x = lambda * x
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrices A and B.
!
!    Input, real (dp) A(N,N), a real symmetric matrix.
!
!    Input, real (dp) B(N,N), a positive definite symmetric matrix.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired, 
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) b(n,n)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  call reduc2 ( n, a, b, fv2, ierr )

  if ( ierr /= 0 ) then
    return
  end if

  if ( matz == 0 ) then

    call tred1 ( n, a, w, fv1, fv2 )

    call tqlrat ( n, w, fv2, ierr )

  else

    call tred2 ( n, a, w, fv1, z )

    call tql2 ( n, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      return
    end if

    call rebakb ( n, b, fv2, n, z )

  end if

  return
end subroutine rsgba

subroutine rsm ( n, a, w, m, z, ierr )

!*****************************************************************************80
!
!! RSM computes eigenvalues, some eigenvectors, real symmetric matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find all of the eigenvalues and some of the eigenvectors
!    of a real symmetric matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), the symmetric matrix.
!
!    Input, integer ( i4 ) M, specifies the number of eigenvectors to 
!    compute.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,M), contains the orthonormal eigenvectors
!    associated with the first M eigenvalues.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT, IMTQLV and
!    TINVIT.  The normal completion code is zero.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) fwork1(n)
  real (dp) fwork2(n)
  real (dp) fwork3(n)
  real (dp) fwork4(n)
  integer ( i4 ) ierr
  integer ( i4 ) iwork(n)
  integer ( i4 ) k1
  integer ( i4 ) k2
  integer ( i4 ) k3
  integer ( i4 ) k4
  real (dp) w(n)
  real (dp) z(n,m)

  k1 = 1
  k2 = k1 + n
  k3 = k2 + n
  k4 = k3 + n

  if ( m <= 0 ) then

    call tred1 ( n, a, w, fwork1, fwork2 )

    call tqlrat ( n, w, fwork2, ierr )

  else

    call tred1 ( n, a, fwork1, fwork2, fwork3 )

    call imtqlv ( n, fwork1, fwork2, fwork3, w, iwork, ierr )

    call tinvit ( n, fwork1, fwork2, fwork3, m, w, iwork, z, ierr )

    call trbak1 ( n, a, fwork2, m, z )

  end if

  return
end subroutine rsm 

subroutine rsp ( n, nv, a, w, matz, z, ierr )

!*****************************************************************************80
!
!! RSP computes eigenvalues and eigenvectors of real symmetric packed matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of
!    subroutines from the eigensystem subroutine package (eispack)
!    to find the eigenvalues and eigenvectors (if desired)
!    of a real symmetric packed matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) NV, the dimension of the array A, which
!    must be at least (N*(N+1))/2.
!
!    Input, real (dp) A(NV), contains the lower triangle of the
!    real symmetric packed matrix stored row-wise.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired,
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ is 
!    nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for TQLRAT and TQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n
  integer ( i4 ) nv

  real (dp) a(nv)
  real (dp) fv1(n)
  real (dp) fv2(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  if ( ( n * ( n + 1 ) ) / 2 > nv ) then
    ierr = 20 * n
    return
  end if

  call tred3 ( n, nv, a, w, fv1, fv2 )

  if ( matz == 0 ) then

    call tqlrat ( n, w, fv2, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RSP - Fatal error!'
      write ( *, '(a)' ) '  Error return from TQLRAT.'
      return
    end if

  else

    z(1:n,1:n) = 0.0D+00

    do i = 1, n
      z(i,i) = 1.0D+00
    end do

    call tql2 ( n, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RSP - Fatal error!'
      write ( *, '(a)' ) '  Error return from TQL2.'
      return
    end if

    call trbak3 ( n, nv, a, n, z )

  end if

  return
end subroutine rsp

subroutine rspp ( n, nv, a, w, matz, z, ierr, m, type )

!*****************************************************************************80
!
!! RSPP computes some eigenvalues/vectors, real symmetric packed matrix.
!
!  Discussion:
!
!    This routine calls the appropriate routines for the following problem:
!
!    Given a symmetric matrix A, which is stored in a packed mode, find
!    the M smallest or largest eigenvalues, and corresponding eigenvectors.
!
!    The routine RSP returns all eigenvalues and eigenvectors.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of A, the number of rows and
!    columns in the original matrix.
!
!    Input, integer ( i4 ) NV, is the of the array A as specified in the
!    calling program.  NV must not be less than N*(N+1)/2.
!
!    Input, real (dp) A((N*(N+1))/2), on input the lower triangle of the
!    real symmetric matrix, stored row-wise in the vector,
!    in the order A(1,1), / A(2,1), A(2,2), / A(3,1), A(3,2), A(3,3)/
!    and so on.
!
!    Output, real (dp) W(M), the eigenvalues requested.
!
!    Input, integer ( i4 ) MATZ, is set to 0 if only eigenvalues are
!    desired.  Otherwise it is set to any non-zero integer for both eigenvalues
!    and eigenvectors.
!
!    Output, real (dp) Z(N,M), the eigenvectors.
!
!    Output, integer ( i4 ) IERR, error flag from RATQR.  IERR=0 on
!    normal return.  IERR nonzero, in this case, means that the algorithm broke
!    down while computing an eigenvalue.
!
!    Input, integer ( i4 ) M, the number of eigenvalues to be found.
!
!    Input, logical TYPE, set to .true. if the smallest eigenvalues
!    are to be found, or .false. if the largest ones are sought.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n
  integer ( i4 ) nv

  real (dp) a(nv)
  real (dp) bd(n)
  real (dp) eps1
  integer ( i4 ) idef
  integer ( i4 ) ierr
  integer ( i4 ) iwork(n)
  integer ( i4 ) matz
  logical type
  real (dp) w(m)
  real (dp) work1(n)
  real (dp) work2(n)
  real (dp) work3(n)
  real (dp) z(n,m)
!
!  IDEF =
!    -1 if the matrix is known to be negative definite,
!    +1 if the matrix is known to be positive definite, or
!    0 otherwise.
!
  idef = 0
!
!  Reduce to symmetric tridiagonal form.
!
  call tred3 ( n, nv, a, work1, work2, work3 )
!
!  Find the eigenvalues.
!
  eps1 = 0.0D+00

  call ratqr ( n, eps1, work1, work2, work3, m, w, iwork, &
    bd, type, idef, ierr )

  if ( ierr /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'RSPP - Fatal error!'
    write ( *, '(a)' ) '  Error return from RATQR.'
    return
  end if
!
!  Find eigenvectors for the first M eigenvalues.
!
  if ( matz /= 0 ) then

    call tinvit ( n, work1, work2, work3, m, w, iwork, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RSPP - Fatal error!'
      write ( *, '(a)' ) '  Error return from TINVIT.'
      return
    end if
!
!  Reverse the transformation.
!
    call trbak3 ( n, nv, a, m, z )

  end if

  return
end subroutine rspp

subroutine rst ( n, w, e, matz, z, ierr )

!*****************************************************************************80
!
!! RST computes eigenvalues/vectors, real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of subroutines
!    to find the eigenvalues and eigenvectors (if desired)
!    of a real symmetric tridiagonal matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) W(N).  On input, the diagonal elements
!    of the real symmetric tridiagonal matrix.  On output, the eigenvalues in
!    ascending order.
!
!    Input, real (dp) E(N), the subdiagonal elements of the matrix in
!    E(2:N).  E(1) is arbitrary.
!
!    Input, integer ( i4 ) MATZ, is zero if only eigenvalues are desired,
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for IMTQL1 and IMTQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) e(n)
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) w(n)
  real (dp) z(n,n)

  if ( matz == 0 ) then

    call imtql1 ( n, w, e, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RST - Fatal error!'
      write ( *, '(a)' ) '  Error return from IMTQL1.'
      return
    end if

  else

    z(1:n,1:n) = 0.0D+00

    do i = 1, n
      z(i,i) = 1.0D+00
    end do

    call imtql2 ( n, w, e, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RST - Fatal error!'
      write ( *, '(a)' ) '  Error return from IMTQL2.'
      return
    end if

  end if

  return
end subroutine rst 

subroutine rt ( n, a, w, matz, z, ierr )

!*****************************************************************************80
!
!! RT computes eigenvalues/vectors, real sign-symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine calls the recommended sequence of subroutines
!    to find the eigenvalues and eigenvectors (if desired)
!    of a special real tridiagonal matrix.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), contains the special real tridiagonal
!    matrix in its first three columns.  The subdiagonal elements are stored
!    in the last N-1 positions of the first column, the diagonal elements
!    in the second column, and the superdiagonal elements in the first N-1
!    positions of the third column.  Elements A(1,1) and A(N,3) are arbitrary.
!
!    Input, integer ( i4 ) MATZ, is 0 if only eigenvalues are desired,
!    and nonzero if both eigenvalues and eigenvectors are desired.
!
!    Output, real (dp) W(N), the eigenvalues in ascending order.
!
!    Output, real (dp) Z(N,N), contains the eigenvectors, if MATZ
!    is nonzero.
!
!    Output, integer ( i4 ) IERR, is set to an error
!    completion code described in the documentation for IMTQL1 and IMTQL2.
!    The normal completion code is zero.
!
  implicit none

  integer ( i4 ) n

  real (dp) fv1(n)
  integer ( i4 ) ierr
  integer ( i4 ) matz
  real (dp) a(n,3)
  real (dp) w(n)
  real (dp) z(n,n)

  if ( matz == 0 ) then

    call figi ( n, a, w, fv1, fv1, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RT - Fatal error!'
      write ( *, '(a)' ) '  Error return from FIGI.'
      return
    end if

    call imtql1 ( n, w, fv1, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RT - Fatal error!'
      write ( *, '(a)' ) '  Error return from IMTQL1.'
      return
    end if

  else

    call figi2 ( n, a, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RT - Fatal error!'
      write ( *, '(a)' ) '  Error return from FIGI2.'
      return
    end if

    call imtql2 ( n, w, fv1, z, ierr )

    if ( ierr /= 0 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RT - Fatal error!'
      write ( *, '(a)' ) '  Error return from IMTQL2.'
      return
    end if

  end if

  return
end subroutine rt 

subroutine svd ( m, n, a, w, matu, u, matv, v, ierr )

!*****************************************************************************80
!
!! SVD computes the singular value decomposition for a real matrix.
!
!  Discussion:
!
!    This subroutine determines the singular value decomposition
!
!      A = U * S * V'
!
!    of a real M by N rectangular matrix.  Householder bidiagonalization
!    and a variant of the QR algorithm are used.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Golub, Christian Reinsch,
!    Numerische Mathematik,
!    Volume 14, 1970, pages 403-420.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) M, the number of rows of A and U.
!
!    Input, integer ( i4 ) N, the number of columns of A and U, and
!    the order of V.
!
!    Input, real (dp) A(M,N), the M by N matrix to be decomposed.
!
!    Output, real (dp) W(N), the singular values of A.  These are 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.
!
!    Input, logical MATU, should be set to TRUE if the U matrix in the
!    decomposition is desired, and to FALSE otherwise.
!
!    Output, real (dp) U(M,N), contains the matrix U, with orthogonal
!    columns, 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.
!
!    Input, logical MATV, should be set to TRUE if the V matrix in the
!    decomposition is desired, and to FALSE otherwise.
!
!    Output, real (dp) V(N,N), the orthogonal matrix V 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.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    K, if the K-th singular value has not been determined after 30 iterations.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(m,n)
  real (dp) c
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) its
  integer ( i4 ) i1
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) kk
  integer ( i4 ) k1
  integer ( i4 ) l
  integer ( i4 ) ll
  integer ( i4 ) l1
  logical matu
  logical matv
  integer ( i4 ) mn
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) rv1(n)
  real (dp) s
  real (dp) scale
  real (dp) tst1
  real (dp) tst2
  real (dp) u(m,n)
  real (dp) v(n,n)
  real (dp) w(n)
  real (dp) x
  real (dp) y
  real (dp) z

  ierr = 0
  u(1:m,1:n) = a(1:m,1:n)
!
!  Householder reduction to bidiagonal form.
!
  g = 0.0D+00
  scale = 0.0D+00
  x = 0.0D+00

  do i = 1, n

    l = i + 1
    rv1(i) = scale * g
    g = 0.0D+00
    s = 0.0D+00
    scale = 0.0D+00

    if ( i <= m ) then

      scale = sum ( abs ( u(i:m,i) ) )

      if ( scale /= 0.0D+00 ) then

        u(i:m,i) = u(i:m,i) / scale

        s = sum ( u(i:m,i)**2 )

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

        if ( i /= n ) then

          do j = l, n
            s = dot_product ( u(i:m,i), u(i:m,j) )
            u(i:m,j) = u(i:m,j) + s * u(i:m,i) / h
          end do

        end if

        u(i:m,i) = scale * u(i:m,i)

      end if

    end if

    w(i) = scale * g
    g = 0.0D+00
    s = 0.0D+00
    scale = 0.0D+00

    if ( i <= m .and. i /= n ) then

      scale = sum ( abs ( u(i,l:n) ) )

      if ( scale /= 0.0D+00 ) then

        u(i,l:n) = u(i,l:n) / scale
        s = sum ( u(i,l:n)**2 )
        f = u(i,l)
        g = - sign ( sqrt ( s ), f )
        h = f * g - s
        u(i,l) = f - g
        rv1(l:n) = u(i,l:n) / h

        if ( i /= m ) then

          do j = l, m

            s = dot_product ( u(j,l:n), u(i,l:n) )

            u(j,l:n) = u(j,l:n) + s * rv1(l:n)

          end do

        end if

        u(i,l:n) = scale * u(i,l:n)

      end if

    end if

    x = max ( x, abs ( w(i) ) + abs ( rv1(i) ) )

  end do
!
!  Accumulation of right-hand transformations.
!
  if ( matv ) then

    do i = n, 1, -1

      if ( i /= n ) then

         if ( g /= 0.0D+00 ) then

          v(l:n,i) = ( u(i,l:n) / u(i,l) ) / g

          do j = l, n

            s = dot_product ( u(i,l:n), v(l:n,j) )

            v(l:n,j) = v(l:n,j) + s * v(l:n,i)

          end do

        end if

        v(i,l:n) = 0.0D+00
        v(l:n,i) = 0.0D+00

      end if

      v(i,i) = 1.0D+00
      g = rv1(i)
      l = i

    end do

  end if
!
!  Accumulation of left-hand transformations.
!
  if ( matu ) then

    mn = min ( m, n )

    do i = min ( m, n ), 1, -1

      l = i + 1
      g = w(i)

      if ( i /= n ) then
        u(i,l:n) = 0.0D+00
      end if

      if ( g /= 0.0D+00 ) then

        if ( i /= mn ) then

          do j = l, n
            s = dot_product ( u(l:m,i), u(l:m,j) )
            f = ( s / u(i,i) ) / g
            u(i:m,j) = u(i:m,j) + f * u(i:m,i)
          end do

        end if

        u(i:m,i) = u(i:m,i) / g

      else

        u(i:m,i) = 0.0D+00

      end if

      u(i,i) = u(i,i) + 1.0D+00

    end do

  end if
!
!  Diagonalization of the bidiagonal form.
!
  tst1 = x

  do kk = 1, n

     k1 = n - kk
     k = k1 + 1
     its = 0
!
!  Test for splitting.
!
520  continue

     do ll = 1, k

       l1 = k - ll
       l = l1 + 1
       tst2 = tst1 + abs ( rv1(l) )

       if ( tst2 == tst1 ) then
         go to 565
       end if

       tst2 = tst1 + abs ( w(l1) )

       if ( tst2 == tst1 ) then
         exit
       end if

     end do
!
!  Cancellation of rv1(l) if L greater than 1.
!
     c = 0.0D+00
     s = 1.0D+00

     do i = l, k

       f = s * rv1(i)
       rv1(i) = c * rv1(i)
       tst2 = tst1 + abs ( f )

       if ( tst2 == tst1 ) then
         go to 565
       end if

       g = w(i)
       h = pythag ( f, g )
       w(i) = h
       c = g / h
       s = -f / h

       if ( matu ) then

         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

       end if

    end do
!
!  Test for convergence.
!
565 continue

    z = w(k)

    if ( l == k ) then
      go to 650
    end if
!
!  Shift from bottom 2 by 2 minor.
!
    if ( its >= 30 ) then
      ierr = k
      return
    end if

    its = its + 1
    x = w(l)
    y = w(k1)
    g = rv1(k1)
    h = rv1(k)
    f = 0.5D+00 * ( ( ( g + z ) / h ) * ( ( g - z ) / y ) + y / h - h / y )
    g = pythag ( f, 1.0D+00 )
    f = x - ( z / x ) * z + ( h / x ) * ( y / ( f + sign ( g, f ) ) - h )
!
!  Next QR transformation.
!
    c = 1.0D+00
    s = 1.0D+00

    do i1 = l, k1

      i = i1 + 1
      g = rv1(i)
      y = w(i)
      h = s * g
      g = c * g
      z = pythag ( f, 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 ( matv ) then

        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

      end if

      z = pythag ( f, h )
      w(i1) = z
!
!  Rotation can be arbitrary if Z is zero.
!
      if ( z /= 0.0D+00 ) then
        c = f / z
        s = h / z
      end if

      f = c * g + s * y
      x = - s * g + c * y

      if ( matu ) then

        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

      end if

    end do

    rv1(l) = 0.0D+00
    rv1(k) = f
    w(k) = x
    go to 520
!
!  Convergence.
!
650 continue

    if ( z <= 0.0D+00 ) then

      w(k) = - z

      if ( matv ) then
        v(1:n,k) = - v(1:n,k)
      end if

    end if

  end do

  return
end subroutine svd

subroutine eispack_timestamp ( )

!*****************************************************************************80
!
!! EISPACK_TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 February 2003
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( i4 ) d
  character ( len = 8 ) date
  integer ( i4 ) h
  integer ( i4 ) m
  integer ( i4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( i4 ) n
  integer ( i4 ) s
  character ( len = 10 ) time
  integer ( i4 ) values(8)
  integer ( i4 ) y
  character ( len = 5 ) zone

  call date_and_time ( date, time, zone, values )

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

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

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

  return
end subroutine eispack_timestamp

subroutine tinvit ( n, d, e, e2, m, w, ind, z, ierr )

!*****************************************************************************80
!
!! TINVIT computes eigenvectors from eigenvalues, real tridiagonal symmetric.
!
!  Discussion:
!
!    This subroutine finds those eigenvectors of a tridiagonal
!    symmetric matrix corresponding to specified eigenvalues,
!    using inverse iteration.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) D(N), the diagonal elements of the matrix.
!
!    Input, real (dp) E(N), contains the subdiagonal elements of
!    the input matrix in E(2:N).  E(1) is arbitrary.
!
!    Input, real (dp) E2(N), contains the squares of the corresponding
!    elements of E, with zeros corresponding to negligible elements of E.
!    E(I) is considered negligible if it is not larger than the product of
!    the relative machine precision and the sum of the magnitudes of D(I)
!    and D(I-1).  E2(1) must contain 0.0D+00 if the eigenvalues are in
!    ascending order, or 2.0D+00 if the eigenvalues are in descending order.
!    If BISECT, TRIDIB, or IMTQLV has been used to find the eigenvalues,
!    their output E2 array is exactly what is expected here.
!
!    Input, integer ( i4 ) M, the number of specified eigenvalues.
!
!    Input, real (dp) W(M), the eigenvalues.
!
!    Input, integer ( i4 ) IND(M), the submatrix indices associated with 
!    the corresponding eigenvalues in W: 1 for eigenvalues belonging to the
!    first submatrix from the top, 2 for those belonging to the second
!    submatrix, and so on.
!
!    Output, real (dp) Z(N,M), the associated set of orthonormal
!    eigenvectors.  Any vector which fails to converge is set to zero.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    -R, if the eigenvector corresponding to the R-th eigenvalue fails to
!      converge in 5 iterations.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) eps2
  real (dp) eps3
  real (dp) eps4
  integer ( i4 ) group
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ind(m)
  integer ( i4 ) ip
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  real (dp) norm
  real (dp) order
  integer ( i4 ) p
  !  real (dp) pythag  ! removed as this is now in the same module
  integer ( i4 ) q
  integer ( i4 ) r
  real (dp) rv1(n)
  real (dp) rv2(n)
  real (dp) rv3(n)
  real (dp) rv4(n)
  real (dp) rv6(n)
  integer ( i4 ) s
  integer ( i4 ) tag
  real (dp) u
  real (dp) uk
  real (dp) v
  real (dp) w(m)
  real (dp) x0
  real (dp) x1
  real (dp) xu
  real (dp) z(n,m)

  ierr = 0

  if ( m == 0 ) then
    return
  end if

  u = 0.0D+00
  x0 = 0.0D+00

  tag = 0
  order = 1.0D+00 - e2(1)
  q = 0
!
!  Establish and process next submatrix.
!
100 continue

  p = q + 1

  do q = p, n
    if ( q == n ) then
      exit
    end if
    if ( e2(q+1) == 0.0D+00 ) then
      exit
    end if
  end do
!
!  Find vectors by inverse iteration.
!
140 continue

  tag = tag + 1
  s = 0

  do r = 1, m

     if ( ind(r) /= tag ) then
       go to 920
     end if

     its = 1
     x1 = w(r)

     if ( s /= 0 ) then
       go to 510
     end if
!
!  Check for isolated root.
!
     xu = 1.0D+00

     if ( p == q ) then
       rv6(p) = 1.0D+00
       go to 870
     end if

     norm = abs ( d(p) )
     ip = p + 1

     do i = p + 1, q
       norm = max ( norm, abs ( d(i) ) + abs ( e(i) ) )
     end do
!
!  EPS2 is the criterion for grouping,
!  EPS3 replaces zero pivots and equal roots are modified by EPS3,
!  EPS4 is taken very small to avoid overflow.
!
     eps2 = 0.001D+00 * norm
     eps3 = abs ( norm ) * epsilon ( eps3 )
     uk = q - p + 1
     eps4 = uk * eps3
     uk = eps4 / sqrt ( uk )
     s = p

505 continue

     group = 0
     go to 520
!
!  Look for close or coincident roots.
!
510  continue

     if ( abs ( x1 - x0 ) >= eps2 ) then
       go to 505
     end if

     group = group + 1

     if ( order * (x1 - x0) <= 0.0D+00 ) then
       x1 = x0 + order * eps3
     end if
!
!  Elimination with interchanges and initialization of vector.
!
520  continue

     v = 0.0D+00

     do i = p, q

        rv6(i) = uk

        if ( i == p ) then
          go to 560
        end if

        if ( abs ( e(i) ) < abs ( u ) ) then
          go to 540
        end if

        xu = u / e(i)
        rv4(i) = xu
        rv1(i-1) = e(i)
        rv2(i-1) = d(i) - x1
        rv3(i-1) = 0.0D+00
        if ( i /= q ) then
          rv3(i-1) = e(i+1)
        end if
        u = v - xu * rv2(i-1)
        v = - xu * rv3(i-1)
        cycle

540     continue

        xu = e(i) / u
        rv4(i) = xu
        rv1(i-1) = u
        rv2(i-1) = v
        rv3(i-1) = 0.0D+00

560     continue

        u = d(i) - x1 - xu * v
        if ( i /= q ) then
          v = e(i+1)
        end if

     end do

     if ( u == 0.0D+00 ) then
       u = eps3
     end if

     rv1(q) = u
     rv2(q) = 0.0D+00
     rv3(q) = 0.0D+00
!
!  Back substitution.
!
600   continue

  do ii = p, q
    i = p + q - ii
    rv6(i) = ( rv6(i) - u * rv2(i) - v * rv3(i) ) / rv1(i)
    v = u
    u = rv6(i)
  end do
!
!  Orthogonalize with respect to previous members of group.
!
     j = r

     do jj = 1, group

       do

         j = j - 1

         if ( ind(j) == tag ) then
           exit
         end if

       end do

       xu = dot_product ( rv6(p:q), z(p:q,j) )

       rv6(p:q) = rv6(p:q) - xu * z(p:q,j)

     end do

     norm = sum ( abs ( rv6(p:q) ) )

     if ( norm >= 1.0D+00 ) then
       go to 840
     end if
!
!  Forward substitution.
!
     if ( its == 5 ) then
       go to 830
     end if

     if ( norm == 0.0D+00 ) then
       rv6(s) = eps4
       s = s + 1
       if ( q < s ) then
         s = p
       end if
       go to 780
     end if

740  continue

     xu = eps4 / norm
     rv6(p:q) = rv6(p:q) * xu
!
!  Elimination operations on next vector iterate.
!
780  continue
!
!  If RV1(I-1) == E(I), a row interchange was performed earlier in the
!  triangularization process.
!
     do i = ip, q

       u = rv6(i)

       if ( rv1(i-1) == e(i) ) then
         u = rv6(i-1)
         rv6(i-1) = rv6(i)
       end if

       rv6(i) = u - rv4(i) * rv6(i-1)

     end do

     its = its + 1
     go to 600
!
!  Set error: non-converged eigenvector.
!
830  continue

     ierr = -r
     xu = 0.0D+00
     go to 870
!
!  Normalize so that sum of squares is 1 and expand to full order.
!
840  continue

     u = 0.0D+00
     do i = p, q
       u = pythag ( u, rv6(i) )
     end do

     xu = 1.0D+00 / u

870  continue

     z(1:n,r) = 0.0D+00
     z(p:q,r) = rv6(p:q) * xu

     x0 = x1

920  continue

  end do

  if ( q < n ) then
    go to 100
  end if

  return
end subroutine tinvit

subroutine tql1 ( n, d, e, ierr )

!*****************************************************************************80
!
!! TQL1 computes all eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a symmetric tridiagonal
!    matrix by the QL method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  References:
!
!    Bowdler, Martin, Reinsch, James Wilkinson,
!    Numerische Mathematik,
!    Volume 11, 1968, pages 293-306.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, is the order of the matrix.
!
!    Input/output, real (dp) D(N).
!    On input, the diagonal elements of the matrix.
!    On output, the eigenvalues in ascending order.
!    If an error exit is made, the eigenvalues are correct and
!    ordered for indices 1, 2,... IERR-1, but may not be
!    the smallest eigenvalues.
!
!    Input/output, real (dp) E(N).  On input, E(2:N) contains the
!    subdiagonal elements of the input matrix, and E(1) is arbitrary.
!    On output, E has been destroyed.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, normal return,
!    J, if the J-th eigenvalue has not been determined after
!    30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) c
  real (dp) c2
  real (dp) c3
  real (dp) d(n)
  real (dp) dl1
  real (dp) e(n)
  real (dp) el1
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) l2
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) s
  real (dp) s2
  real (dp) tst1
  real (dp) tst2

  ierr = 0
  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    e(i-1) = e(i)
  end do

  f = 0.0D+00
  tst1 = 0.0D+00
  e(n) = 0.0D+00

  do l = 1, n

    j = 0
    h = abs ( d(l) ) + abs ( e(l) )
    tst1 = max ( tst1, h )
!
!  Look for a small sub-diagonal element.
!
    do m = l, n

      tst2 = tst1 + abs ( e(m) )

      if ( tst2 == tst1 ) then
        exit
      end if

    end do

    if ( m == l ) then
      go to 210
    end if

130 continue

    if ( j >= 30 ) then
      ierr = l
      return
    end if

    j = j + 1
!
!  Form the shift.
!
    l1 = l + 1
    l2 = l1 + 1
    g = d(l)
    p = ( d(l1) - g ) / ( 2.0D+00 * e(l) )
    r = pythag ( p, 1.0D+00 )
    d(l) = e(l) / ( p + sign ( r, p ) )
    d(l1) = e(l) * ( p + sign ( r, p ) )
    dl1 = d(l1)
    h = g - d(l)

    d(l2:n) = d(l2:n) - h

    f = f + h
!
!  QL transformation.
!
    p = d(m)
    c = 1.0D+00
    c2 = c
    el1 = e(l1)
    s = 0.0D+00
    mml = m - l

    do ii = 1, mml
      c3 = c2
      c2 = c
      s2 = s
      i = m - ii
      g = c * e(i)
      h = c * p
      r = pythag ( p, e(i) )
      e(i+1) = s * r
      s = e(i) / r
      c = p / r
      p = c * d(i) - s * g
      d(i+1) = h + s * ( c * g + s * d(i) )
    end do

    p = - s * s2 * c3 * el1 * e(l) / dl1
    e(l) = s * p
    d(l) = c * p
    tst2 = tst1 + abs ( e(l) )
    if ( tst2 > tst1 ) then
      go to 130
    end if

210 continue

    p = d(l) + f
!
!  Order the eigenvalues.
!
    do ii = 2, l
      i = l + 2 - ii
      if ( p >= d(i-1) ) then
        go to 270
      end if
      d(i) = d(i-1)
    end do

    i = 1

270 continue

    d(i) = p

  end do

  return
end subroutine tql1

subroutine tql2 ( n, d, e, z, ierr )

!*****************************************************************************80
!
!! TQL2 computes all eigenvalues/vectors, real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues and eigenvectors of a symmetric
!    tridiagonal matrix by the QL method.  The eigenvectors of a full
!    symmetric matrix can also be found if TRED2 has been used to reduce this
!    full matrix to tridiagonal form.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 November 2012
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Bowdler, Martin, Reinsch, James Wilkinson,
!    TQL2,
!    Numerische Mathematik,
!    Volume 11, pages 293-306, 1968.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) D(N).  On input, the diagonal elements of
!    the matrix.  On output, the eigenvalues in ascending order.  If an error
!    exit is made, the eigenvalues are correct but unordered for indices
!    1,2,...,IERR-1.
!
!    Input/output, real (dp) E(N).  On input, E(2:N) contains the
!    subdiagonal elements of the input matrix, and E(1) is arbitrary.
!    On output, E has been destroyed.
!
!    Input, real (dp) Z(N,N).  On input, the transformation matrix
!    produced in the reduction by TRED2, if performed.  If the eigenvectors of
!    the tridiagonal matrix are desired, Z must contain the identity matrix.
!    On output, Z contains the orthonormal eigenvectors of the symmetric
!    tridiagonal (or full) matrix.  If an error exit is made, Z contains
!    the eigenvectors associated with the stored eigenvalues.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, normal return,
!    J, if the J-th eigenvalue has not been determined after
!    30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) c
  real (dp) c2
  real (dp) c3
  real (dp) d(n)
  real (dp) dl1
  real (dp) e(n)
  real (dp) el1
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) l2
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
  !  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) s
  real (dp) s2
  real (dp) t
  real (dp) tst1
  real (dp) tst2
  real (dp) z(n,n)

  ierr = 0

  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    e(i-1) = e(i)
  end do

  f = 0.0D+00
  tst1 = 0.0D+00
  e(n) = 0.0D+00

  do l = 1, n

    j = 0
    h = abs ( d(l) ) + abs ( e(l) )
    tst1 = max ( tst1, h )
!
!  Look for a small sub-diagonal element.
!
    do m = l, n
      tst2 = tst1 + abs ( e(m) )
      if ( tst2 == tst1 ) then
        exit
      end if
    end do

    if ( m /= l ) then

      do

        if ( 30 <= j ) then
          ierr = l
          return
        end if

        j = j + 1
!
!  Form shift.
!
        l1 = l + 1
        l2 = l1 + 1
        g = d(l)
        p = ( d(l1) - g ) / ( 2.0D+00 * e(l) )
        r = pythag ( p, 1.0D+00 )
        d(l) = e(l) / ( p + sign ( r, p ) )
        d(l1) = e(l) * ( p + sign ( r, p ) )
        dl1 = d(l1)
        h = g - d(l)
        d(l2:n) = d(l2:n) - h
        f = f + h
!
!  QL transformation.
!
        p = d(m)
        c = 1.0D+00
        c2 = c
        el1 = e(l1)
        s = 0.0D+00
        mml = m - l

        do ii = 1, mml

          c3 = c2
          c2 = c
          s2 = s
          i = m - ii
          g = c * e(i)
          h = c * p
          r = pythag ( p, e(i) )
          e(i+1) = s * r
          s = e(i) / r
          c = p / r
          p = c * d(i) - s * g
          d(i+1) = h + s * ( c * g + s * d(i) )
!
!  Form vector.
!
          do k = 1, n
            h = z(k,i+1)
            z(k,i+1) = s * z(k,i) + c * h
            z(k,i) = c * z(k,i) - s * h
          end do

        end do

        p = - s * s2 * c3 * el1 * e(l) / dl1
        e(l) = s * p
        d(l) = c * p
        tst2 = tst1 + abs ( e(l) )

        if ( tst2 <= tst1 ) then
          exit
        end if

      end do

    end if

    d(l) = d(l) + f

  end do
!
!  Order eigenvalues and eigenvectors.
!
  do ii = 2, n

    i = ii - 1
    k = i
    p = d(i)

    do j = ii, n

      if ( d(j) < p ) then
        k = j
        p = d(j)
      end if

    end do

    if ( k /= i ) then

      d(k) = d(i)
      d(i) = p

      do j = 1, n
        t      = z(j,i)
        z(j,i) = z(j,k)
        z(j,k) = t
      end do

    end if

  end do

  return
end subroutine tql2

subroutine tqlrat ( n, d, e2, ierr )

!*****************************************************************************80
!
!! TQLRAT computes all eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds the eigenvalues of a symmetric
!    tridiagonal matrix by the rational QL method.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    08 November 2012
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    C Reinsch,
!    Algorithm 464, TQLRAT,
!    Communications of the ACM,
!    Volume 16, page 689, 1973.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) D(N).  On input, D contains the diagonal
!    elements of the matrix.  On output, D contains the eigenvalues in ascending
!    order.  If an error exit was made, then the eigenvalues are correct
!    in positions 1 through IERR-1, but may not be the smallest eigenvalues.
!
!    Input/output, real (dp) E2(N), contains in positions 2 through N 
!    the squares of the subdiagonal elements of the matrix.  E2(1) is
!    arbitrary.  On output, E2 has been overwritten by workspace
!    information.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for no error,
!    J, if the J-th eigenvalue could not be determined after 30 iterations.
!
  implicit none

  integer ( i4 ) n

  real (dp) b
  real (dp) c
  real (dp) d(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) l
  integer ( i4 ) l1
  integer ( i4 ) m
  integer ( i4 ) mml
  real (dp) p
!  real (dp) pythag  ! removed as this is now in the same module
  real (dp) r
  real (dp) s
  real (dp) t

  ierr = 0

  if ( n == 1 ) then
    return
  end if

  do i = 2, n
    e2(i-1) = e2(i)
  end do

  f = 0.0D+00
  t = 0.0D+00
  e2(n) = 0.0D+00

  do l = 1, n

     j = 0
     h = abs ( d(l) ) + sqrt ( e2(l) )

     if ( t <= h ) then

       t = h
       b = abs ( t ) * epsilon ( b )
       c = b * b

     end if
!
!  Look for small squared sub-diagonal element.
!
     do m = l, n
       if ( e2(m) <= c ) then
         exit
       end if
     end do

     if ( m /= l ) then

       do

         if ( 30 <= j ) then
           ierr = l
           return
         end if

         j = j + 1
!
!  Form shift.
!
         l1 = l + 1
         s = sqrt ( e2(l) )
         g = d(l)
         p = ( d(l1) - g ) / ( 2.0D+00 * s )
         r = pythag ( p, 1.0D+00 )
         d(l) = s / ( p + sign ( r, p ) )
         h = g - d(l)
         d(l1:n) = d(l1:n) - h
         f = f + h
!
!  Rational QL transformation.
!
         g = d(m)
         if ( g == 0.0D+00 ) then
           g = b
         end if

         h = g
         s = 0.0D+00
         mml = m - l

         do ii = 1, mml
           i = m - ii
           p = g * h
           r = p + e2(i)
           e2(i+1) = s * r
           s = e2(i) / r
           d(i+1) = h + s * ( h + d(i) )
           g = d(i) - e2(i) / g
           if ( g == 0.0D+00 ) then
             g = b
           end if
           h = g * p / r
         end do

         e2(l) = s * g
         d(l) = h
!
!  Guard against underflow in convergence test.
!
         if ( h == 0.0D+00 ) then
           exit
         end if

         if ( abs ( e2(l) ) <= abs ( c / h ) ) then
           exit
         end if

         e2(l) = h * e2(l)

         if ( e2(l) == 0.0D+00 ) then
            exit
         end if

       end do

     end if

     p = d(l) + f
!
!  Order the eigenvalues.
!
     do i = l, 1, -1
       if ( i == 1 ) then
         d(i) = p
         exit
       else if ( d(i-1) <= p ) then
         d(i) = p
         exit
       end if
       d(i) = d(i-1)
     end do

  end do

  return
end subroutine tqlrat

subroutine trbak1 ( n, a, e, m, z )

!*****************************************************************************80
!
!! TRBAK1 determines eigenvectors by undoing the TRED1 transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a real symmetric
!    matrix by back transforming those of the corresponding
!    symmetric tridiagonal matrix determined by TRED1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), contains information about the orthogonal
!    transformations used in the reduction by TRED1 in its strict lower
!    triangle.
!
!    Input, real (dp) E(N), the subdiagonal elements of the tridiagonal
!    matrix in E(2:N).  E(1) is arbitrary.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M).  On input, the eigenvectors to be
!    back transformed.  On output, the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) e(n)
  integer ( i4 ) i
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) s
  real (dp) z(n,m)

  if ( m <= 0 ) then
    return
  end if

  if ( n <= 1 ) then
    return
  end if

  do i = 2, n

    l = i - 1

    if ( e(i) /= 0.0D+00 ) then

      do j = 1, m

        s = dot_product ( a(i,1:l), z(1:l,j) )

        s = ( s / a(i,l) ) / e(i)

        z(1:l,j) = z(1:l,j) + s * a(i,1:l)

      end do

    end if

  end do

  continue

  return
end subroutine trbak1

subroutine trbak3 ( n, nv, a, m, z )

!*****************************************************************************80
!
!! TRBAK3 determines eigenvectors by undoing the TRED3 transformation.
!
!  Discussion:
!
!    This subroutine forms the eigenvectors of a real symmetric
!    matrix by back transforming those of the corresponding
!    symmetric tridiagonal matrix determined by TRED3.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) NV, the dimension of the array paramater A,
!    which must be at least N*(N+1)/2.
!
!    Input, real (dp) A(NV), information about the orthogonal
!    transformations used in the reduction by TRED3.
!
!    Input, integer ( i4 ) M, the number of eigenvectors to be back
!    transformed.
!
!    Input/output, real (dp) Z(N,M).  On input, the eigenvectors to be 
!    back transformed.  On output, the transformed eigenvectors.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) nv

  real (dp) a(nv)
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ik
  integer ( i4 ) iz
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  integer ( i4 ) n
  real (dp) s
  real (dp) z(n,m)

  if ( m == 0 ) then
    return
  end if

  do i = 2, n

    l = i - 1
    iz = ( i * l ) / 2
    ik = iz + i
    h = a(ik)

    if ( h /= 0.0D+00 ) then

      do j = 1, m

        s = 0.0D+00
        ik = iz

        do k = 1, l
          ik = ik + 1
          s = s + a(ik) * z(k,j)
        end do

        s = ( s / h ) / h
        ik = iz

        do k = 1, l
          ik = ik + 1
          z(k,j) = z(k,j) - s * a(ik)
        end do

      end do

    end if

  end do

  return
end subroutine trbak3

subroutine tred1 ( n, a, d, e, e2 )

!*****************************************************************************80
!
!! TRED1 transforms a real symmetric matrix to symmetric tridiagonal form.
!
!  Discussion:
!
!    The routine reduces a real symmetric matrix to a symmetric
!    tridiagonal matrix using orthogonal similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Martin, Reinsch, James Wilkinson,
!    TRED1,
!    Numerische Mathematik,
!    Volume 11, pages 181-195, 1968.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix A.
!
!    Input/output, real (dp) A(N,N), on input, contains the real
!    symmetric matrix.  Only the lower triangle of the matrix need be supplied.
!    On output, A contains information about the orthogonal transformations
!    used in the reduction in its strict lower triangle.
!    The full upper triangle of A is unaltered.
!
!    Output, real (dp) D(N), contains the diagonal elements of the
!    tridiagonal matrix.
!
!    Output, real (dp) E(N), contains the subdiagonal elements of the
!    tridiagonal matrix in its last N-1 positions.  E(1) is set to zero.
!
!    Output, real (dp) E2(N), contains the squares of the corresponding
!    elements of E.  E2 may coincide with E if the squares are not needed.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) g
  real (dp) h
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) scale

  d(1:n) = a(n,1:n)

  do i = 1, n
    a(n,i) = a(i,i)
  end do

  do ii = 1, n

    i = n + 1 - ii
    l = i - 1
    h = 0.0D+00
!
!  Scale row.
!
    scale = sum ( abs ( d(1:l) ) )

    if ( scale == 0.0D+00 ) then

      do j = 1, l
        d(j) = a(l,j)
        a(l,j) = a(i,j)
        a(i,j) = 0.0D+00
      end do

      e(i) = 0.0D+00
      e2(i) = 0.0D+00

      cycle

    end if

    d(1:l) = d(1:l) / scale

    do k = 1, l
      h = h + d(k)**2
    end do

    e2(i) = h * scale**2
    f = d(l)
    g = - sign ( sqrt ( h ), f )
    e(i) = scale * g
    h = h - f * g
    d(l) = f - g

    if ( 1 <= l ) then
!
!  Form A * U.
!
      e(1:l) = 0.0D+00

      do j = 1, l

        f = d(j)
        g = e(j) + a(j,j) * f

        do k = j + 1, l
          g = g + a(k,j) * d(k)
          e(k) = e(k) + a(k,j) * f
        end do

        e(j) = g

      end do
!
!  Form P.
!
      f = 0.0D+00

      do j = 1, l
        e(j) = e(j) / h
        f = f + e(j) * d(j)
      end do

      h = f / ( h + h )
!
!  Form Q.
!
      e(1:l) = e(1:l) - h * d(1:l)
!
!  Form reduced A.
!
      do j = 1, l

        f = d(j)
        g = e(j)

        a(j:l,j) = a(j:l,j) - f * e(j:l) - g * d(j:l)

      end do

    end if

    do j = 1, l
      f = d(j)
      d(j) = a(l,j)
      a(l,j) = a(i,j)
      a(i,j) = f * scale
    end do


  end do

  return
end subroutine tred1

subroutine tred2 ( n, a, d, e, z )

!*****************************************************************************80
!
!! TRED2 transforms a real symmetric matrix to symmetric tridiagonal form.
!
!  Discussion:
!
!    This subroutine reduces a real symmetric matrix to a
!    symmetric tridiagonal matrix using and accumulating
!    orthogonal similarity transformations.
!
!    A and Z may coincide, in which case a single storage area is used
!    for the input of A and the output of Z.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    03 November 2012
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Martin, Reinsch, James Wilkinson,
!    TRED2,
!    Numerische Mathematik,
!    Volume 11, pages 181-195, 1968.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, real (dp) A(N,N), the real symmetric input matrix.  Only the
!    lower triangle of the matrix need be supplied.
!
!    Output, real (dp) D(N), the diagonal elements of the tridiagonal
!    matrix.
!
!    Output, real (dp) E(N), contains the subdiagonal elements of the
!    tridiagonal matrix in E(2:N).  E(1) is set to zero.
!
!    Output, real (dp) Z(N,N), the orthogonal transformation matrix
!    produced in the reduction.
!
  implicit none

  integer ( i4 ) n

  real (dp) a(n,n)
  real (dp) d(n)
  real (dp) e(n)
  real (dp) f
  real (dp) g
  real (dp) h
  real (dp) hh
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) scale
  real (dp) z(n,n)

  do i = 1, n
    z(i:n,i) = a(i:n,i)
  end do

  d(1:n) = a(n,1:n)

  do ii = 2, n

    i = n + 2 - ii
    l = i - 1
    h = 0.0D+00
!
!  Scale row.
!
    scale = sum ( abs ( d(1:l) ) )

    if ( scale == 0.0D+00 ) then

      e(i) = d(l)

      do j = 1, l
        d(j) = z(l,j)
        z(i,j) = 0.0D+00
        z(j,i) = 0.0D+00
      end do

      d(i) = 0.0D+00

      cycle

    end if

    d(1:l) = d(1:l) / scale

    h = h + dot_product ( d(1:l), d(1:l) )

    f = d(l)
    g = - sign ( sqrt ( h ), f )
    e(i) = scale * g
    h = h - f * g
    d(l) = f - g
!
!  Form A*U.
!
    e(1:l) = 0.0D+00

    do j = 1, l

      f = d(j)
      z(j,i) = f
      g = e(j) + z(j,j) * f

      do k = j + 1, l
        g = g + z(k,j) * d(k)
        e(k) = e(k) + z(k,j) * f
      end do

      e(j) = g

    end do
!
!  Form P.
!
    e(1:l) = e(1:l) / h

    f = dot_product ( e(1:l), d(1:l) )

    hh = 0.5D+00 * f / h
!
!  Form Q.
!
    e(1:l) = e(1:l) - hh * d(1:l)
!
!  Form reduced A.
!
    do j = 1, l

      f = d(j)
      g = e(j)

      z(j:l,j) = z(j:l,j) - f * e(j:l) - g * d(j:l)

      d(j) = z(l,j)
      z(i,j) = 0.0D+00

    end do

    d(i) = h

  end do
!
!  Accumulation of transformation matrices.
!
  do i = 2, n

    l = i - 1
    z(n,l) = z(l,l)
    z(l,l) = 1.0D+00
    h = d(i)

    if ( h /= 0.0D+00 ) then

      d(1:l) = z(1:l,i) / h

      do j = 1, l

        g = dot_product ( z(1:l,i), z(1:l,j) )

        do k = 1, l
          z(k,j) = z(k,j) - g * d(k)
        end do

      end do

    end if

    z(1:l,i) = 0.0D+00

  end do

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

  z(n,1:n-1) = 0.0D+00
  z(n,n) = 1.0D+00

  e(1) = 0.0D+00

  return
end subroutine tred2

subroutine tred3 ( n, nv, a, d, e, e2 )

!*****************************************************************************80
!
!! TRED3: transform real symmetric packed matrix to symmetric tridiagonal form.
!
!  Discussion:
!
!    This subroutine reduces a real symmetric matrix, stored as
!    a one-dimensional array, to a symmetric tridiagonal matrix
!    using orthogonal similarity transformations.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Martin, Reinsch, James Wilkinson,
!    TRED3,
!    Numerische Mathematik,
!    Volume 11, pages 181-195, 1968.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input, integer ( i4 ) NV, the dimension of A, which must be at least
!    (N*(N+1))/2.
!
!    Input/output, real (dp) A(NV).  On input, the lower triangle of
!    the real symmetric matrix, stored row-wise.  On output, information about
!    the orthogonal transformations used in the reduction.
!
!    Output, real (dp) D(N), the diagonal elements of the tridiagonal
!    matrix.
!
!    Output, real (dp) E(N), the subdiagonal elements of the tridiagonal
!    matrix in E(2:N).  E(1) is set to zero.
!
!    Output, real (dp) E2(N),  the squares of the corresponding
!    elements of E.  E2 may coincide with E if the squares are not needed.
!
  implicit none

  integer ( i4 ) n
  integer ( i4 ) nv

  real (dp) a(nv)
  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) f
  real (dp) g
  real (dp) h
  real (dp) hh
  integer ( i4 ) i
  integer ( i4 ) ii
  integer ( i4 ) iz
  integer ( i4 ) j
  integer ( i4 ) jk
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) scale

  do ii = 1, n

     i = n + 1 - ii
     l = i - 1
     iz = ( i * l ) / 2
     h = 0.0D+00
     scale = 0.0D+00
!
!  Scale row.
!
     do k = 1, l
       iz = iz + 1
       d(k) = a(iz)
       scale = scale + abs ( d(k) )
     end do

     if ( scale == 0.0D+00 ) then
       e(i) = 0.0D+00
       e2(i) = 0.0D+00
       go to 290
     end if

     do k = 1, l
       d(k) = d(k) / scale
       h = h + d(k)**2
     end do

     e2(i) = scale * scale * h
     f = d(l)
     g = - sign ( sqrt ( h ), f )
     e(i) = scale * g
     h = h - f * g
     d(l) = f - g
     a(iz) = scale * d(l)

     if ( l == 1 ) then
       go to 290
     end if

     jk = 1

     do j = 1, l

        f = d(j)
        g = 0.0D+00

        do k = 1, j - 1
          g = g + a(jk) * d(k)
          e(k) = e(k) + a(jk) * f
          jk = jk + 1
        end do

        e(j) = g + a(jk) * f
        jk = jk + 1

     end do
!
!  Form P.
!
     e(1:l) = e(1:l) / h
     f = dot_product ( e(1:l), d(1:l) )
     hh = f / ( h + h )
!
!  Form Q.
!
     e(1:l) = e(1:l) - hh * d(1:l)
     jk = 1
!
!  Form reduced A.
!
     do j = 1, l
       f = d(j)
       g = e(j)
       do k = 1, j
         a(jk) = a(jk) - f * e(k) - g * d(k)
         jk = jk + 1
       end do
     end do

290  continue

     d(i) = a(iz+1)
     a(iz+1) = scale * sqrt ( h )

300  continue

  end do

  return
end subroutine tred3

subroutine tridib ( n, eps1, d, e, e2, lb, ub, m11, m, w, ind, ierr )

!*****************************************************************************80
!
!! TRIDIB computes some eigenvalues of a real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvalues of a tridiagonal
!    symmetric matrix between specified boundary indices,
!    using bisection.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    20 April 2011
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) EPS1.  On input, an absolute error
!    tolerance for the computed eigenvalues.  It should be chosen commensurate
!    with relative perturbations in the matrix elements of the order of the
!    relative machine precision.  If the input EPS1 is non-positive, it
!    is reset for each submatrix to a default value, namely, minus the
!    product of the relative machine precision and the 1-norm of the submatrix.
!
!    Input, real (dp) D(N), the diagonal elements of the input matrix.
!
!    Input, real (dp) E(N), the subdiagonal elements of the input matrix
!    in E(2:N).  E(1) is arbitrary.
!
!    Input/output, real (dp) E2(N).  On input, the squares of the
!    corresponding elements of E.  E2(1) is arbitrary.  On output, elements of
!    E2 corresponding to elements of E regarded as negligible, have been
!    replaced by zero, causing the matrix to split into a direct sum of
!    submatrices.  E2(1) is also set to zero.
!
!    Input, integer ( i4 ) M11, the lower boundary index for the desired
!    eigenvalues.
!
!    Input, integer ( i4 ) M, the number of eigenvalues desired.  The
!    upper boundary index M22 is then obtained as M22 = M11 + M - 1.
!
!    Output, real (dp) LB, UB, define an interval containing exactly
!    the desired eigenvalues.
!
!    Output, real (dp) W(M), the eigenvalues between indices M11 and M22
!    in ascending order.
!
!    Output, integer ( i4 ) IND(M), the submatrix indices associated with
!    the corresponding eigenvalues in W: 1 for eigenvalues belonging to the
!    first submatrix from the top, 2 for those belonging to the second
!    submatrix, and so on.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, for normal return,
!    3*N+1, if multiple eigenvalues at index M11 make unique selection
!      impossible,
!    3*N+2, if multiple eigenvalues at index M22 make unique selection
!      impossible.
!
  implicit none

  integer ( i4 ) m
  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) eps1
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ind(m)
  integer ( i4 ) isturm
  integer ( i4 ) j
  integer ( i4 ) k
  integer ( i4 ) l
  real (dp) lb
  integer ( i4 ) m1
  integer ( i4 ) m11
  integer ( i4 ) m2
  integer ( i4 ) m22
  integer ( i4 ) p
  integer ( i4 ) q
  integer ( i4 ) r
  real (dp) rv4(n)
  real (dp) rv5(n)
  integer ( i4 ) s
  real (dp) t1
  real (dp) t2
  integer ( i4 ) tag
  real (dp) tst1
  real (dp) tst2
  real (dp) u
  real (dp) ub
  real (dp) v
  real (dp) w(m)
  real (dp) x0
  real (dp) x1
  real (dp) xu

  ierr = 0
  tag = 0
  xu = d(1)
  x0 = d(1)
  s = 0
  u = 0.0D+00
!
!  Look for small sub-diagonal entries and determine an
!  interval containing all the eigenvalues.
!
  do i = 1, n

     x1 = u

     if ( i == n ) then
       u = 0.0D+00
     else
       u = abs ( e(i+1) )
     end if

     xu = min ( xu, d(i) - ( x1 + u ) )
     x0 = max ( x0, d(i) + ( x1 + u ) )

     if ( 1 < i ) then
       tst1 = abs ( d(i) ) + abs ( d(i-1) )
       tst2 = tst1 + abs ( e(i) )
       if ( tst2 <= tst1 ) then
         e2(i) = 0.0D+00
       end if
     else
       e2(i) = 0.0D+00
     end if

  end do

  x1 = n
  x1 = x1 * max ( abs ( xu ), abs ( x0 ) ) * epsilon ( x1 )
  xu = xu - x1
  t1 = xu
  x0 = x0 + x1
  t2 = x0
!
!  Determine an interval containing exactly the desired eigenvalues.
!
  p = 1
  q = n
  m1 = m11 - 1

  if ( m1 == 0 ) then
    go to 75
  end if

  isturm = 1

50 continue

  v = x1
  x1 = xu + ( x0 - xu ) * 0.5D+00

  if ( x1 == v ) then
    go to 980
  end if

  go to 320

60 continue

  if ( s < m1 ) then
    xu = x1
    go to 50
  else if ( m1 < s ) then
    x0 = x1
    go to 50
  end if

  xu = x1
  t1 = x1

75 continue

  m22 = m1 + m

  if ( m22 /= n ) then
    x0 = t2
    isturm = 2
    go to 50
  end if

  go to 90

80 continue

  if ( s < m22 ) then
    xu = x1
    go to 50
  else if ( m22 < s ) then
    x0 = x1
    go to 50
  end if

   t2 = x1

90 continue

  q = 0
  r = 0
!
!  Establish and process next submatrix, refining interval by the
!  Gerschgorin bounds.
!
100 continue

  if ( r == m ) then
    go to 1001
  end if

  tag = tag + 1
  p = q + 1
  xu = d(p)
  x0 = d(p)
  u = 0.0D+00

  do q = p, n

    x1 = u
    u = 0.0D+00
    v = 0.0D+00

    if ( q < n ) then
      u = abs ( e(q+1) )
      v = e2(q+1)
    end if

    xu = min ( d(q) - ( x1 + u ), xu )
    x0 = max ( d(q) + ( x1 + u ), x0 )

    if ( v == 0.0D+00 ) then
      exit
    end if

  end do

  x1 = max ( abs ( xu ), abs ( x0 ) ) * epsilon ( x1 )

  if ( eps1 <= 0.0D+00 ) then
    eps1 = -x1
  end if

  if ( p /= q ) then
    go to 180
  end if
!
!  Check for isolated root within interval.
!
  if ( d(p) < t1 .or. t2 <= d(p) ) then
    go to 940
  end if

  m1 = p
  m2 = p
  rv5(p) = d(p)
  go to 900

180 continue

  x1 = x1 * ( q - p + 1 )
  lb = max ( t1, xu - x1 )
  ub = min ( t2, x0 + x1 )
  x1 = lb
  isturm = 3
  go to 320

200 continue

  m1 = s + 1
  x1 = ub
  isturm = 4
  go to 320

220 continue

  m2 = s
  if ( m2 < m1 ) then
    go to 940
  end if
!
!  Find roots by bisection.
!
  x0 = ub
  isturm = 5

  rv5(m1:m2) = ub
  rv4(m1:m2) = lb
!
!  Loop for the K-th eigenvalue.
!
  k = m2

250 continue

  xu = lb

  do ii = m1, k

    i = m1 + k - ii
    if ( xu < rv4(i) ) then
      xu = rv4(i)
      exit
    end if

  end do

  x0 = min ( x0, rv5(k) )
!
!  Next bisection step.
!
300  continue

     x1 = ( xu + x0 ) * 0.5D+00

     if ( ( x0 - xu ) <= abs ( eps1) ) then
       go to 420
     end if

     tst1 = 2.0D+00 * ( abs ( xu ) + abs ( x0 ) )
     tst2 = tst1 + (x0 - xu)

     if ( tst2 == tst1 ) then
       go to 420
     end if
!
!  Sturm sequence.
!
320  continue

     s = p - 1
     u = 1.0D+00

     do i = p, q

       if ( u == 0.0D+00 ) then
         v = abs ( e(i) ) / epsilon ( v )
         if ( e2(i) == 0.0D+00 ) then
           v = 0.0D+00
         end if
       else
         v = e2(i) / u
       end if

       u = d(i) - x1 - v

       if ( u < 0.0D+00 ) then
         s = s + 1
       end if

     end do

!     go to (60,80,200,220,360), isturm
! Replaced computed GOTO with a select case structure
        select case (isturm)     
        case(1)
          GOTO 60
        case(2)
          GOTO 80
        case(3)
          GOTO 200
        case(4)
          GOTO 220
        case(5)
          GOTO 360
        case default     
          CONTINUE    
        end select
!
!  Refine intervals.
!
360  continue

     if ( k <= s ) then
       go to 400
     end if

     xu = x1

     if ( m1 <= s ) then
       go to 380
     end if

     rv4(m1) = x1
     go to 300

380  continue

     rv4(s+1) = x1
     rv5(s) = min ( rv5(s), x1 )
     go to 300

400  continue

     x0 = x1
     go to 300
!
!  K-th eigenvalue found.
!
420  continue

  rv5(k) = x1
  k = k - 1
  if ( m1 <= k ) then
    go to 250
  end if
!
!  Order eigenvalues tagged with their submatrix associations.
!
900 continue

  s = r
  r = r + m2 - m1 + 1
  j = 1
  k = m1

  do l = 1, r

     if ( s < j ) then
       go to 910
     end if

     if ( m2 < k ) then
       go to 940
     end if

     if ( w(l) <= rv5(k) ) then
       go to 915
     end if

     do ii = j, s
       i = l + s - ii
       w(i+1) = w(i)
       ind(i+1) = ind(i)
     end do

910  continue

     w(l) = rv5(k)
     ind(l) = tag
     k = k + 1
     go to 920

915  continue

     j = j + 1

920  continue

  end do

940 continue

  if ( q < n ) then
    go to 100
  end if

  go to 1001
!
!  Set error: interval cannot be found containing exactly the
!  desired eigenvalues.
!
980 continue

  ierr = 3 * n + isturm

1001 continue

  lb = t1
  ub = t2

  return
end subroutine tridib

subroutine tsturm ( n, eps1, d, e, e2, lb, ub, mm, m, w, z, ierr )

!*****************************************************************************80
!
!! TSTURM computes some eigenvalues/vectors, real symmetric tridiagonal matrix.
!
!  Discussion:
!
!    This subroutine finds those eigenvalues of a tridiagonal
!    symmetric matrix which lie in a specified interval and their
!    associated eigenvectors, using bisection and inverse iteration.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2009
!
!  Author:
!
!    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
!    Klema, Moler.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer, 1971,
!    ISBN: 0387054146,
!    LC: QA251.W67.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
!    Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( i4 ) N, the order of the matrix.
!
!    Input/output, real (dp) EPS1.  On input, an absolute error
!    tolerance for the computed eigenvalues.  It should be chosen commensurate
!    with relative perturbations in the matrix elements of the order of the
!    relative machine precision.  If the input EPS1 is non-positive, it
!    is reset for each submatrix to a default value, namely, minus the
!    product of the relative machine precision and the 1-norm of the submatrix.
!
!    Input, real (dp) D(N), the diagonal elements of the input matrix.
!
!    Input, real (dp) E(N), the subdiagonal elements of the input matrix
!    in E(2:N).  E(1) is arbitrary.
!
!    Input/output, real (dp) E2(N).  On input, the squares of the
!    corresponding elements of E.  E2(1) is arbitrary.  On output, elements of
!    E2 corresponding to elements of E regarded as negligible have been
!    replaced by zero, causing the matrix to split into a direct sum of
!    submatrices.  E2(1) is also set to zero.
!
!    Input, real (dp) LB, UB, define the interval to be searched for
!    eigenvalues.  If LB is not less than UB, no eigenvalues will be found.
!
!    Input, integer ( i4 ) MM, an upper bound for the number of
!    eigenvalues in the interval.  If more than MM eigenvalues are determined
!    to lie in the interval, an error return is made with no values or vectors
!    found.
!
!    Output, integer ( i4 ) M, the number of eigenvalues determined to lie
!    in (LB, UB).
!
!    Output, real (dp) W(M), the eigenvalues in ascending order if the
!    matrix does not split.  If the matrix splits, the eigenvalues are in
!    ascending order for each submatrix.  If a vector error exit is made, W
!    contains those values already found.
!
!    Output, real (dp) Z(N,MM), the associated set of orthonormal
!    eigenvectors.  If an error exit is made, Z contains those vectors already
!    found.
!
!    Output, integer ( i4 ) IERR, error flag.
!    0, normal return.
!    3*N+1, if M exceeds MM.
!    4*N+R, if the eigenvector corresponding to the R-th
!      eigenvalue fails to converge in 5 iterations.
!
  implicit none

  integer ( i4 ) mm
  integer ( i4 ) n

  real (dp) d(n)
  real (dp) e(n)
  real (dp) e2(n)
  real (dp) eps1
  real (dp) eps2
  real (dp) eps3
  real (dp) eps4
  integer ( i4 ) group
  integer ( i4 ) i
  integer ( i4 ) ierr
  integer ( i4 ) ii
  integer ( i4 ) ip
  integer ( i4 ) isturm
  integer ( i4 ) its
  integer ( i4 ) j
  integer ( i4 ) jj
  integer ( i4 ) k
  real (dp) lb
  integer ( i4 ) m
  integer ( i4 ) m1
  integer ( i4 ) m2
  real (dp) norm
  integer ( i4 ) p
!  real (dp) pythag  ! removed as this is now in the same module
  integer ( i4 ) q
  integer ( i4 ) r
  real (dp) rv1(n)
  real (dp) rv2(n)
  real (dp) rv3(n)
  real (dp) rv4(n)
  real (dp) rv5(n)
  real (dp) rv6(n)
  integer ( i4 ) s
  real (dp) t1
  real (dp) t2
  real (dp) tst1
  real (dp) tst2
  real (dp) u
  real (dp) ub
  real (dp) uk
  real (dp) v
  real (dp) w(mm)
  real (dp) x0
  real (dp) x1
  real (dp) xu
  real (dp) z(n,mm)

  ierr = 0
  s = 0
  t1 = lb
  t2 = ub
!
!  Look for small sub-diagonal entries.
!
  e2(1) = 0.0D+00

  do i = 2, n

    tst1 = abs ( d(i) ) + abs ( d(i-1) )
    tst2 = tst1 + abs ( e(i) )

    if ( tst2 <= tst1 ) then
      e2(i) = 0.0D+00
    end if

  end do
!
!  Determine the number of eigenvalues in the interval.
!
  p = 1
  q = n
  x1 = ub
  isturm = 1
  go to 320

60 continue

  m = s
  x1 = lb
  isturm = 2
  go to 320

80 continue

  m = m - s

  if ( mm < m ) then
    go to 980
  end if

  q = 0
  r = 0
!
!  Establish and process next submatrix, refining interval by the
!  Gerschgorin bounds.
!
100 continue

  if ( r == m ) then
    go to 1001
  end if

  p = q + 1
  xu = d(p)
  x0 = d(p)
  u = 0.0D+00

  do q = p, n

     x1 = u
     u = 0.0D+00
     v = 0.0D+00

     if ( q /= n ) then
       u = abs ( e(q+1) )
       v = e2(q+1)
     end if

     xu = min ( d(q) - ( x1 + u ), xu )
     x0 = max ( d(q) + ( x1 + u ), x0 )

     if ( v == 0.0D+00 ) then
       exit
     end if

  end do

  x1 = max ( abs ( xu ), abs ( x0 ) ) * epsilon ( x1 )

  if ( eps1 <= 0.0D+00 ) then
    eps1 = -x1
  end if

  if ( p /= q ) then
    go to 180
  end if
!
!  Check for isolated root within interval.
!
  if ( d(p) < t1 .or. t2 <= d(p) ) then
    go to 940
  end if

  r = r + 1

  z(1:n,r) = 0.0D+00

  w(r) = d(p)
  z(p,r) = 1.0D+00
  go to 940

180 continue

  u = q - p + 1
  x1 = u * x1
  lb = max ( t1, xu - x1 )
  ub = min ( t2, x0 + x1 )
  x1 = lb
  isturm = 3
  go to 320

200 continue

  m1 = s + 1
  x1 = ub
  isturm = 4
  go to 320

220 continue

  m2 = s
  if ( m2 < m1 ) then
    go to 940
  end if
!
!  Find roots by bisection.
!
  x0 = ub
  isturm = 5

  rv5(m1:m2) = ub
  rv4(m1:m2) = lb
!
!  Loop for K-th eigenvalue.
!
  k = m2

250 continue

  xu = lb

  do ii = m1, k

    i = m1 + k - ii

    if ( xu < rv4(i) ) then
      xu = rv4(i)
      exit
    end if

  end do

280 continue

  x0 = min ( x0, rv5(k) )
!
!  Next bisection step.
!
300 continue

     x1 = ( xu + x0 ) * 0.5D+00

     if ( ( x0 - xu ) <= abs ( eps1 ) ) then
       go to 420
     end if

     tst1 = 2.0D+00 * ( abs ( xu ) + abs ( x0 ) )
     tst2 = tst1 + (x0 - xu)

     if ( tst2 == tst1 ) then
       go to 420
     end if
!
!  Sturm sequence.
!
320  continue

     s = p - 1
     u = 1.0D+00

     do i = p, q

        if ( u /= 0.0D+00 ) then
          go to 325
        end if

        v = abs ( e(i) ) / epsilon ( v )
        if ( e2(i) == 0.0D+00 ) then
          v = 0.0D+00
        end if

        go to 330

325     continue

        v = e2(i) / u
330     continue

        u = d(i) - x1 - v
        if ( u < 0.0D+00 ) then
          s = s + 1
        end if

     end do

!     go to ( 60,80,200,220,360 ), isturm
! Replaced computed GOTO with a select case structure
        select case (isturm)     
        case(1)
          GOTO 60
        case(2)
          GOTO 80
        case(3)
          GOTO 200
        case(4)
          GOTO 220
        case(5)
          GOTO 360
        case default     
          CONTINUE    
        end select
!
!  Refine intervals.
!
360  continue

     if ( k <= s ) then
       go to 400
     end if

     xu = x1

     if ( m1 <= s ) then
       go to 380
     end if

     rv4(m1) = x1
     go to 300

380  continue

     rv4(s+1) = x1
     if ( x1 < rv5(s) ) then
       rv5(s) = x1
     end if
     go to 300

400  continue

     x0 = x1
     go to 300
!
!  K-th eigenvalue found.
!
420  continue

  rv5(k) = x1
  k = k - 1

  if ( m1 <= k ) then
    go to 250
  end if
!
!  Find vectors by inverse iteration.
!
  norm = abs ( d(p) )
  ip = p + 1

  do i = ip, q
    norm = max ( norm, abs ( d(i) ) + abs ( e(i) ) )
  end do
!
!  EPS2 is the criterion for grouping,
!  EPS3 replaces zero pivots and equal roots are modified by eps3,
!  EPS4 is taken very small to avoid overflow.
!
  eps2 = 0.001D+00 * norm
  eps3 = abs ( norm ) * epsilon ( eps3 )
  uk = q - p + 1
  eps4 = uk * eps3
  uk = eps4 / sqrt ( uk )
  group = 0
  s = p

  do k = m1, m2

     r = r + 1
     its = 1
     w(r) = rv5(k)
     x1 = rv5(k)
!
!  Look for close or coincident roots.
!
     if ( k /= m1 ) then
       if ( eps2 <= x1 - x0 ) then
         group = -1
       end if
       group = group + 1
       if ( x1 <= x0 ) then
         x1 = x0 + eps3
       end if
     end if
!
!  Elimination with interchanges and initialization of vector.
!
520  continue

     v = 0.0D+00

     do i = p, q

        rv6(i) = uk

        if ( i == p ) then
          go to 560
        end if

        if ( abs ( u ) <= abs ( e(i) ) ) then
          xu = u / e(i)
          rv4(i) = xu
          rv1(i-1) = e(i)
          rv2(i-1) = d(i) - x1
          rv3(i-1) = 0.0D+00
          if ( i /= q ) then
            rv3(i-1) = e(i+1)
          end if
          u = v - xu * rv2(i-1)
          v = -xu * rv3(i-1)
          cycle
        end if

540     continue

        xu = e(i) / u
        rv4(i) = xu
        rv1(i-1) = u
        rv2(i-1) = v
        rv3(i-1) = 0.0D+00

560     continue

        u = d(i) - x1 - xu * v

        if ( i /= q ) then
          v = e(i+1)
        end if

     end do

     if ( u == 0.0D+00 ) then
       u = eps3
     end if

     rv1(q) = u
     rv2(q) = 0.0D+00
     rv3(q) = 0.0D+00
!
!  Back substitution.
!
600  continue

     do ii = p, q
        i = p + q - ii
        rv6(i) = ( rv6(i) - u * rv2(i) - v * rv3(i) ) / rv1(i)
        v = u
        u = rv6(i)
     end do
!
!  Orthogonalize with respect to previous members of group.
!
     do jj = 1, group
        j = r - group - 1 + jj
        xu = dot_product ( rv6(p:q), z(p:q,j) )
        rv6(p:q) = rv6(p:q) - xu * z(p:q,j)
     end do

700  continue

     norm = sum ( abs ( rv6(p:q) ) )

     if ( 1.0D+00 <= norm ) then
       go to 840
     end if
!
!  Forward substitution.
!
     if ( its == 5 ) then
       ierr = 4 * n + r
       go to 1001
     end if

     if ( norm == 0.0D+00 ) then
       rv6(s) = eps4
       s = s + 1
       if ( q < s ) then
         s = p
       end if
       go to 780
     end if

740  continue

    xu = eps4 / norm

     rv6(p:q) = rv6(p:q) * xu
!
!  Elimination operations on next vector iterate.
!
780    continue
!
!  If rv1(i-1) == e(i), a row interchange was performed earlier in the
!  triangularization process.
!
     do i = p, q

       u = rv6(i)

       if ( rv1(i-1) == e(i) ) then
         u = rv6(i-1)
         rv6(i-1) = rv6(i)
       end if

       rv6(i) = u - rv4(i) * rv6(i-1)

     end do

     its = its + 1
     go to 600
!
!  Normalize so that sum of squares is 1 and expand to full order.
!
840  continue

     u = 0.0D+00

     do i = p, q
       u = pythag ( u, rv6(i) )
     end do

     xu = 1.0D+00 / u

     z(1:n,r) = 0.0D+00
     z(p:q,r) = rv6(p:q) * xu

     x0 = x1

  end do

940 continue

  if ( q < n ) then
    go to 100
  end if

  go to 1001
!
!  Set error: underestimate of number of eigenvalues in interval.
!
980 continue

  ierr = 3 * n + 1

1001 continue

  lb = t1
  ub = t2

  return
end subroutine tsturm

END MODULE eispack
