function d_is_int ( r )

!*******************************************************************************
!
!! D_IS_INT determines if a double precision number represents an integer value.
!
!  Modified:
!
!    07 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) R, the number to be checked.
!
!    Output, logical D_IS_INT, is TRUE if R is an integer value.
!
  implicit none
!
  integer, parameter :: i = 1
  real ( kind = 8 ) r
  logical d_is_int
!
  if ( real ( huge ( i ), kind = 8 ) < r ) then
    d_is_int = .false.
  else if ( r < - real ( huge ( i ), kind = 8 ) ) then
    d_is_int = .false.
  else if ( r == real ( int ( r ), kind = 8 ) ) then
    d_is_int = .true.
  else
    d_is_int = .false.
  end if

  return
end
      SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     December 1, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPQ, UPLO
      INTEGER            INFO, LDU, LDVT, N
!     ..
!     .. Array Arguments ..
      INTEGER            IQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), Q( * ), U( LDU, * ), &
                         VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DBDSDC computes the singular value decomposition (SVD) of a real
!  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
!  using a divide and conquer method, where S is a diagonal matrix
!  with non-negative diagonal elements (the singular values of B), and
!  U and VT are orthogonal matrices of left and right singular vectors,
!  respectively. DBDSDC can be used to compute all singular values,
!  and optionally, singular vectors or singular vectors in compact form.
!
!  This code makes very mild assumptions about floating point
!  arithmetic. It will work on machines with a guard digit in
!  add/subtract, or on those binary machines without guard digits
!  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!  It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.  See DLASD3 for details.
!
!  The code currently call DLASDQ if singular values only are desired.
!  However, it can be slightly modified to compute singular values
!  using the divide and conquer method.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  B is upper bidiagonal.
!          = 'L':  B is lower bidiagonal.
!
!  COMPQ   (input) CHARACTER*1
!          Specifies whether singular vectors are to be computed
!          as follows:
!          = 'N':  Compute singular values only;
!          = 'P':  Compute singular values and compute singular
!                  vectors in compact form;
!          = 'I':  Compute singular values and singular vectors.
!
!  N       (input) INTEGER
!          The order of the matrix B.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the bidiagonal matrix B.
!          On exit, if INFO=0, the singular values of B.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the elements of E contain the offdiagonal
!          elements of the bidiagonal matrix whose SVD is desired.
!          On exit, E has been destroyed.
!
!  U       (output) DOUBLE PRECISION array, dimension (LDU,N)
!          If  COMPQ = 'I', then:
!             On exit, if INFO = 0, U contains the left singular vectors
!             of the bidiagonal matrix.
!          For other values of COMPQ, U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U.  LDU >= 1.
!          If singular vectors are desired, then LDU >= max( 1, N ).
!
!  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
!          If  COMPQ = 'I', then:
!             On exit, if INFO = 0, VT' contains the right singular
!             vectors of the bidiagonal matrix.
!          For other values of COMPQ, VT is not referenced.
!
!  LDVT    (input) INTEGER
!          The leading dimension of the array VT.  LDVT >= 1.
!          If singular vectors are desired, then LDVT >= max( 1, N ).
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ)
!          If  COMPQ = 'P', then:
!             On exit, if INFO = 0, Q and IQ contain the left
!             and right singular vectors in a compact form,
!             requiring O(N log N) space instead of 2*N**2.
!             In particular, Q contains all the DOUBLE PRECISION data in
!             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
!             words of memory, where SMLSIZ is returned by ILAENV and
!             is equal to the maximum size of the subproblems at the
!             bottom of the computation tree (usually about 25).
!          For other values of COMPQ, Q is not referenced.
!
!  IQ      (output) INTEGER array, dimension (LDIQ)
!          If  COMPQ = 'P', then:
!             On exit, if INFO = 0, Q and IQ contain the left
!             and right singular vectors in a compact form,
!             requiring O(N log N) space instead of 2*N**2.
!             In particular, IQ contains all INTEGER data in
!             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
!             words of memory, where SMLSIZ is returned by ILAENV and
!             is equal to the maximum size of the subproblems at the
!             bottom of the computation tree (usually about 25).
!          For other values of COMPQ, IQ is not referenced.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)
!          If COMPQ = 'N' then LWORK >= (4 * N).
!          If COMPQ = 'P' then LWORK >= (6 * N).
!          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
!
!  IWORK   (workspace) INTEGER array, dimension (8*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  The algorithm failed to compute an singular value.
!                The update process of divide and conquer failed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC, &
                         ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK, &
                         MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ, &
                         SMLSZP, SQRE, START, WSTART, Z
      DOUBLE PRECISION   CS, EPS, ORGNRM, P, R, SN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ, &
                         DLASET, DLASR, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG, SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IUPLO = 0
      IF( LSAME( UPLO, 'U' ) ) &
         IUPLO = 1
      IF( LSAME( UPLO, 'L' ) ) &
         IUPLO = 2
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ICOMPQ = 0
      ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ICOMPQ = 2
      ELSE
         ICOMPQ = -1
      END IF
      IF( IUPLO.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT. &
               N ) ) ) THEN
         INFO = -7
      ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT. &
               N ) ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DBDSDC', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
      SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
      IF( N.EQ.1 ) THEN
         IF( ICOMPQ.EQ.1 ) THEN
            Q( 1 ) = SIGN( ONE, D( 1 ) )
            Q( 1+SMLSIZ*N ) = ONE
         ELSE IF( ICOMPQ.EQ.2 ) THEN
            U( 1, 1 ) = SIGN( ONE, D( 1 ) )
            VT( 1, 1 ) = ONE
         END IF
         D( 1 ) = ABS( D( 1 ) )
         RETURN
      END IF
      NM1 = N - 1
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left
!
      WSTART = 1
      QSTART = 3
      IF( ICOMPQ.EQ.1 ) THEN
         CALL DCOPY( N, D, 1, Q( 1 ), 1 )
         CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
      END IF
      IF( IUPLO.EQ.2 ) THEN
         QSTART = 5
         WSTART = 2*N - 1
         DO I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( ICOMPQ.EQ.1 ) THEN
               Q( I+2*N ) = CS
               Q( I+3*N ) = SN
            ELSE IF( ICOMPQ.EQ.2 ) THEN
               WORK( I ) = CS
               WORK( NM1+I ) = -SN
            END IF
         end do
      END IF
!
!     If ICOMPQ = 0, use DLASDQ to compute the singular values.
!
      IF( ICOMPQ.EQ.0 ) THEN
         CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U, &
                      LDU, WORK( WSTART ), INFO )
         GO TO 40
      END IF
!
!     If N is smaller than the minimum divide size SMLSIZ, then solve
!     the problem with another solver.
!
      IF( N.LE.SMLSIZ ) THEN
         IF( ICOMPQ.EQ.2 ) THEN
            CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
            CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
            CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U, &
                         LDU, WORK( WSTART ), INFO )
         ELSE IF( ICOMPQ.EQ.1 ) THEN
            IU = 1
            IVT = IU + N
            CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ), &
                         N )
            CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ), &
                         N )
            CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, &
                         Q( IVT+( QSTART-1 )*N ), N, &
                         Q( IU+( QSTART-1 )*N ), N, &
                         Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ), &
                         INFO )
         END IF
         GO TO 40
      END IF
!
      IF( ICOMPQ.EQ.2 ) THEN
         CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
         CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
      END IF
!
!     Scale.
!
      ORGNRM = DLANST( 'M', N, D, E )
      IF( ORGNRM.EQ.ZERO ) &
         RETURN
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
!
      EPS = DLAMCH( 'Epsilon' )
!
      MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
      SMLSZP = SMLSIZ + 1
!
      IF( ICOMPQ.EQ.1 ) THEN
         IU = 1
         IVT = 1 + SMLSIZ
         DIFL = IVT + SMLSZP
         DIFR = DIFL + MLVL
         Z = DIFR + MLVL*2
         IC = Z + MLVL
         IS = IC + 1
         POLES = IS + 1
         GIVNUM = POLES + 2*MLVL
!
         K = 1
         GIVPTR = 2
         PERM = 3
         GIVCOL = PERM + MLVL
      END IF
!
      DO 20 I = 1, N
         IF( ABS( D( I ) ).LT.EPS ) THEN
            D( I ) = SIGN( EPS, D( I ) )
         END IF
   20 CONTINUE
!
      START = 1
      SQRE = 0
!
      DO 30 I = 1, NM1
         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
!
!        Subproblem found. First determine its size and then
!        apply divide and conquer on it.
!
            IF( I.LT.NM1 ) THEN
!
!        A subproblem with E(I) small for I < NM1.
!
               NSIZE = I - START + 1
            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
!
!        A subproblem with E(NM1) not too small but I = NM1.
!
               NSIZE = N - START + 1
            ELSE
!
!        A subproblem with E(NM1) small. This implies an
!        1-by-1 subproblem at D(N). Solve this 1-by-1 problem
!        first.
!
               NSIZE = I - START + 1
               IF( ICOMPQ.EQ.2 ) THEN
                  U( N, N ) = SIGN( ONE, D( N ) )
                  VT( N, N ) = ONE
               ELSE IF( ICOMPQ.EQ.1 ) THEN
                  Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
                  Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
               END IF
               D( N ) = ABS( D( N ) )
            END IF
            IF( ICOMPQ.EQ.2 ) THEN
               CALL DLASD0( NSIZE, SQRE, D( START ), E( START ), &
                            U( START, START ), LDU, VT( START, START ), &
                            LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
            ELSE
               CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ), &
                            E( START ), Q( START+( IU+QSTART-2 )*N ), N, &
                            Q( START+( IVT+QSTART-2 )*N ), &
                            IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )* &
                            N ), Q( START+( DIFR+QSTART-2 )*N ), &
                            Q( START+( Z+QSTART-2 )*N ), &
                            Q( START+( POLES+QSTART-2 )*N ), &
                            IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ), &
                            N, IQ( START+PERM*N ), &
                            Q( START+( GIVNUM+QSTART-2 )*N ), &
                            Q( START+( IC+QSTART-2 )*N ), &
                            Q( START+( IS+QSTART-2 )*N ), &
                            WORK( WSTART ), IWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
            END IF
            START = I + 1
         END IF
   30 CONTINUE
!
!     Unscale
!
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
   40 CONTINUE
!
!     Use Selection Sort to minimize swaps of singular vectors
!
      DO 60 II = 2, N
         I = II - 1
         KK = I
         P = D( I )
         DO 50 J = II, N
            IF( D( J ).GT.P ) THEN
               KK = J
               P = D( J )
            END IF
   50    CONTINUE
         IF( KK.NE.I ) THEN
            D( KK ) = D( I )
            D( I ) = P
            IF( ICOMPQ.EQ.1 ) THEN
               IQ( I ) = KK
            ELSE IF( ICOMPQ.EQ.2 ) THEN
               CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
               CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
            END IF
         ELSE IF( ICOMPQ.EQ.1 ) THEN
            IQ( I ) = I
         END IF
   60 CONTINUE
!
!     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
!
      IF( ICOMPQ.EQ.1 ) THEN
         IF( IUPLO.EQ.1 ) THEN
            IQ( N ) = 1
         ELSE
            IQ( N ) = 0
         END IF
      END IF
!
!     If B is lower bidiagonal, update U by those Givens rotations
!     which rotated B to be upper bidiagonal
!
      IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) ) &
         CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
!
      RETURN
!
!     End of DBDSDC
!
      END
      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, &
                         LDU, C, LDC, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ), &
                         VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DBDSQR computes the singular value decomposition (SVD) of a real
!  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
!  denotes the transpose of P), where S is a diagonal matrix with
!  non-negative diagonal elements (the singular values of B), and Q
!  and P are orthogonal matrices.
!
!  The routine computes S, and optionally computes U * Q, P' * VT,
!  or Q' * C, for given real input matrices U, VT, and C.
!
!  See "Computing  Small Singular Values of Bidiagonal Matrices With
!  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
!  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
!  no. 5, pp. 873-912, Sept 1990) and
!  "Accurate singular values and differential qd algorithms," by
!  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
!  Department, University of California at Berkeley, July 1992
!  for a detailed description of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  B is upper bidiagonal;
!          = 'L':  B is lower bidiagonal.
!
!  N       (input) INTEGER
!          The order of the matrix B.  N >= 0.
!
!  NCVT    (input) INTEGER
!          The number of columns of the matrix VT. NCVT >= 0.
!
!  NRU     (input) INTEGER
!          The number of rows of the matrix U. NRU >= 0.
!
!  NCC     (input) INTEGER
!          The number of columns of the matrix C. NCC >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the bidiagonal matrix B.
!          On exit, if INFO=0, the singular values of B in decreasing
!          order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the elements of E contain the
!          offdiagonal elements of the bidiagonal matrix whose SVD
!          is desired. On normal exit (INFO = 0), E is destroyed.
!          If the algorithm does not converge (INFO > 0), D and E
!          will contain the diagonal and superdiagonal elements of a
!          bidiagonal matrix orthogonally equivalent to the one given
!          as input. E(N) is used for workspace.
!
!  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
!          On entry, an N-by-NCVT matrix VT.
!          On exit, VT is overwritten by P' * VT.
!          VT is not referenced if NCVT = 0.
!
!  LDVT    (input) INTEGER
!          The leading dimension of the array VT.
!          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
!
!  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)
!          On entry, an NRU-by-N matrix U.
!          On exit, U is overwritten by U * Q.
!          U is not referenced if NRU = 0.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U.  LDU >= max(1,NRU).
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
!          On entry, an N-by-NCC matrix C.
!          On exit, C is overwritten by Q' * C.
!          C is not referenced if NCC = 0.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C.
!          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  If INFO = -i, the i-th argument had an illegal value
!          > 0:  the algorithm did not converge; D and E contain the
!                elements of a bidiagonal matrix which is orthogonally
!                similar to the input matrix B;  if INFO = i, i
!                elements of E have not converged to zero.
!
!  Internal Parameters
!  ===================
!
!  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
!          TOLMUL controls the convergence criterion of the QR loop.
!          If it is positive, TOLMUL*EPS is the desired relative
!             precision in the computed singular values.
!          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
!             desired absolute accuracy in the computed singular
!             values (corresponds to relative accuracy
!             abs(TOLMUL*EPS) in the largest singular value.
!          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
!             between 10 (for fast convergence) and .1/EPS
!             (for there to be some accuracy in the results).
!          Default is to lose at either one eighth or 2 of the
!             available decimal digits in each computed singular value
!             (whichever is smaller).
!
!  MAXITR  INTEGER, default = 6
!          MAXITR controls the maximum number of passes of the
!          algorithm through its inner loop. The algorithms stops
!          (and so fails to converge) if the number of passes
!          through the inner loop exceeds MAXITR*N**2.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   NEGONE
      PARAMETER          ( NEGONE = -1.0D0 )
      DOUBLE PRECISION   HNDRTH
      PARAMETER          ( HNDRTH = 0.01D0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 10.0D0 )
      DOUBLE PRECISION   HNDRD
      PARAMETER          ( HNDRD = 100.0D0 )
      DOUBLE PRECISION   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      INTEGER            MAXITR
      PARAMETER          ( MAXITR = 6 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LOWER, ROTATE
      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, &
                         NM12, NM13, OLDLL, OLDM
      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, &
                         OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, &
                         SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, &
                         SN, THRESH, TOL, TOLMUL, UNFL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, &
                         DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      LOWER = LSAME( UPLO, 'L' )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NCVT.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NCC.LT.0 ) THEN
         INFO = -5
      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. &
               ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
         INFO = -9
      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
         INFO = -11
      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. &
               ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DBDSQR', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 ) &
         RETURN
      IF( N.EQ.1 ) &
         GO TO 160
!
!     ROTATE is true if any singular vectors desired, false otherwise
!
      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
!
!     If no singular vectors desired, use qd algorithm
!
      IF( .NOT.ROTATE ) THEN
         CALL DLASQ1( N, D, E, WORK, INFO )
         RETURN
      END IF
!
      NM1 = N - 1
      NM12 = NM1 + NM1
      NM13 = NM12 + NM1
      IDIR = 0
!
!     Get machine constants
!
      EPS = DLAMCH( 'Epsilon' )
      UNFL = DLAMCH( 'Safe minimum' )
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left
!
      IF( LOWER ) THEN
         DO I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            WORK( I ) = CS
            WORK( NM1+I ) = SN
         end do
!
!  Update singular vectors if desired
!
         IF( NRU.GT.0 ) &
            CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, &
                        LDU )
         IF( NCC.GT.0 ) &
            CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, &
                        LDC )
      END IF
!
!     Compute singular values to relative accuracy TOL
!     (By setting TOL to be negative, algorithm will compute
!     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
!
      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
      TOL = TOLMUL*EPS
!
!     Compute approximate maximum, minimum singular values
!
      SMAX = ZERO
      DO 20 I = 1, N
         SMAX = MAX( SMAX, ABS( D( I ) ) )
   20 CONTINUE
      DO 30 I = 1, N - 1
         SMAX = MAX( SMAX, ABS( E( I ) ) )
   30 CONTINUE
      SMINL = ZERO
      IF( TOL.GE.ZERO ) THEN
!
!        Relative accuracy desired
!
         SMINOA = ABS( D( 1 ) )
         IF( SMINOA.EQ.ZERO ) &
            GO TO 50
         MU = SMINOA
         DO 40 I = 2, N
            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
            SMINOA = MIN( SMINOA, MU )
            IF( SMINOA.EQ.ZERO ) &
               GO TO 50
   40    CONTINUE
   50    CONTINUE
         SMINOA = SMINOA / SQRT( DBLE( N ) )
         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
      ELSE
!
!        Absolute accuracy desired
!
         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
      END IF
!
!     Prepare for main iteration loop for the singular values
!     (MAXIT is the maximum number of passes through the inner
!     loop permitted before nonconvergence signalled.)
!
      MAXIT = MAXITR*N*N
      ITER = 0
      OLDLL = -1
      OLDM = -1
!
!     M points to last element of unconverged part of matrix
!
      M = N
!
!     Begin main iteration loop
!
   60 CONTINUE
!
!     Check for convergence or exceeding iteration count
!
      IF( M.LE.1 ) &
         GO TO 160
      IF( ITER.GT.MAXIT ) &
         GO TO 200
!
!     Find diagonal block of matrix to work on
!
      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) &
         D( M ) = ZERO
      SMAX = ABS( D( M ) )
      SMIN = SMAX
      DO 70 LLL = 1, M - 1
         LL = M - LLL
         ABSS = ABS( D( LL ) )
         ABSE = ABS( E( LL ) )
         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) &
            D( LL ) = ZERO
         IF( ABSE.LE.THRESH ) &
            GO TO 80
         SMIN = MIN( SMIN, ABSS )
         SMAX = MAX( SMAX, ABSS, ABSE )
   70 CONTINUE
      LL = 0
      GO TO 90
   80 CONTINUE
      E( LL ) = ZERO
!
!     Matrix splits since E(LL) = 0
!
      IF( LL.EQ.M-1 ) THEN
!
!        Convergence of bottom singular value, return to top of loop
!
         M = M - 1
         GO TO 60
      END IF
   90 CONTINUE
      LL = LL + 1
!
!     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
!
      IF( LL.EQ.M-1 ) THEN
!
!        2 by 2 block, handle separately
!
         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, &
                      COSR, SINL, COSL )
         D( M-1 ) = SIGMX
         E( M-1 ) = ZERO
         D( M ) = SIGMN
!
!        Compute singular vectors, if desired
!
         IF( NCVT.GT.0 ) &
            CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, &
                       SINR )
         IF( NRU.GT.0 ) &
            CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
         IF( NCC.GT.0 ) &
            CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, &
                       SINL )
         M = M - 2
         GO TO 60
      END IF
!
!     If working on new submatrix, choose shift direction
!     (from larger end diagonal element towards smaller)
!
      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
!
!           Chase bulge from top (big end) to bottom (small end)
!
            IDIR = 1
         ELSE
!
!           Chase bulge from bottom (big end) to top (small end)
!
            IDIR = 2
         END IF
      END IF
!
!     Apply convergence tests
!
      IF( IDIR.EQ.1 ) THEN
!
!        Run convergence test in forward direction
!        First apply standard test to bottom of matrix
!
         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. &
             ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
            E( M-1 ) = ZERO
            GO TO 60
         END IF

         IF( TOL.GE.ZERO ) THEN
!
!  If relative accuracy desired, apply convergence criterion forward
!
            MU = ABS( D( LL ) )
            SMINL = MU
            DO LLL = LL, M - 1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 60
               END IF
               SMINLO = SMINL
               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
            end do
         END IF

      ELSE
!
!        Run convergence test in backward direction
!        First apply standard test to top of matrix
!
         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. &
             ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
            E( LL ) = ZERO
            GO TO 60
         END IF
!
         IF( TOL.GE.ZERO ) THEN
!
!           If relative accuracy desired,
!           apply convergence criterion backward
!
            MU = ABS( D( M ) )
            SMINL = MU
            DO 110 LLL = M - 1, LL, -1
               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
                  E( LLL ) = ZERO
                  GO TO 60
               END IF
               SMINLO = SMINL
               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
               SMINL = MIN( SMINL, MU )
  110       CONTINUE
         END IF
      END IF
      OLDLL = LL
      OLDM = M
!
!     Compute shift.  First, test if shifting would ruin relative
!     accuracy, and if so set the shift to zero.
!
      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. &
          MAX( EPS, HNDRTH*TOL ) ) THEN
!
!        Use a zero shift to avoid loss of relative accuracy
!
         SHIFT = ZERO
      ELSE
!
!        Compute the shift from 2-by-2 block at end of matrix
!
         IF( IDIR.EQ.1 ) THEN
            SLL = ABS( D( LL ) )
            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
         ELSE
            SLL = ABS( D( M ) )
            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
         END IF
!
!        Test if shift negligible, and if so set to zero
!
         IF( SLL.GT.ZERO ) THEN
            IF( ( SHIFT / SLL )**2.LT.EPS ) &
               SHIFT = ZERO
         END IF
      END IF
!
!     Increment iteration count
!
      ITER = ITER + M - LL
!
!     If SHIFT = 0, do simplified QR iteration
!
      IF( SHIFT.EQ.ZERO ) THEN
         IF( IDIR.EQ.1 ) THEN
!
!           Chase bulge from top to bottom
!           Save cosines and sines for later singular vector updates
!
            CS = ONE
            OLDCS = ONE
            DO 120 I = LL, M - 1
               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
               IF( I.GT.LL ) &
                  E( I-1 ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
               WORK( I-LL+1 ) = CS
               WORK( I-LL+1+NM1 ) = SN
               WORK( I-LL+1+NM12 ) = OLDCS
               WORK( I-LL+1+NM13 ) = OLDSN
  120       CONTINUE
            H = D( M )*CS
            D( M ) = H*OLDCS
            E( M-1 ) = H*OLDSN
!
!           Update singular vectors
!
            IF( NCVT.GT.0 ) &
               CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), &
                           WORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 ) &
               CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), &
                           WORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 ) &
               CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), &
                           WORK( NM13+1 ), C( LL, 1 ), LDC )
!
!           Test convergence
!
            IF( ABS( E( M-1 ) ).LE.THRESH ) &
               E( M-1 ) = ZERO
!
         ELSE
!
!           Chase bulge from bottom to top
!           Save cosines and sines for later singular vector updates
!
            CS = ONE
            OLDCS = ONE
            DO 130 I = M, LL + 1, -1
               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
               IF( I.LT.M ) &
                  E( I ) = OLDSN*R
               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
               WORK( I-LL ) = CS
               WORK( I-LL+NM1 ) = -SN
               WORK( I-LL+NM12 ) = OLDCS
               WORK( I-LL+NM13 ) = -OLDSN
  130       CONTINUE
            H = D( LL )*CS
            D( LL ) = H*OLDCS
            E( LL ) = H*OLDSN
!
!           Update singular vectors
!
            IF( NCVT.GT.0 ) &
               CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), &
                           WORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 ) &
               CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), &
                           WORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 ) &
               CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), &
                           WORK( N ), C( LL, 1 ), LDC )
!
!           Test convergence
!
            IF( ABS( E( LL ) ).LE.THRESH ) &
               E( LL ) = ZERO
         END IF
      ELSE
!
!        Use nonzero shift
!
         IF( IDIR.EQ.1 ) THEN
!
!           Chase bulge from top to bottom
!           Save cosines and sines for later singular vector updates
!
            F = ( ABS( D( LL ) )-SHIFT )* &
                ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
            G = E( LL )
            DO 140 I = LL, M - 1
               CALL DLARTG( F, G, COSR, SINR, R )
               IF( I.GT.LL ) &
                  E( I-1 ) = R
               F = COSR*D( I ) + SINR*E( I )
               E( I ) = COSR*E( I ) - SINR*D( I )
               G = SINR*D( I+1 )
               D( I+1 ) = COSR*D( I+1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I ) + SINL*D( I+1 )
               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
               IF( I.LT.M-1 ) THEN
                  G = SINL*E( I+1 )
                  E( I+1 ) = COSL*E( I+1 )
               END IF
               WORK( I-LL+1 ) = COSR
               WORK( I-LL+1+NM1 ) = SINR
               WORK( I-LL+1+NM12 ) = COSL
               WORK( I-LL+1+NM13 ) = SINL
  140       CONTINUE
            E( M-1 ) = F
!
!           Update singular vectors
!
            IF( NCVT.GT.0 ) &
               CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), &
                           WORK( N ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 ) &
               CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), &
                           WORK( NM13+1 ), U( 1, LL ), LDU )
            IF( NCC.GT.0 ) &
               CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), &
                           WORK( NM13+1 ), C( LL, 1 ), LDC )
!
!           Test convergence
!
            IF( ABS( E( M-1 ) ).LE.THRESH ) &
               E( M-1 ) = ZERO
!
         ELSE
!
!           Chase bulge from bottom to top
!           Save cosines and sines for later singular vector updates
!
            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / &
                D( M ) )
            G = E( M-1 )
            DO 150 I = M, LL + 1, -1
               CALL DLARTG( F, G, COSR, SINR, R )
               IF( I.LT.M ) &
                  E( I ) = R
               F = COSR*D( I ) + SINR*E( I-1 )
               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
               G = SINR*D( I-1 )
               D( I-1 ) = COSR*D( I-1 )
               CALL DLARTG( F, G, COSL, SINL, R )
               D( I ) = R
               F = COSL*E( I-1 ) + SINL*D( I-1 )
               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
               IF( I.GT.LL+1 ) THEN
                  G = SINL*E( I-2 )
                  E( I-2 ) = COSL*E( I-2 )
               END IF
               WORK( I-LL ) = COSR
               WORK( I-LL+NM1 ) = -SINR
               WORK( I-LL+NM12 ) = COSL
               WORK( I-LL+NM13 ) = -SINL
  150       CONTINUE
            E( LL ) = F
!
!           Test convergence
!
            IF( ABS( E( LL ) ).LE.THRESH ) &
               E( LL ) = ZERO
!
!           Update singular vectors if desired
!
            IF( NCVT.GT.0 ) &
               CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), &
                           WORK( NM13+1 ), VT( LL, 1 ), LDVT )
            IF( NRU.GT.0 ) &
               CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), &
                           WORK( N ), U( 1, LL ), LDU )
            IF( NCC.GT.0 ) &
               CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), &
                           WORK( N ), C( LL, 1 ), LDC )
         END IF
      END IF
!
!     QR iteration finished, go back and check convergence
!
      GO TO 60
!
!     All singular values converged, so make them positive
!
  160 CONTINUE
      DO 170 I = 1, N
         IF( D( I ).LT.ZERO ) THEN
            D( I ) = -D( I )
!
!           Change sign of singular vectors, if desired
!
            IF( NCVT.GT.0 ) &
               CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
         END IF
  170 CONTINUE
!
!     Sort the singular values into decreasing order (insertion sort on
!     singular values, but only one transposition per singular vector)
!
      DO 190 I = 1, N - 1
!
!        Scan for smallest D(I)
!
         ISUB = 1
         SMIN = D( 1 )
         DO 180 J = 2, N + 1 - I
            IF( D( J ).LE.SMIN ) THEN
               ISUB = J
               SMIN = D( J )
            END IF
  180    CONTINUE
         IF( ISUB.NE.N+1-I ) THEN
!
!           Swap singular values and vectors
!
            D( ISUB ) = D( N+1-I )
            D( N+1-I ) = SMIN
            IF( NCVT.GT.0 ) &
               CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), &
                           LDVT )
            IF( NRU.GT.0 ) &
               CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
            IF( NCC.GT.0 ) &
               CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
         END IF
  190 CONTINUE
      GO TO 220
!
!     Maximum number of iterations exceeded, failure to converge
!
  200 CONTINUE
      INFO = 0
      DO 210 I = 1, N - 1
         IF( E( I ).NE.ZERO ) &
            INFO = INFO + 1
  210 CONTINUE
  220 CONTINUE
      RETURN
!
!     End of DBDSQR
!
      END
      SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), SEP( * )
!     ..
!
!  Purpose
!  =======
!
!  DDISNA computes the reciprocal condition numbers for the eigenvectors
!  of a real symmetric or complex Hermitian matrix or for the left or
!  right singular vectors of a general m-by-n matrix. The reciprocal
!  condition number is the 'gap' between the corresponding eigenvalue or
!  singular value and the nearest other one.
!
!  The bound on the error, measured by angle in radians, in the I-th
!  computed vector is given by
!
!         DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
!
!  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
!  to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
!  the error bound.
!
!  DDISNA may also be used to compute error bounds for eigenvectors of
!  the generalized symmetric definite eigenproblem.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies for which problem the reciprocal condition numbers
!          should be computed:
!          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
!          = 'L':  the left singular vectors of a general matrix;
!          = 'R':  the right singular vectors of a general matrix.
!
!  M       (input) INTEGER
!          The number of rows of the matrix. M >= 0.
!
!  N       (input) INTEGER
!          If JOB = 'L' or 'R', the number of columns of the matrix,
!          in which case N >= 0. Ignored if JOB = 'E'.
!
!  D       (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
!                              dimension (min(M,N)) if JOB = 'L' or 'R'
!          The eigenvalues (if JOB = 'E') or singular values (if JOB =
!          'L' or 'R') of the matrix, in either increasing or decreasing
!          order. If singular values, they must be non-negative.
!
!  SEP     (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
!                               dimension (min(M,N)) if JOB = 'L' or 'R'
!          The reciprocal condition numbers of the vectors.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            DECR, EIGEN, INCR, LEFT, RIGHT, SING
      INTEGER            I, K
      DOUBLE PRECISION   ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      EIGEN = LSAME( JOB, 'E' )
      LEFT = LSAME( JOB, 'L' )
      RIGHT = LSAME( JOB, 'R' )
      SING = LEFT .OR. RIGHT
      IF( EIGEN ) THEN
         K = M
      ELSE IF( SING ) THEN
         K = MIN( M, N )
      END IF
      IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( K.LT.0 ) THEN
         INFO = -3
      ELSE
         INCR = .TRUE.
         DECR = .TRUE.
         DO I = 1, K - 1
            IF( INCR ) &
               INCR = INCR .AND. D( I ).LE.D( I+1 )
            IF( DECR ) &
               DECR = DECR .AND. D( I ).GE.D( I+1 )
         end do
         IF( SING .AND. K.GT.0 ) THEN
            IF( INCR ) &
               INCR = INCR .AND. ZERO.LE.D( 1 )
            IF( DECR ) &
               DECR = DECR .AND. D( K ).GE.ZERO
         END IF
         IF( .NOT.( INCR .OR. DECR ) ) &
            INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DDISNA', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.0 ) &
         RETURN
!
!     Compute reciprocal condition numbers
!
      IF( K.EQ.1 ) THEN
         SEP( 1 ) = DLAMCH( 'O' )
      ELSE
         OLDGAP = ABS( D( 2 )-D( 1 ) )
         SEP( 1 ) = OLDGAP
         DO 20 I = 2, K - 1
            NEWGAP = ABS( D( I+1 )-D( I ) )
            SEP( I ) = MIN( OLDGAP, NEWGAP )
            OLDGAP = NEWGAP
   20    CONTINUE
         SEP( K ) = OLDGAP
      END IF
      IF( SING ) THEN
         IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
            IF( INCR ) &
               SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
            IF( DECR ) &
               SEP( K ) = MIN( SEP( K ), D( K ) )
         END IF
      END IF
!
!     Ensure that reciprocal condition numbers are not less than
!     threshold, in order to limit the size of the error bound
!
      EPS = DLAMCH( 'E' )
      SAFMIN = DLAMCH( 'S' )
      ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
      IF( ANORM.EQ.ZERO ) THEN
         THRESH = EPS
      ELSE
         THRESH = MAX( EPS*ANORM, SAFMIN )
      END IF
      DO 30 I = 1, K
         SEP( I ) = MAX( SEP( I ), THRESH )
   30 CONTINUE
!
      RETURN
!
!     End of DDISNA
!
      END
      SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, &
                         LDQ, PT, LDPT, C, LDC, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          VECT
      INTEGER            INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), &
                         PT( LDPT, * ), Q( LDQ, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGBBRD reduces a real general m-by-n band matrix A to upper
!  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
!
!  The routine computes B, and optionally forms Q or P', or computes
!  Q'*C for a given matrix C.
!
!  Arguments
!  =========
!
!  VECT    (input) CHARACTER*1
!          Specifies whether or not the matrices Q and P' are to be
!          formed.
!          = 'N': do not form Q or P';
!          = 'Q': form Q only;
!          = 'P': form P' only;
!          = 'B': form both.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  NCC     (input) INTEGER
!          The number of columns of the matrix C.  NCC >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals of the matrix A. KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals of the matrix A. KU >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the m-by-n band matrix A, stored in rows 1 to
!          KL+KU+1. The j-th column of A is stored in the j-th column of
!          the array AB as follows:
!          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
!          On exit, A is overwritten by values generated during the
!          reduction.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array A. LDAB >= KL+KU+1.
!
!  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The diagonal elements of the bidiagonal matrix B.
!
!  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
!          The superdiagonal elements of the bidiagonal matrix B.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ,M)
!          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
!          If VECT = 'N' or 'P', the array Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.
!          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
!
!  PT      (output) DOUBLE PRECISION array, dimension (LDPT,N)
!          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
!          If VECT = 'N' or 'Q', the array PT is not referenced.
!
!  LDPT    (input) INTEGER
!          The leading dimension of the array PT.
!          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
!          On entry, an m-by-ncc matrix C.
!          On exit, C is overwritten by Q'*C.
!          C is not referenced if NCC = 0.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C.
!          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            WANTB, WANTC, WANTPT, WANTQ
      INTEGER            I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1, &
                         KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
      DOUBLE PRECISION   RA, RB, RC, RS
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      WANTB = LSAME( VECT, 'B' )
      WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
      WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
      WANTC = NCC.GT.0
      KLU1 = KL + KU + 1
      INFO = 0
      IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) ) &
           THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCC.LT.0 ) THEN
         INFO = -4
      ELSE IF( KL.LT.0 ) THEN
         INFO = -5
      ELSE IF( KU.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KLU1 ) THEN
         INFO = -8
      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBBRD', -INFO )
         RETURN
      END IF
!
!     Initialize Q and P' to the unit matrix, if needed
!
      IF( WANTQ ) &
         CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
      IF( WANTPT ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
!
!     Quick return if possible.
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
      MINMN = MIN( M, N )
!
      IF( KL+KU.GT.1 ) THEN
!
!        Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
!        first to lower bidiagonal form and then transform to upper
!        bidiagonal
!
         IF( KU.GT.0 ) THEN
            ML0 = 1
            MU0 = 2
         ELSE
            ML0 = 2
            MU0 = 1
         END IF
!
!        Wherever possible, plane rotations are generated and applied in
!        vector operations of length NR over the index set J1:J2:KLU1.
!
!        The sines of the plane rotations are stored in WORK(1:max(m,n))
!        and the cosines in WORK(max(m,n)+1:2*max(m,n)).
!
         MN = MAX( M, N )
         KLM = MIN( M-1, KL )
         KUN = MIN( N-1, KU )
         KB = KLM + KUN
         KB1 = KB + 1
         INCA = KB1*LDAB
         NR = 0
         J1 = KLM + 2
         J2 = 1 - KUN

         DO 90 I = 1, MINMN
!
!  Reduce i-th column and i-th row of matrix to bidiagonal form
!
            ML = KLM + 1
            MU = KUN + 1
            DO 80 KK = 1, KB
               J1 = J1 + KB
               J2 = J2 + KB
!
!  generate plane rotations to annihilate nonzero elements
!  which have been created below the band
!
               IF( NR.GT.0 ) &
                  CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA, &
                               WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
!
!  apply plane rotations from the left
!
               DO L = 1, KB
                  IF( J2-KLM+L-1.GT.N ) THEN
                     NRT = NR - 1
                  ELSE
                     NRT = NR
                  END IF
                  IF( NRT.GT.0 ) &
                     CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA, &
                                  AB( KLU1-L+1, J1-KLM+L-1 ), INCA, &
                                  WORK( MN+J1 ), WORK( J1 ), KB1 )
               end do

               IF( ML.GT.ML0 ) THEN
                  IF( ML.LE.M-I+1 ) THEN
!
!                    generate plane rotation to annihilate a(i+ml-1,i)
!                    within the band, and apply rotation from the left
!
                     CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ), &
                                  WORK( MN+I+ML-1 ), WORK( I+ML-1 ), &
                                  RA )
                     AB( KU+ML-1, I ) = RA
                     IF( I.LT.N ) &
                        CALL DROT( MIN( KU+ML-2, N-I ), &
                                   AB( KU+ML-2, I+1 ), LDAB-1, &
                                   AB( KU+ML-1, I+1 ), LDAB-1, &
                                   WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
                  END IF
                  NR = NR + 1
                  J1 = J1 - KB1
               END IF
!
               IF( WANTQ ) THEN
!
!                 accumulate product of plane rotations in Q
!
                  DO 20 J = J1, J2, KB1
                     CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1, &
                                WORK( MN+J ), WORK( J ) )
   20             CONTINUE
               END IF
!
               IF( WANTC ) THEN
!
!                 apply plane rotations to C
!
                  DO 30 J = J1, J2, KB1
                     CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC, &
                                WORK( MN+J ), WORK( J ) )
   30             CONTINUE
               END IF
!
               IF( J2+KUN.GT.N ) THEN
!
!                 adjust J2 to keep within the bounds of the matrix
!
                  NR = NR - 1
                  J2 = J2 - KB1
               END IF
!
               DO 40 J = J1, J2, KB1
!
!                 create nonzero element a(j-1,j+ku) above the band
!                 and store it in WORK(n+1:2*n)
!
                  WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
                  AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
   40          CONTINUE
!
!              generate plane rotations to annihilate nonzero elements
!              which have been generated above the band
!
               IF( NR.GT.0 ) &
                  CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA, &
                               WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ), &
                               KB1 )
!
!              apply plane rotations from the right
!
               DO 50 L = 1, KB
                  IF( J2+L-1.GT.M ) THEN
                     NRT = NR - 1
                  ELSE
                     NRT = NR
                  END IF
                  IF( NRT.GT.0 ) &
                     CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA, &
                                  AB( L, J1+KUN ), INCA, &
                                  WORK( MN+J1+KUN ), WORK( J1+KUN ), &
                                  KB1 )
   50          CONTINUE
!
               IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
                  IF( MU.LE.N-I+1 ) THEN
!
!                    generate plane rotation to annihilate a(i,i+mu-1)
!                    within the band, and apply rotation from the right
!
                     CALL DLARTG( AB( KU-MU+3, I+MU-2 ), &
                                  AB( KU-MU+2, I+MU-1 ), &
                                  WORK( MN+I+MU-1 ), WORK( I+MU-1 ), &
                                  RA )
                     AB( KU-MU+3, I+MU-2 ) = RA
                     CALL DROT( MIN( KL+MU-2, M-I ), &
                                AB( KU-MU+4, I+MU-2 ), 1, &
                                AB( KU-MU+3, I+MU-1 ), 1, &
                                WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
                  END IF
                  NR = NR + 1
                  J1 = J1 - KB1
               END IF
!
               IF( WANTPT ) THEN
!
!                 accumulate product of plane rotations in P'
!
                  DO 60 J = J1, J2, KB1
                     CALL DROT( N, PT( J+KUN-1, 1 ), LDPT, &
                                PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ), &
                                WORK( J+KUN ) )
   60             CONTINUE
               END IF
!
               IF( J2+KB.GT.M ) THEN
!
!                 adjust J2 to keep within the bounds of the matrix
!
                  NR = NR - 1
                  J2 = J2 - KB1
               END IF
!
               DO 70 J = J1, J2, KB1
!
!                 create nonzero element a(j+kl+ku,j+ku-1) below the
!                 band and store it in WORK(1:n)
!
                  WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
                  AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
   70          CONTINUE
!
               IF( ML.GT.ML0 ) THEN
                  ML = ML - 1
               ELSE
                  MU = MU - 1
               END IF
   80       CONTINUE
   90    CONTINUE
      END IF

      IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
!
!        A has been reduced to lower bidiagonal form
!
!        Transform lower bidiagonal form to upper bidiagonal by applying
!        plane rotations from the left, storing diagonal elements in D
!        and off-diagonal elements in E
!
         DO I = 1, MIN( M-1, N )
            CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
            D( I ) = RA
            IF( I.LT.N ) THEN
               E( I ) = RS*AB( 1, I+1 )
               AB( 1, I+1 ) = RC*AB( 1, I+1 )
            END IF
            IF( WANTQ ) &
               CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
            IF( WANTC ) &
               CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC, &
                          RS )
         end do
         IF( M.LE.N ) &
            D( M ) = AB( 1, M )
      ELSE IF( KU.GT.0 ) THEN
!
!        A has been reduced to upper bidiagonal form
!
         IF( M.LT.N ) THEN
!
!           Annihilate a(m,m+1) by applying plane rotations from the
!           right, storing diagonal elements in D and off-diagonal
!           elements in E
!
            RB = AB( KU, M+1 )
            DO 110 I = M, 1, -1
               CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA )
               D( I ) = RA
               IF( I.GT.1 ) THEN
                  RB = -RS*AB( KU, I )
                  E( I-1 ) = RC*AB( KU, I )
               END IF
               IF( WANTPT ) &
                  CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT, &
                             RC, RS )
  110       CONTINUE
         ELSE
!
!           Copy off-diagonal elements to E and diagonal elements to D
!
            DO 120 I = 1, MINMN - 1
               E( I ) = AB( KU, I+1 )
  120       CONTINUE
            DO 130 I = 1, MINMN
               D( I ) = AB( KU+1, I )
  130       CONTINUE
         END IF
      ELSE
!
!        A is diagonal. Set elements of E to zero and copy diagonal
!        elements to D.
!
         DO 140 I = 1, MINMN - 1
            E( I ) = ZERO
  140    CONTINUE
         DO 150 I = 1, MINMN
            D( I ) = AB( 1, I )
  150    CONTINUE
      END IF
      RETURN
!
!     End of DGBBRD
!
      END
      SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, KL, KU, LDAB, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGBCON estimates the reciprocal of the condition number of a real
!  general band matrix A, in either the 1-norm or the infinity-norm,
!  using the LU factorization computed by DGBTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as
!     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          Details of the LU factorization of the band matrix A, as
!          computed by DGBTRF.  U is stored as an upper triangular band
!          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
!          the multipliers used during the factorization are stored in
!          rows KL+KU+2 to 2*KL+KU+1.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= N, row i of the matrix was
!          interchanged with row IPIV(i).
!
!  ANORM   (input) DOUBLE PRECISION
!          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!          If NORM = 'I', the infinity-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LNOTI, ONENRM
      CHARACTER          NORMIN
      INTEGER            IX, J, JP, KASE, KASE1, KD, LM
      DOUBLE PRECISION   AINVNM, SCALE, SMLNUM, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DLACON, DLATBS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
         INFO = -6
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
      SMLNUM = DLAMCH( 'Safe minimum' )
!
!     Estimate the norm of inv(A).
!
      AINVNM = ZERO
      NORMIN = 'N'
      IF( ONENRM ) THEN
         KASE1 = 1
      ELSE
         KASE1 = 2
      END IF
      KD = KL + KU + 1
      LNOTI = KL.GT.0
      KASE = 0
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( KASE.EQ.KASE1 ) THEN
!
!           Multiply by inv(L).
!
            IF( LNOTI ) THEN
               DO 20 J = 1, N - 1
                  LM = MIN( KL, N-J )
                  JP = IPIV( J )
                  T = WORK( JP )
                  IF( JP.NE.J ) THEN
                     WORK( JP ) = WORK( J )
                     WORK( J ) = T
                  END IF
                  CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
   20          CONTINUE
            END IF
!
!           Multiply by inv(U).
!
            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, &
                         KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), &
                         INFO )
         ELSE
!
!           Multiply by inv(U').
!
            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, &
                         KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), &
                         INFO )
!
!           Multiply by inv(L').
!
            IF( LNOTI ) THEN
               DO 30 J = N - 1, 1, -1
                  LM = MIN( KL, N-J )
                  WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1, &
                              WORK( J+1 ), 1 )
                  JP = IPIV( J )
                  IF( JP.NE.J ) THEN
                     T = WORK( JP )
                     WORK( JP ) = WORK( J )
                     WORK( J ) = T
                  END IF
   30          CONTINUE
            END IF
         END IF
!
!        Divide X by 1/SCALE if doing so will not cause overflow.
!
         NORMIN = 'Y'
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) &
               GO TO 40
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
   40 CONTINUE
      RETURN
!
!     End of DGBCON
!
      END
      SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, &
                         AMAX, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), C( * ), R( * )
!     ..
!
!  Purpose
!  =======
!
!  DGBEQU computes row and column scalings intended to equilibrate an
!  M-by-N band matrix A and reduce its condition number.  R returns the
!  row scale factors and C the column scale factors, chosen to try to
!  make the largest element in each row and column of the matrix B with
!  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!
!  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!  number and BIGNUM = largest safe number.  Use of these scaling
!  factors is not guaranteed to reduce the condition number of A but
!  works well in practice.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
!          column of A is stored in the j-th column of the array AB as
!          follows:
!          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KL+KU+1.
!
!  R       (output) DOUBLE PRECISION array, dimension (M)
!          If INFO = 0, or INFO > M, R contains the row scale factors
!          for A.
!
!  C       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, C contains the column scale factors for A.
!
!  ROWCND  (output) DOUBLE PRECISION
!          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!          AMAX is neither too large nor too small, it is not worth
!          scaling by R.
!
!  COLCND  (output) DOUBLE PRECISION
!          If INFO = 0, COLCND contains the ratio of the smallest
!          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!          worth scaling by C.
!
!  AMAX    (output) DOUBLE PRECISION
!          Absolute value of largest matrix element.  If AMAX is very
!          close to overflow or very close to underflow, the matrix
!          should be scaled.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= M:  the i-th row of A is exactly zero
!                >  M:  the (i-M)-th column of A is exactly zero
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, KD
      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBEQU', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         ROWCND = ONE
         COLCND = ONE
         AMAX = ZERO
         RETURN
      END IF
!
!     Get machine constants.
!
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
!
!     Compute row scale factors.
!
      R(1:m) = ZERO
!
!     Find the maximum element in each row.
!
      KD = KU + 1
      DO 30 J = 1, N
         DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
            R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
   20    CONTINUE
   30 CONTINUE
!
!     Find the maximum and minimum scale factors.
!
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 40 I = 1, M
         RCMAX = MAX( RCMAX, R( I ) )
         RCMIN = MIN( RCMIN, R( I ) )
   40 CONTINUE
      AMAX = RCMAX
!
      IF( RCMIN.EQ.ZERO ) THEN
!
!        Find the first zero scale factor and return an error code.
!
         DO 50 I = 1, M
            IF( R( I ).EQ.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   50    CONTINUE
      ELSE
!
!        Invert the scale factors.
!
         DO 60 I = 1, M
            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
   60    CONTINUE
!
!        Compute ROWCND = min(R(I)) / max(R(I))
!
         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
!
!     Compute column scale factors
!
      DO 70 J = 1, N
         C( J ) = ZERO
   70 CONTINUE
!
!     Find the maximum element in each column,
!     assuming the row scaling computed above.
!
      KD = KU + 1
      DO 90 J = 1, N
         DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
            C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
   80    CONTINUE
   90 CONTINUE
!
!     Find the maximum and minimum scale factors.
!
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO J = 1, N
         RCMIN = MIN( RCMIN, C( J ) )
         RCMAX = MAX( RCMAX, C( J ) )
      end do

      IF( RCMIN.EQ.ZERO ) THEN
!
!        Find the first zero scale factor and return an error code.
!
         DO 110 J = 1, N
            IF( C( J ).EQ.ZERO ) THEN
               INFO = M + J
               RETURN
            END IF
  110    CONTINUE
      ELSE
!
!        Invert the scale factors.
!
         DO 120 J = 1, N
            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
  120    CONTINUE
!
!        Compute COLCND = min(C(J)) / max(C(J))
!
         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
!
      RETURN
!
!     End of DGBEQU
!
      END
      SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, &
                         IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is banded, and provides
!  error bounds and backward error estimates for the solution.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The original band matrix A, stored in rows 1 to KL+KU+1.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KL+KU+1.
!
!  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)
!          Details of the LU factorization of the band matrix A, as
!          computed by DGBTRF.  U is stored as an upper triangular band
!          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
!          the multipliers used during the factorization are stored in
!          rows KL+KU+2 to 2*KL+KU+1.
!
!  LDAFB   (input) INTEGER
!          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGBTRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DGBTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      CHARACTER          TRANST
      INTEGER            COUNT, I, J, K, KASE, KK, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGBMV, DGBTRS, DLACON, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
          LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
         INFO = -7
      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         FERR(1:nrhs) = ZERO
         BERR(1:nrhs) = ZERO
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = MIN( KL+KU+2, N+1 )
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A, A**T, or A**H, depending on TRANS.
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1, &
                     ONE, WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(op(A))*abs(X) + abs(B).
!
         IF( NOTRAN ) THEN
            DO 50 K = 1, N
               KK = KU + 1 - K
               XK = ABS( X( K, J ) )
               DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
                  WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
   40          CONTINUE
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               KK = KU + 1 - K
               DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
                  S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, &
                         WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)**T).
!
               CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV, &
                            WORK( N+1 ), N, INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( N+I )*WORK( I )
  110          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( N+I )*WORK( I )
  120          CONTINUE
               CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, &
                            WORK( N+1 ), N, INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DGBRFS
!
      END
      SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBSV computes the solution to a real system of linear equations
!  A * X = B, where A is a band matrix of order N with KL subdiagonals
!  and KU superdiagonals, and X and B are N-by-NRHS matrices.
!
!  The LU decomposition with partial pivoting and row interchanges is
!  used to factor A as A = L * U, where L is a product of permutation
!  and unit lower triangular matrices with KL subdiagonals, and U is
!  upper triangular with KL+KU superdiagonals.  The factored form of A
!  is then used to solve the system of equations A * X = B.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (N)
!          The pivot indices that define the permutation matrix P;
!          row i of the matrix was interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
!                has been completed, but the factor U is exactly
!                singular, and the solution has not been computed.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U because of fill-in resulting from the row interchanges.
!
!  =====================================================================
!
!     .. External Subroutines ..
      EXTERNAL           DGBTRF, DGBTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( KL.LT.0 ) THEN
         INFO = -2
      ELSE IF( KU.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBSV ', -INFO )
         RETURN
      END IF
!
!     Compute the LU factorization of the band matrix A.
!
      CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, &
                      B, LDB, INFO )
      END IF
      RETURN
!
!     End of DGBSV
!
      END
      SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, &
                         LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, &
                         RCOND, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, TRANS
      INTEGER            INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), &
                         BERR( * ), C( * ), FERR( * ), R( * ), &
                         WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBSVX uses the LU factorization to compute the solution to a real
!  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
!  where A is a band matrix of order N with KL subdiagonals and KU
!  superdiagonals, and X and B are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed by this subroutine:
!
!  1. If FACT = 'E', real scaling factors are computed to equilibrate
!     the system:
!        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
!        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
!        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
!     Whether or not the system will be equilibrated depends on the
!     scaling of the matrix A, but if equilibration is used, A is
!     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
!     or diag(C)*B (if TRANS = 'T' or 'C').
!
!  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
!     matrix A (after equilibration if FACT = 'E') as
!        A = L * U,
!     where L is a product of permutation and unit lower triangular
!     matrices with KL subdiagonals, and U is upper triangular with
!     KL+KU superdiagonals.
!
!  3. If some U(i,i)=0, so that U is exactly singular, then the routine
!     returns with INFO = i. Otherwise, the factored form of A is used
!     to estimate the condition number of the matrix A.  If the
!     reciprocal of the condition number is less than machine precision,
!     INFO = N+1 is returned as a warning, but the routine still goes on
!     to solve for X and compute error bounds as described below.
!
!  4. The system of equations is solved for X using the factored form
!     of A.
!
!  5. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  6. If equilibration was used, the matrix X is premultiplied by
!     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
!     that it solves the original system before equilibration.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of the matrix A is
!          supplied on entry, and if not, whether the matrix A should be
!          equilibrated before it is factored.
!          = 'F':  On entry, AFB and IPIV contain the factored form of
!                  A.  If EQUED is not 'N', the matrix A has been
!                  equilibrated with scaling factors given by R and C.
!                  AB, AFB, and IPIV are not modified.
!          = 'N':  The matrix A will be copied to AFB and factored.
!          = 'E':  The matrix A will be equilibrated if necessary, then
!                  copied to AFB and factored.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations.
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Transpose)
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
!
!          If FACT = 'F' and EQUED is not 'N', then A must have been
!          equilibrated by the scaling factors in R and/or C.  AB is not
!          modified if FACT = 'F' or 'N', or if FACT = 'E' and
!          EQUED = 'N' on exit.
!
!          On exit, if EQUED .ne. 'N', A is scaled as follows:
!          EQUED = 'R':  A := diag(R) * A
!          EQUED = 'C':  A := A * diag(C)
!          EQUED = 'B':  A := diag(R) * A * diag(C).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KL+KU+1.
!
!  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
!          If FACT = 'F', then AFB is an input argument and on entry
!          contains details of the LU factorization of the band matrix
!          A, as computed by DGBTRF.  U is stored as an upper triangular
!          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
!          and the multipliers used during the factorization are stored
!          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is
!          the factored form of the equilibrated matrix A.
!
!          If FACT = 'N', then AFB is an output argument and on exit
!          returns details of the LU factorization of A.
!
!          If FACT = 'E', then AFB is an output argument and on exit
!          returns details of the LU factorization of the equilibrated
!          matrix A (see the description of AB for the form of the
!          equilibrated matrix).
!
!  LDAFB   (input) INTEGER
!          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.
!
!  IPIV    (input or output) INTEGER array, dimension (N)
!          If FACT = 'F', then IPIV is an input argument and on entry
!          contains the pivot indices from the factorization A = L*U
!          as computed by DGBTRF; row i of the matrix was interchanged
!          with row IPIV(i).
!
!          If FACT = 'N', then IPIV is an output argument and on exit
!          contains the pivot indices from the factorization A = L*U
!          of the original matrix A.
!
!          If FACT = 'E', then IPIV is an output argument and on exit
!          contains the pivot indices from the factorization A = L*U
!          of the equilibrated matrix A.
!
!  EQUED   (input or output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration (always true if FACT = 'N').
!          = 'R':  Row equilibration, i.e., A has been premultiplied by
!                  diag(R).
!          = 'C':  Column equilibration, i.e., A has been postmultiplied
!                  by diag(C).
!          = 'B':  Both row and column equilibration, i.e., A has been
!                  replaced by diag(R) * A * diag(C).
!          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!          output argument.
!
!  R       (input or output) DOUBLE PRECISION array, dimension (N)
!          The row scale factors for A.  If EQUED = 'R' or 'B', A is
!          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!          is not accessed.  R is an input argument if FACT = 'F';
!          otherwise, R is an output argument.  If FACT = 'F' and
!          EQUED = 'R' or 'B', each element of R must be positive.
!
!  C       (input or output) DOUBLE PRECISION array, dimension (N)
!          The column scale factors for A.  If EQUED = 'C' or 'B', A is
!          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!          is not accessed.  C is an input argument if FACT = 'F';
!          otherwise, C is an output argument.  If FACT = 'F' and
!          EQUED = 'C' or 'B', each element of C must be positive.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit,
!          if EQUED = 'N', B is not modified;
!          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
!          diag(R)*B;
!          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
!          overwritten by diag(C)*B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
!          to the original system of equations.  Note that A and B are
!          modified on exit if EQUED .ne. 'N', and the solution to the
!          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
!          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
!          and EQUED = 'R' or 'B'.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A after equilibration (if done).  If RCOND is less than the
!          machine precision (in particular, if RCOND = 0), the matrix
!          is singular to working precision.  This condition is
!          indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (3*N)
!          On exit, WORK(1) contains the reciprocal pivot growth
!          factor norm(A)/norm(U). The "max absolute element" norm is
!          used. If WORK(1) is much less than 1, then the stability
!          of the LU factorization of the (equilibrated) matrix A
!          could be poor. This also means that the solution X, condition
!          estimator RCOND, and forward error bound FERR could be
!          unreliable. If factorization fails with 0<INFO<=N, then
!          WORK(1) contains the reciprocal pivot growth factor for the
!          leading INFO columns of A.
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  U(i,i) is exactly zero.  The factorization
!                       has been completed, but the factor U is exactly
!                       singular, so the solution and error bounds
!                       could not be computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
      CHARACTER          NORM
      INTEGER            I, INFEQU, J, J1, J2
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, &
                         ROWCND, RPVGRW, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGB, DLANTB
      EXTERNAL           LSAME, DLAMCH, DLANGB, DLANTB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS, &
                         DLACPY, DLAQGB, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         ROWEQU = .FALSE.
         COLEQU = .FALSE.
      ELSE
         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
!
!     Test the input parameters.
!
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KL.LT.0 ) THEN
         INFO = -4
      ELSE IF( KU.LT.0 ) THEN
         INFO = -5
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KL+KU+1 ) THEN
         INFO = -8
      ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
         INFO = -10
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. &
               ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -12
      ELSE
         IF( ROWEQU ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO J = 1, N
               RCMIN = MIN( RCMIN, R( J ) )
               RCMAX = MAX( RCMAX, R( J ) )
            end do
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -13
            ELSE IF( N.GT.0 ) THEN
               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               ROWCND = ONE
            END IF
         END IF
         IF( COLEQU .AND. INFO.EQ.0 ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO 20 J = 1, N
               RCMIN = MIN( RCMIN, C( J ) )
               RCMAX = MAX( RCMAX, C( J ) )
   20       CONTINUE
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -14
            ELSE IF( N.GT.0 ) THEN
               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               COLCND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -16
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -18
            END IF
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBSVX', -INFO )
         RETURN
      END IF
!
      IF( EQUIL ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, &
                      AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, &
                         AMAX, EQUED )
            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         END IF
      END IF
!
!     Scale the right hand side.
!
      IF( NOTRAN ) THEN
         IF( ROWEQU ) THEN
            DO 40 J = 1, NRHS
               DO 30 I = 1, N
                  B( I, J ) = R( I )*B( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE IF( COLEQU ) THEN
         DO 60 J = 1, NRHS
            DO 50 I = 1, N
               B( I, J ) = C( I )*B( I, J )
   50       CONTINUE
   60    CONTINUE
      END IF
!
      IF( NOFACT .OR. EQUIL ) THEN
!
!        Compute the LU factorization of the band matrix A.
!
         DO 70 J = 1, N
            J1 = MAX( J-KU, 1 )
            J2 = MIN( J+KL, N )
            CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1, &
                        AFB( KL+KU+1-J+J1, J ), 1 )
   70    CONTINUE
!
         CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) THEN
!
!              Compute the reciprocal pivot growth factor of the
!              leading rank-deficient INFO columns of A.
!
               ANORM = ZERO
               DO 90 J = 1, INFO
                  DO 80 I = MAX( KU+2-J, 1 ), &
                          MIN( N+KU+1-J, KL+KU+1 )
                     ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
   80             CONTINUE
   90          CONTINUE
               RPVGRW = DLANTB( 'M', 'U', 'N', INFO, &
                        MIN( INFO-1, KL+KU ), AFB( MAX( 1, &
                        KL+KU+2-INFO ), 1 ), LDAFB, WORK )
               IF( RPVGRW.EQ.ZERO ) THEN
                  RPVGRW = ONE
               ELSE
                  RPVGRW = ANORM / RPVGRW
               END IF
               WORK( 1 ) = RPVGRW
               RCOND = ZERO
            END IF
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A and the
!     reciprocal pivot growth factor RPVGRW.
!
      IF( NOTRAN ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
      ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
      RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
      IF( RPVGRW.EQ.ZERO ) THEN
         RPVGRW = ONE
      ELSE
         RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
      END IF
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, &
                   WORK, IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution matrix X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, &
                   INFO )
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, &
                   B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF( NOTRAN ) THEN
         IF( COLEQU ) THEN
            DO 110 J = 1, NRHS
               DO I = 1, N
                  X( I, J ) = C( I )*X( I, J )
               end do
  110       CONTINUE
            DO 120 J = 1, NRHS
               FERR( J ) = FERR( J ) / COLCND
  120       CONTINUE
         END IF
      ELSE IF( ROWEQU ) THEN
         DO 140 J = 1, NRHS
            DO 130 I = 1, N
               X( I, J ) = R( I )*X( I, J )
  130       CONTINUE
  140    CONTINUE
         DO 150 J = 1, NRHS
            FERR( J ) = FERR( J ) / ROWCND
  150    CONTINUE
      END IF
!
      WORK( 1 ) = RPVGRW
      RETURN
!
!     End of DGBSVX
!
      END
      SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBTF2 computes an LU factorization of a real m-by-n band matrix A
!  using partial pivoting with row interchanges.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U, because of fill-in resulting from the row
!  interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, JP, JU, KM, KV
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in.
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBTF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
!     Gaussian elimination with partial pivoting
!
!     Set fill-in elements in columns KU+2 to KV to zero.
!
      DO 20 J = KU + 2, MIN( KV, N )
         DO I = KV - J + 2, KL
            AB( I, J ) = ZERO
         end do
   20 CONTINUE
!
!     JU is the index of the last column affected by the current stage
!     of the factorization.
!
      JU = 1
!
      DO 40 J = 1, MIN( M, N )
!
!        Set fill-in elements in column J+KV to zero.
!
         IF( J+KV.LE.N ) THEN
            DO 30 I = 1, KL
               AB( I, J+KV ) = ZERO
   30       CONTINUE
         END IF
!
!        Find pivot and test for singularity. KM is the number of
!        subdiagonal elements in the current column.
!
         KM = MIN( KL, M-J )
         JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )
         IPIV( J ) = JP + J - 1
         IF( AB( KV+JP, J ).NE.ZERO ) THEN
            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
!
!           Apply interchange to columns J to JU.
!
            IF( JP.NE.1 ) &
               CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, &
                           AB( KV+1, J ), LDAB-1 )
!
            IF( KM.GT.0 ) THEN
!
!              Compute multipliers.
!
               CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
!
!              Update trailing submatrix within the band.
!
               IF( JU.GT.J ) &
                  CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, &
                             AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), &
                             LDAB-1 )
            END IF
         ELSE
!
!           If pivot is zero, set INFO to the index of the pivot
!           unless a zero pivot has already been found.
!
            IF( INFO.EQ.0 ) &
               INFO = J
         END IF
   40 CONTINUE
      RETURN
!
!     End of DGBTF2
!
      END
      SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBTRF computes an LU factorization of a real m-by-n band matrix A
!  using partial pivoting with row interchanges.
!
!  This is the blocked version of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U because of fill-in resulting from the row interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, &
                         JU, K2, KM, KV, NB, NW
      DOUBLE PRECISION   TEMP
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   WORK13( LDWORK, NBMAX ), &
                         WORK31( LDWORK, NBMAX )
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX, ILAENV
      EXTERNAL           IDAMAX, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, &
                         DSWAP, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment
!
      NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU )
!
!     The block size must not exceed the limit set by the size of the
!     local arrays WORK13 and WORK31.
!
      NB = MIN( NB, NBMAX )
!
      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
!
!        Use unblocked code
!
         CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
      ELSE
!
!        Use blocked code
!
!        Zero the superdiagonal elements of the work array WORK13
!
         DO 20 J = 1, NB
            WORK13(1:j-1, J ) = ZERO
   20    CONTINUE
!
!        Zero the subdiagonal elements of the work array WORK31
!
         DO 40 J = 1, NB
            DO 30 I = J + 1, NB
               WORK31( I, J ) = ZERO
   30       CONTINUE
   40    CONTINUE
!
!        Gaussian elimination with partial pivoting
!
!        Set fill-in elements in columns KU+2 to KV to zero
!
         DO 60 J = KU + 2, MIN( KV, N )
            DO 50 I = KV - J + 2, KL
               AB( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
!
!        JU is the index of the last column affected by the current
!        stage of the factorization
!
         JU = 1
!
         DO 180 J = 1, MIN( M, N ), NB
            JB = MIN( NB, MIN( M, N )-J+1 )
!
!           The active part of the matrix is partitioned
!
!              A11   A12   A13
!              A21   A22   A23
!              A31   A32   A33
!
!           Here A11, A21 and A31 denote the current block of JB columns
!           which is about to be factorized. The number of rows in the
!           partitioning are JB, I2, I3 respectively, and the numbers
!           of columns are JB, J2, J3. The superdiagonal elements of A13
!           and the subdiagonal elements of A31 lie outside the band.
!
            I2 = MIN( KL-JB, M-J-JB+1 )
            I3 = MIN( JB, M-J-KL+1 )
!
!           J2 and J3 are computed after JU has been updated.
!
!           Factorize the current block of JB columns
!
            DO 80 JJ = J, J + JB - 1
!
!              Set fill-in elements in column JJ+KV to zero
!
               IF( JJ+KV.LE.N ) THEN
                  DO 70 I = 1, KL
                     AB( I, JJ+KV ) = ZERO
   70             CONTINUE
               END IF
!
!              Find pivot and test for singularity. KM is the number of
!              subdiagonal elements in the current column.
!
               KM = MIN( KL, M-JJ )
               JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )
               IPIV( JJ ) = JP + JJ - J
               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
                  IF( JP.NE.1 ) THEN
!
!                    Apply interchange to columns J to J+JB-1
!
                     IF( JP+JJ-1.LT.J+KL ) THEN
!
                        CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, &
                                    AB( KV+JP+JJ-J, J ), LDAB-1 )
                     ELSE
!
!                       The interchange affects columns J to JJ-1 of A31
!                       which are stored in the work array WORK31
!
                        CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, &
                                    WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                        CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, &
                                    AB( KV+JP, JJ ), LDAB-1 )
                     END IF
                  END IF
!
!                 Compute multipliers
!
                  CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), &
                              1 )
!
!                 Update trailing submatrix within the band and within
!                 the current block. JM is the index of the last column
!                 which needs to be updated.
!
                  JM = MIN( JU, J+JB-1 )
                  IF( JM.GT.JJ ) &
                     CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, &
                                AB( KV, JJ+1 ), LDAB-1, &
                                AB( KV+1, JJ+1 ), LDAB-1 )
               ELSE
!
!                 If pivot is zero, set INFO to the index of the pivot
!                 unless a zero pivot has already been found.
!
                  IF( INFO.EQ.0 ) &
                     INFO = JJ
               END IF
!
!              Copy current column of A31 into the work array WORK31
!
               NW = MIN( JJ-J+1, I3 )
               IF( NW.GT.0 ) &
                  CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, &
                              WORK31( 1, JJ-J+1 ), 1 )
   80       CONTINUE
            IF( J+JB.LE.N ) THEN
!
!              Apply the row interchanges to the other blocks.
!
               J2 = MIN( JU-J+1, KV ) - JB
               J3 = MAX( 0, JU-J-KV+1 )
!
!              Use DLASWP to apply the row interchanges to A12, A22, and
!              A32.
!
               CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, &
                            IPIV( J ), 1 )
!
!              Adjust the pivot indices.
!
               DO 90 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
   90          CONTINUE
!
!              Apply the row interchanges to A13, A23, and A33
!              columnwise.
!
               K2 = J - 1 + JB + J2
               DO 110 I = 1, J3
                  JJ = K2 + I
                  DO II = J + I - 1, J + JB - 1
                     IP = IPIV( II )
                     IF( IP.NE.II ) THEN
                        TEMP = AB( KV+1+II-JJ, JJ )
                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
                        AB( KV+1+IP-JJ, JJ ) = TEMP
                     END IF
                  end do
  110          CONTINUE
!
!              Update the relevant part of the trailing submatrix
!
               IF( J2.GT.0 ) THEN
!
!                 Update A12
!
                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', &
                              JB, J2, ONE, AB( KV+1, J ), LDAB-1, &
                              AB( KV+1-JB, J+JB ), LDAB-1 )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A22
!
                     CALL DGEMM( 'No transpose', 'No transpose', I2, J2, &
                                 JB, -ONE, AB( KV+1+JB, J ), LDAB-1, &
                                 AB( KV+1-JB, J+JB ), LDAB-1, ONE, &
                                 AB( KV+1, J+JB ), LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A32
!
                     CALL DGEMM( 'No transpose', 'No transpose', I3, J2, &
                                 JB, -ONE, WORK31, LDWORK, &
                                 AB( KV+1-JB, J+JB ), LDAB-1, ONE, &
                                 AB( KV+KL+1-JB, J+JB ), LDAB-1 )
                  END IF
               END IF
!
               IF( J3.GT.0 ) THEN
!
!                 Copy the lower triangle of A13 into the work array
!                 WORK13
!
                  DO 130 JJ = 1, J3
                     DO 120 II = JJ, JB
                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
  120                CONTINUE
  130             CONTINUE
!
!                 Update A13 in the work array
!
                  CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', &
                              JB, J3, ONE, AB( KV+1, J ), LDAB-1, &
                              WORK13, LDWORK )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A23
!
                     CALL DGEMM( 'No transpose', 'No transpose', I2, J3, &
                                 JB, -ONE, AB( KV+1+JB, J ), LDAB-1, &
                                 WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), &
                                 LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A33
!
                     CALL DGEMM( 'No transpose', 'No transpose', I3, J3, &
                                 JB, -ONE, WORK31, LDWORK, WORK13, &
                                 LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
                  END IF
!
!                 Copy the lower triangle of A13 back into place
!
                  DO 150 JJ = 1, J3
                     DO 140 II = JJ, JB
                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
!
!              Adjust the pivot indices.
!
               DO 160 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
  160          CONTINUE
            END IF
!
!           Partially undo the interchanges in the current block to
!           restore the upper triangular form of A31 and copy the upper
!           triangle of A31 back into place
!
            DO 170 JJ = J + JB - 1, J, -1
               JP = IPIV( JJ ) - JJ + 1
               IF( JP.NE.1 ) THEN
!
!                 Apply interchange to columns J to JJ-1
!
                  IF( JP+JJ-1.LT.J+KL ) THEN
!
!                    The interchange does not affect A31
!
                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, &
                                 AB( KV+JP+JJ-J, J ), LDAB-1 )
                  ELSE
!
!                    The interchange does affect A31
!
                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, &
                                 WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                  END IF
               END IF
!
!              Copy the current column of A31 back into place
!
               NW = MIN( I3, JJ-J+1 )
               IF( NW.GT.0 ) &
                  CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, &
                              AB( KV+KL+1-JJ+J, JJ ), 1 )
  170       CONTINUE
  180    CONTINUE
      END IF
!
      RETURN
!
!     End of DGBTRF
!
      END
      SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGBTRS solves a system of linear equations
!     A * X = B  or  A' * X = B
!  with a general band matrix A using the LU factorization computed
!  by DGBTRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations.
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A'* X = B  (Transpose)
!          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          Details of the LU factorization of the band matrix A, as
!          computed by DGBTRF.  U is stored as an upper triangular band
!          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
!          the multipliers used during the factorization are stored in
!          rows KL+KU+2 to 2*KL+KU+1.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= N, row i of the matrix was
!          interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LNOTI, NOTRAN
      INTEGER            I, J, KD, L, LM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER, DSWAP, DTBSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
          LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGBTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      KD = KU + KL + 1
      LNOTI = KL.GT.0
!
      IF( NOTRAN ) THEN
!
!        Solve  A*X = B.
!
!        Solve L*X = B, overwriting B with X.
!
!        L is represented as a product of permutations and unit lower
!        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
!        where each transformation L(i) is a rank-one modification of
!        the identity matrix.
!
         IF( LNOTI ) THEN
            DO J = 1, N - 1
               LM = MIN( KL, N-J )
               L = IPIV( J )
               IF( L.NE.J ) &
                  CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
               CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), &
                          LDB, B( J+1, 1 ), LDB )
            end do
         END IF

         DO 20 I = 1, NRHS
!
!           Solve U*X = B, overwriting B with X.
!
            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, &
                        AB, LDAB, B( 1, I ), 1 )
   20    CONTINUE
!
      ELSE
!
!        Solve A'*X = B.
!
         DO 30 I = 1, NRHS
!
!           Solve U'*X = B, overwriting B with X.
!
            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, &
                        LDAB, B( 1, I ), 1 )
   30    CONTINUE
!
!        Solve L'*X = B, overwriting B with X.
!
         IF( LNOTI ) THEN
            DO 40 J = N - 1, 1, -1
               LM = MIN( KL, N-J )
               CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), &
                           LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
               L = IPIV( J )
               IF( L.NE.J ) &
                  CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
   40       CONTINUE
         END IF
      END IF
      RETURN
!
!     End of DGBTRS
!
      END
      SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOB, SIDE
      INTEGER            IHI, ILO, INFO, LDV, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   SCALE( * ), V( LDV, * )
!     ..
!
!  Purpose
!  =======
!
!  DGEBAK forms the right or left eigenvectors of a real general matrix
!  by backward transformation on the computed eigenvectors of the
!  balanced matrix output by DGEBAL.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies the type of backward transformation required:
!          = 'N', do nothing, return immediately;
!          = 'P', do backward transformation for permutation only;
!          = 'S', do backward transformation for scaling only;
!          = 'B', do backward transformations for both permutation and
!                 scaling.
!          JOB must be the same as the argument JOB supplied to DGEBAL.
!
!  SIDE    (input) CHARACTER*1
!          = 'R':  V contains right eigenvectors;
!          = 'L':  V contains left eigenvectors.
!
!  N       (input) INTEGER
!          The number of rows of the matrix V.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          The integers ILO and IHI determined by DGEBAL.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  SCALE   (input) DOUBLE PRECISION array, dimension (N)
!          Details of the permutation and scaling factors, as returned
!          by DGEBAL.
!
!  M       (input) INTEGER
!          The number of columns of the matrix V.  M >= 0.
!
!  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)
!          On entry, the matrix of right or left eigenvectors to be
!          transformed, as returned by DHSEIN or DTREVC.
!          On exit, V is overwritten by the transformed eigenvectors.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V. LDV >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFTV, RIGHTV
      INTEGER            I, II, K
      DOUBLE PRECISION   S
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and Test the input parameters
!
      RIGHTV = LSAME( SIDE, 'R' )
      LEFTV = LSAME( SIDE, 'L' )
!
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. &
          .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -7
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEBAK', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
      IF( M.EQ.0 ) &
         RETURN
      IF( LSAME( JOB, 'N' ) ) &
         RETURN
!
      IF( ILO.EQ.IHI ) &
         GO TO 30
!
!     Backward balance
!
      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
!
         IF( RIGHTV ) THEN
            DO I = ILO, IHI
               S = SCALE( I )
               CALL DSCAL( M, S, V( I, 1 ), LDV )
            end do
         END IF

         IF( LEFTV ) THEN
            DO 20 I = ILO, IHI
               S = ONE / SCALE( I )
               CALL DSCAL( M, S, V( I, 1 ), LDV )
   20       CONTINUE
         END IF
!
      END IF
!
!     Backward permutation
!
!     For  I = ILO-1 step -1 until 1,
!              IHI+1 step 1 until N do --
!
   30 CONTINUE
      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
         IF( RIGHTV ) THEN
            DO 40 II = 1, N
               I = II
               IF( I.GE.ILO .AND. I.LE.IHI ) &
                  GO TO 40
               IF( I.LT.ILO ) &
                  I = ILO - II
               K = SCALE( I )
               IF( K.EQ.I ) &
                  GO TO 40
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   40       CONTINUE
         END IF
!
         IF( LEFTV ) THEN
            DO 50 II = 1, N
               I = II
               IF( I.GE.ILO .AND. I.LE.IHI ) &
                  GO TO 50
               IF( I.LT.ILO ) &
                  I = ILO - II
               K = SCALE( I )
               IF( K.EQ.I ) &
                  GO TO 50
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   50       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGEBAK
!
      END
      SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), SCALE( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEBAL balances a general real matrix A.  This involves, first,
!  permuting A by a similarity transformation to isolate eigenvalues
!  in the first 1 to ILO-1 and last IHI+1 to N elements on the
!  diagonal; and second, applying a diagonal similarity transformation
!  to rows and columns ILO to IHI to make the rows and columns as
!  close in norm as possible.  Both steps are optional.
!
!  Balancing may reduce the 1-norm of the matrix, and improve the
!  accuracy of the computed eigenvalues and/or eigenvectors.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies the operations to be performed on A:
!          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
!                  for i = 1,...,N;
!          = 'P':  permute only;
!          = 'S':  scale only;
!          = 'B':  both permute and scale.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the input matrix A.
!          On exit,  A is overwritten by the balanced matrix.
!          If JOB = 'N', A is not referenced.
!          See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  ILO     (output) INTEGER
!  IHI     (output) INTEGER
!          ILO and IHI are set to integers such that on exit
!          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
!          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!
!  SCALE   (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied to
!          A.  If P(j) is the index of the row and column interchanged
!          with row and column j and D(j) is the scaling factor
!          applied to row and column j, then
!          SCALE(j) = P(j)    for j = 1,...,ILO-1
!                   = D(j)    for j = ILO,...,IHI
!                   = P(j)    for j = IHI+1,...,N.
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The permutations consist of row and column interchanges which put
!  the matrix in the form
!
!             ( T1   X   Y  )
!     P A P = (  0   B   Z  )
!             (  0   0   T2 )
!
!  where T1 and T2 are upper triangular matrices whose eigenvalues lie
!  along the diagonal.  The column indices ILO and IHI mark the starting
!  and ending columns of the submatrix B. Balancing consists of applying
!  a diagonal similarity transformation inv(D) * B * D to make the
!  1-norms of each row of B and its corresponding column nearly equal.
!  The output matrix is
!
!     ( T1     X*D          Y    )
!     (  0  inv(D)*B*D  inv(D)*Z ).
!     (  0      0           T2   )
!
!  Information about the permutations P and the diagonal matrix D is
!  returned in the vector SCALE.
!
!  This subroutine is based on the EISPACK routine BALANC.
!
!  Modified by Tzu-Yi Chen, Computer Science Division, University of
!    California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   SCLFAC
      PARAMETER          ( SCLFAC = 0.8D+1 )
      DOUBLE PRECISION   FACTOR
      PARAMETER          ( FACTOR = 0.95D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOCONV
      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, &
                         SFMIN2
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. &
          .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEBAL', -INFO )
         RETURN
      END IF
!
      K = 1
      L = N
!
      IF( N.EQ.0 ) &
         GO TO 210
!
      IF( LSAME( JOB, 'N' ) ) THEN
         SCALE(1:n) = ONE
         GO TO 210
      END IF
!
      IF( LSAME( JOB, 'S' ) ) &
         GO TO 120
!
!     Permutation to isolate eigenvalues if possible
!
      GO TO 50
!
!     Row and column exchange.
!
   20 CONTINUE
      SCALE( M ) = J
      IF( J.EQ.M ) &
         GO TO 30
!
      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
      CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
!
   30 CONTINUE
      GO TO ( 40, 80 )IEXC
!
!     Search for rows isolating an eigenvalue and push them down.
!
   40 CONTINUE
      IF( L.EQ.1 ) &
         GO TO 210
      L = L - 1
!
   50 CONTINUE
      DO 70 J = L, 1, -1
!
         DO 60 I = 1, L
            IF( I.EQ.J ) &
               GO TO 60
            IF( A( J, I ).NE.ZERO ) &
               GO TO 70
   60    CONTINUE
!
         M = L
         IEXC = 1
         GO TO 20
   70 CONTINUE
!
      GO TO 90
!
!     Search for columns isolating an eigenvalue and push them left.
!
   80 CONTINUE
      K = K + 1
!
   90 CONTINUE
      DO 110 J = K, L
!
         DO 100 I = K, L
            IF( I.EQ.J ) &
               GO TO 100
            IF( A( I, J ).NE.ZERO ) &
               GO TO 110
  100    CONTINUE
!
         M = K
         IEXC = 2
         GO TO 20
  110 CONTINUE
!
  120 CONTINUE
      DO 130 I = K, L
         SCALE( I ) = ONE
  130 CONTINUE
!
      IF( LSAME( JOB, 'P' ) ) &
         GO TO 210
!
!     Balance the submatrix in rows K to L.
!
!     Iterative loop for norm reduction
!
      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
      SFMAX1 = ONE / SFMIN1
      SFMIN2 = SFMIN1*SCLFAC
      SFMAX2 = ONE / SFMIN2
  140 CONTINUE
      NOCONV = .FALSE.
!
      DO 200 I = K, L
         C = ZERO
         R = ZERO
!
         DO 150 J = K, L
            IF( J.EQ.I ) &
               GO TO 150
            C = C + ABS( A( J, I ) )
            R = R + ABS( A( I, J ) )
  150    CONTINUE
         ICA = IDAMAX( L, A( 1, I ), 1 )
         CA = ABS( A( ICA, I ) )
         IRA = IDAMAX( N-K+1, A( I, K ), LDA )
         RA = ABS( A( I, IRA+K-1 ) )
!
!        Guard against zero C or R due to underflow.
!
         IF( C.EQ.ZERO .OR. R.EQ.ZERO ) &
            GO TO 200
         G = R / SCLFAC
         F = ONE
         S = C + R
  160    CONTINUE
         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. &
             MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
         F = F*SCLFAC
         C = C*SCLFAC
         CA = CA*SCLFAC
         R = R / SCLFAC
         G = G / SCLFAC
         RA = RA / SCLFAC
         GO TO 160
!
  170    CONTINUE
         G = C / SCLFAC
  180    CONTINUE
         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. &
             MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
         F = F / SCLFAC
         C = C / SCLFAC
         G = G / SCLFAC
         CA = CA / SCLFAC
         R = R*SCLFAC
         RA = RA*SCLFAC
         GO TO 180
!
!        Now balance.
!
  190    CONTINUE
         IF( ( C+R ).GE.FACTOR*S ) &
            GO TO 200
         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
            IF( F*SCALE( I ).LE.SFMIN1 ) &
               GO TO 200
         END IF
         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
            IF( SCALE( I ).GE.SFMAX1 / F ) &
               GO TO 200
         END IF
         G = ONE / F
         SCALE( I ) = SCALE( I )*F
         NOCONV = .TRUE.
!
         CALL DSCAL( N-K+1, G, A( I, K ), LDA )
         CALL DSCAL( L, F, A( 1, I ), 1 )
!
  200 CONTINUE
!
      IF( NOCONV ) &
         GO TO 140
!
  210 CONTINUE
      ILO = K
      IHI = L
!
      RETURN
!
!     End of DGEBAL
!
      END
      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ), &
                         TAUQ( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEBD2 reduces a real general m by n matrix A to upper or lower
!  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
!
!  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows in the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns in the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n general matrix to be reduced.
!          On exit,
!          if m >= n, the diagonal and the first superdiagonal are
!            overwritten with the upper bidiagonal matrix B; the
!            elements below the diagonal, with the array TAUQ, represent
!            the orthogonal matrix Q as a product of elementary
!            reflectors, and the elements above the first superdiagonal,
!            with the array TAUP, represent the orthogonal matrix P as
!            a product of elementary reflectors;
!          if m < n, the diagonal and the first subdiagonal are
!            overwritten with the lower bidiagonal matrix B; the
!            elements below the first subdiagonal, with the array TAUQ,
!            represent the orthogonal matrix Q as a product of
!            elementary reflectors, and the elements above the diagonal,
!            with the array TAUP, represent the orthogonal matrix P as
!            a product of elementary reflectors.
!          See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The diagonal elements of the bidiagonal matrix B:
!          D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
!          The off-diagonal elements of the bidiagonal matrix B:
!          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!
!  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Q. See Further Details.
!
!  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix P. See Further Details.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (max(M,N))
!
!  INFO    (output) INTEGER
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrices Q and P are represented as products of elementary
!  reflectors:
!
!  If m >= n,
!
!     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!
!  Each H(i) and G(i) has the form:
!
!     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
!
!  where tauq and taup are real scalars, and v and u are real vectors;
!  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!  tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  If m < n,
!
!     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!
!  Each H(i) and G(i) has the form:
!
!     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
!
!  where tauq and taup are real scalars, and v and u are real vectors;
!  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!  tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  The contents of A on exit are illustrated by the following examples:
!
!  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!
!    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!    (  v1  v2  v3  v4  v5 )
!
!  where d and e denote diagonal and off-diagonal elements of B, vi
!  denotes an element of the vector defining H(i), and ui an element of
!  the vector defining G(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DGEBD2', -INFO )
         RETURN
      END IF
!
      IF( M.GE.N ) THEN
!
!        Reduce to upper bidiagonal form
!
         DO 10 I = 1, N
!
!           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
!
            CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, &
                         TAUQ( I ) )
            D( I ) = A( I, I )
            A( I, I ) = ONE
!
!           Apply H(i) to A(i:m,i+1:n) from the left
!
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), &
                        A( I, I+1 ), LDA, WORK )
            A( I, I ) = D( I )
!
            IF( I.LT.N ) THEN
!
!              Generate elementary reflector G(i) to annihilate
!              A(i,i+2:n)
!
               CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), &
                            LDA, TAUP( I ) )
               E( I ) = A( I, I+1 )
               A( I, I+1 ) = ONE
!
!              Apply G(i) to A(i+1:m,i+1:n) from the right
!
               CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, &
                           TAUP( I ), A( I+1, I+1 ), LDA, WORK )
               A( I, I+1 ) = E( I )
            ELSE
               TAUP( I ) = ZERO
            END IF
   10    CONTINUE
      ELSE
!
!        Reduce to lower bidiagonal form
!
         DO 20 I = 1, M
!
!           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
!
            CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, &
                         TAUP( I ) )
            D( I ) = A( I, I )
            A( I, I ) = ONE
!
!           Apply G(i) to A(i+1:m,i:n) from the right
!
            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), &
                        A( MIN( I+1, M ), I ), LDA, WORK )
            A( I, I ) = D( I )
!
            IF( I.LT.M ) THEN
!
!              Generate elementary reflector H(i) to annihilate
!              A(i+2:m,i)
!
               CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, &
                            TAUQ( I ) )
               E( I ) = A( I+1, I )
               A( I+1, I ) = ONE
!
!              Apply H(i) to A(i+1:m,i+1:n) from the left
!
               CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), &
                           A( I+1, I+1 ), LDA, WORK )
               A( I+1, I ) = E( I )
            ELSE
               TAUQ( I ) = ZERO
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DGEBD2
!
      END
      SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ), &
                         TAUQ( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEBRD reduces a general real M-by-N matrix A to upper or lower
!  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
!
!  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows in the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns in the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N general matrix to be reduced.
!          On exit,
!          if m >= n, the diagonal and the first superdiagonal are
!            overwritten with the upper bidiagonal matrix B; the
!            elements below the diagonal, with the array TAUQ, represent
!            the orthogonal matrix Q as a product of elementary
!            reflectors, and the elements above the first superdiagonal,
!            with the array TAUP, represent the orthogonal matrix P as
!            a product of elementary reflectors;
!          if m < n, the diagonal and the first subdiagonal are
!            overwritten with the lower bidiagonal matrix B; the
!            elements below the first subdiagonal, with the array TAUQ,
!            represent the orthogonal matrix Q as a product of
!            elementary reflectors, and the elements above the diagonal,
!            with the array TAUP, represent the orthogonal matrix P as
!            a product of elementary reflectors.
!          See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The diagonal elements of the bidiagonal matrix B:
!          D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
!          The off-diagonal elements of the bidiagonal matrix B:
!          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
!          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
!
!  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Q. See Further Details.
!
!  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix P. See Further Details.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,M,N).
!          For optimum performance LWORK >= (M+N)*NB, where NB
!          is the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrices Q and P are represented as products of elementary
!  reflectors:
!
!  If m >= n,
!
!     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
!
!  Each H(i) and G(i) has the form:
!
!     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
!
!  where tauq and taup are real scalars, and v and u are real vectors;
!  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
!  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
!  tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  If m < n,
!
!     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
!
!  Each H(i) and G(i) has the form:
!
!     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
!
!  where tauq and taup are real scalars, and v and u are real vectors;
!  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
!  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
!  tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  The contents of A on exit are illustrated by the following examples:
!
!  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!
!    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
!    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
!    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
!    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
!    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
!    (  v1  v2  v3  v4  v5 )
!
!  where d and e denote diagonal and off-diagonal elements of B, vi
!  denotes an element of the vector defining H(i), and ui an element of
!  the vector defining G(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, &
                         NBMIN, NX
      DOUBLE PRECISION   WS
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEBD2, DGEMM, DLABRD, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
      LWKOPT = ( M+N )*NB
      WORK( 1 ) = DBLE( LWKOPT )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
      IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'DGEBRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      MINMN = MIN( M, N )
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      WS = MAX( M, N )
      LDWRKX = M
      LDWRKY = N
!
      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
!
!        Set the crossover point NX.
!
         NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
!
!        Determine when to switch from blocked to unblocked code.
!
         IF( NX.LT.MINMN ) THEN
            WS = ( M+N )*NB
            IF( LWORK.LT.WS ) THEN
!
!              Not enough work space for the optimal NB, consider using
!              a smaller block size.
!
               NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 )
               IF( LWORK.GE.( M+N )*NBMIN ) THEN
                  NB = LWORK / ( M+N )
               ELSE
                  NB = 1
                  NX = MINMN
               END IF
            END IF
         END IF
      ELSE
         NX = MINMN
      END IF
!
      DO 30 I = 1, MINMN - NX, NB
!
!        Reduce rows and columns i:i+nb-1 to bidiagonal form and return
!        the matrices X and Y which are needed to update the unreduced
!        part of the matrix
!
         CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), &
                      TAUQ( I ), TAUP( I ), WORK, LDWRKX, &
                      WORK( LDWRKX*NB+1 ), LDWRKY )
!
!        Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
!        of the form  A := A - V*Y' - X*U'
!
         CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, &
                     NB, -ONE, A( I+NB, I ), LDA, &
                     WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, &
                     A( I+NB, I+NB ), LDA )
         CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, &
                     NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, &
                     ONE, A( I+NB, I+NB ), LDA )
!
!        Copy diagonal and off-diagonal elements of B back into A
!
         IF( M.GE.N ) THEN
            DO J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J, J+1 ) = E( J )
            end do
         ELSE
            DO 20 J = I, I + NB - 1
               A( J, J ) = D( J )
               A( J+1, J ) = E( J )
   20       CONTINUE
         END IF
   30 CONTINUE
!
!     Use unblocked code to reduce the remainder of the matrix
!
      CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), &
                   TAUQ( I ), TAUP( I ), WORK, IINFO )
      WORK( 1 ) = WS
      RETURN
!
!     End of DGEBRD
!
      END
      SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGECON estimates the reciprocal of the condition number of a general
!  real matrix A, in either the 1-norm or the infinity-norm, using
!  the LU factorization computed by DGETRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as
!     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by DGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  ANORM   (input) DOUBLE PRECISION
!          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!          If NORM = 'I', the infinity-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ONENRM
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, SCALE, SL, SMLNUM, SU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATRS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGECON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
      SMLNUM = DLAMCH( 'Safe minimum' )
!
!     Estimate the norm of inv(A).
!
      AINVNM = ZERO
      NORMIN = 'N'
      IF( ONENRM ) THEN
         KASE1 = 1
      ELSE
         KASE1 = 2
      END IF
      KASE = 0
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( KASE.EQ.KASE1 ) THEN
!
!           Multiply by inv(L).
!
            CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, &
                         LDA, WORK, SL, WORK( 2*N+1 ), INFO )
!
!           Multiply by inv(U).
!
            CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, &
                         A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
         ELSE
!
!           Multiply by inv(U').
!
            CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, &
                         LDA, WORK, SU, WORK( 3*N+1 ), INFO )
!
!           Multiply by inv(L').
!
            CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, &
                         LDA, WORK, SL, WORK( 2*N+1 ), INFO )
         END IF
!
!        Divide X by 1/(SL*SU) if doing so will not cause overflow.
!
         SCALE = SL*SU
         NORMIN = 'Y'
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) &
               GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
   20 CONTINUE
      RETURN
!
!     End of DGECON
!
      END
      SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), R( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEEQU computes row and column scalings intended to equilibrate an
!  M-by-N matrix A and reduce its condition number.  R returns the row
!  scale factors and C the column scale factors, chosen to try to make
!  the largest element in each row and column of the matrix B with
!  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
!
!  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
!  number and BIGNUM = largest safe number.  Use of these scaling
!  factors is not guaranteed to reduce the condition number of A but
!  works well in practice.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The M-by-N matrix whose equilibration factors are
!          to be computed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  R       (output) DOUBLE PRECISION array, dimension (M)
!          If INFO = 0 or INFO > M, R contains the row scale factors
!          for A.
!
!  C       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0,  C contains the column scale factors for A.
!
!  ROWCND  (output) DOUBLE PRECISION
!          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
!          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
!          AMAX is neither too large nor too small, it is not worth
!          scaling by R.
!
!  COLCND  (output) DOUBLE PRECISION
!          If INFO = 0, COLCND contains the ratio of the smallest
!          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
!          worth scaling by C.
!
!  AMAX    (output) DOUBLE PRECISION
!          Absolute value of largest matrix element.  If AMAX is very
!          close to overflow or very close to underflow, the matrix
!          should be scaled.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i,  and i is
!                <= M:  the i-th row of A is exactly zero
!                >  M:  the (i-M)-th column of A is exactly zero
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEEQU', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         ROWCND = ONE
         COLCND = ONE
         AMAX = ZERO
         RETURN
      END IF
!
!     Get machine constants.
!
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
!
!     Compute row scale factors.
!
      R(1:m) = ZERO
!
!     Find the maximum element in each row.
!
      DO 30 J = 1, N
         DO 20 I = 1, M
            R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
   20    CONTINUE
   30 CONTINUE
!
!     Find the maximum and minimum scale factors.
!
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO 40 I = 1, M
         RCMAX = MAX( RCMAX, R( I ) )
         RCMIN = MIN( RCMIN, R( I ) )
   40 CONTINUE
      AMAX = RCMAX
!
      IF( RCMIN.EQ.ZERO ) THEN
!
!        Find the first zero scale factor and return an error code.
!
         DO 50 I = 1, M
            IF( R( I ).EQ.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   50    CONTINUE
      ELSE
!
!        Invert the scale factors.
!
         DO 60 I = 1, M
            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
   60    CONTINUE
!
!        Compute ROWCND = min(R(I)) / max(R(I))
!
         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
!
!     Compute column scale factors
!
      DO 70 J = 1, N
         C( J ) = ZERO
   70 CONTINUE
!
!     Find the maximum element in each column,
!     assuming the row scaling computed above.
!
      DO 90 J = 1, N
         DO 80 I = 1, M
            C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
   80    CONTINUE
   90 CONTINUE
!
!     Find the maximum and minimum scale factors.
!
      RCMIN = BIGNUM
      RCMAX = ZERO
      DO J = 1, N
         RCMIN = MIN( RCMIN, C( J ) )
         RCMAX = MAX( RCMAX, C( J ) )
      end do

      IF( RCMIN.EQ.ZERO ) THEN
!
!        Find the first zero scale factor and return an error code.
!
         DO 110 J = 1, N
            IF( C( J ).EQ.ZERO ) THEN
               INFO = M + J
               RETURN
            END IF
  110    CONTINUE
      ELSE
!
!        Invert the scale factors.
!
         DO 120 J = 1, N
            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
  120    CONTINUE
!
!        Compute COLCND = min(C(J)) / max(C(J))
!
         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
      END IF
!
      RETURN
!
!     End of DGEEQU
!
      END
      SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, &
                        VS, LDVS, WORK, LWORK, BWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVS, SORT
      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
!     ..
!     .. Array Arguments ..
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), &
                         WR( * )
!     ..
!     .. Function Arguments ..
      LOGICAL            SELECT
      EXTERNAL           SELECT
!     ..
!
!  Purpose
!  =======
!
!  DGEES computes for an N-by-N real nonsymmetric matrix A, the
!  eigenvalues, the real Schur form T, and, optionally, the matrix of
!  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
!
!  Optionally, it also orders the eigenvalues on the diagonal of the
!  real Schur form so that selected eigenvalues are at the top left.
!  The leading columns of Z then form an orthonormal basis for the
!  invariant subspace corresponding to the selected eigenvalues.
!
!  A matrix is in real Schur form if it is upper quasi-triangular with
!  1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!  form
!          [  a  b  ]
!          [  c  a  ]
!
!  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
!
!  Arguments
!  =========
!
!  JOBVS   (input) CHARACTER*1
!          = 'N': Schur vectors are not computed;
!          = 'V': Schur vectors are computed.
!
!  SORT    (input) CHARACTER*1
!          Specifies whether or not to order the eigenvalues on the
!          diagonal of the Schur form.
!          = 'N': Eigenvalues are not ordered;
!          = 'S': Eigenvalues are ordered (see SELECT).
!
!  SELECT  (input) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
!          SELECT must be declared EXTERNAL in the calling subroutine.
!          If SORT = 'S', SELECT is used to select eigenvalues to sort
!          to the top left of the Schur form.
!          If SORT = 'N', SELECT is not referenced.
!          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
!          SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
!          conjugate pair of eigenvalues is selected, then both complex
!          eigenvalues are selected.
!          Note that a selected complex eigenvalue may no longer
!          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
!          ordering may change the value of complex eigenvalues
!          (especially if the eigenvalue is ill-conditioned); in this
!          case INFO is set to N+2 (see INFO below).
!
!  N       (input) INTEGER
!          The order of the matrix A. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N matrix A.
!          On exit, A has been overwritten by its real Schur form T.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  SDIM    (output) INTEGER
!          If SORT = 'N', SDIM = 0.
!          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!                         for which SELECT is true. (Complex conjugate
!                         pairs for which SELECT is true for either
!                         eigenvalue count as 2.)
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          WR and WI contain the real and imaginary parts,
!          respectively, of the computed eigenvalues in the same order
!          that they appear on the diagonal of the output Schur form T.
!          Complex conjugate pairs of eigenvalues will appear
!          consecutively with the eigenvalue having the positive
!          imaginary part first.
!
!  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)
!          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
!          vectors.
!          If JOBVS = 'N', VS is not referenced.
!
!  LDVS    (input) INTEGER
!          The leading dimension of the array VS.  LDVS >= 1; if
!          JOBVS = 'V', LDVS >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,3*N).
!          For good performance, LWORK must generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  BWORK   (workspace) LOGICAL array, dimension (N)
!          Not referenced if SORT = 'N'.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, and i is
!             <= N: the QR algorithm failed to compute all the
!                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
!                   contain those eigenvalues which have converged; if
!                   JOBVS = 'V', VS contains the matrix which reduces A
!                   to its partially converged Schur form.
!             = N+1: the eigenvalues could not be reordered because some
!                   eigenvalues were too close to separate (the problem
!                   is very ill-conditioned);
!             = N+2: after reordering, roundoff changed values of some
!                   complex eigenvalues so that leading eigenvalues in
!                   the Schur form no longer satisfy SELECT=.TRUE.  This
!                   could also be caused by underflow due to scaling.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST, &
                         WANTVS
      INTEGER            HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, &
                         IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, &
                         MAXWRK, MINWRK
      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
!     ..
!     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, &
                         DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVS = LSAME( JOBVS, 'V' )
      WANTST = LSAME( SORT, 'S' )
      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
         INFO = -11
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by DHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
         MINWRK = MAX( 1, 3*N )
         IF( .NOT.WANTVS ) THEN
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
         ELSE
            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* &
                     ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEES ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA ) &
         CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
!
!     Permute the matrix to make it more nearly triangular
!     (Workspace: need N)
!
      IBAL = 1
      CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
!
!     Reduce to upper Hessenberg form
!     (Workspace: need 3*N, prefer 2*N+N*NB)
!
      ITAU = N + IBAL
      IWRK = N + ITAU
      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), &
                   LWORK-IWRK+1, IERR )
!
      IF( WANTVS ) THEN
!
!        Copy Householder vectors to VS
!
         CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
!
!        Generate orthogonal matrix in VS
!        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
      END IF
!
      SDIM = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (Workspace: need N+1, prefer N+HSWORK (see comments) )
!
      IWRK = ITAU
      CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, &
                   WORK( IWRK ), LWORK-IWRK+1, IEVAL )
      IF( IEVAL.GT.0 ) &
         INFO = IEVAL
!
!     Sort eigenvalues if desired
!
      IF( WANTST .AND. INFO.EQ.0 ) THEN
         IF( SCALEA ) THEN
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
         END IF
         DO I = 1, N
            BWORK( I ) = SELECT( WR( I ), WI( I ) )
         end do
!
!        Reorder eigenvalues and transform Schur vectors
!        (Workspace: none needed)
!
         CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, &
                      SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, &
                      ICOND )
         IF( ICOND.GT.0 ) &
            INFO = N + ICOND
      END IF
!
      IF( WANTVS ) THEN
!
!        Undo balancing
!        (Workspace: need N)
!
         CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, &
                      IERR )
      END IF
!
      IF( SCALEA ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
         CALL DCOPY( N, A, LDA+1, WR, 1 )
         IF( CSCALE.EQ.SMLNUM ) THEN
!
!           If scaling back towards underflow, adjust WI if an
!           offdiagonal element of a 2-by-2 block in the Schur form
!           underflows.
!
            IF( IEVAL.GT.0 ) THEN
               I1 = IEVAL + 1
               I2 = IHI - 1
               CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, &
                            MAX( ILO-1, 1 ), IERR )
            ELSE IF( WANTST ) THEN
               I1 = 1
               I2 = N - 1
            ELSE
               I1 = ILO
               I2 = IHI - 1
            END IF
            INXT = I1 - 1
            DO 20 I = I1, I2
               IF( I.LT.INXT ) &
                  GO TO 20
               IF( WI( I ).EQ.ZERO ) THEN
                  INXT = I + 1
               ELSE
                  IF( A( I+1, I ).EQ.ZERO ) THEN
                     WI( I ) = ZERO
                     WI( I+1 ) = ZERO
                  ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. &
                           ZERO ) THEN
                     WI( I ) = ZERO
                     WI( I+1 ) = ZERO
                     IF( I.GT.1 ) &
                        CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
                     IF( N.GT.I+1 ) &
                        CALL DSWAP( N-I-1, A( I, I+2 ), LDA, &
                                    A( I+1, I+2 ), LDA )
                     CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
                     A( I, I+1 ) = A( I+1, I )
                     A( I+1, I ) = ZERO
                  END IF
                  INXT = I + 2
               END IF
   20       CONTINUE
         END IF
!
!        Undo scaling for the imaginary part of the eigenvalues
!
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, &
                      WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
      END IF
!
      IF( WANTST .AND. INFO.EQ.0 ) THEN
!
!        Check if reordering successful
!
         LASTSL = .TRUE.
         LST2SL = .TRUE.
         SDIM = 0
         IP = 0
         DO 30 I = 1, N
            CURSL = SELECT( WR( I ), WI( I ) )
            IF( WI( I ).EQ.ZERO ) THEN
               IF( CURSL ) &
                  SDIM = SDIM + 1
               IP = 0
               IF( CURSL .AND. .NOT.LASTSL ) &
                  INFO = N + 2
            ELSE
               IF( IP.EQ.1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
                  CURSL = CURSL .OR. LASTSL
                  LASTSL = CURSL
                  IF( CURSL ) &
                     SDIM = SDIM + 2
                  IP = -1
                  IF( CURSL .AND. .NOT.LST2SL ) &
                     INFO = N + 2
               ELSE
!
!                 First eigenvalue of conjugate pair
!
                  IP = 1
               END IF
            END IF
            LST2SL = LASTSL
            LASTSL = CURSL
   30    CONTINUE
      END IF
!
      WORK( 1 ) = MAXWRK
      RETURN
!
!     End of DGEES
!
      END
      SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, &
                         WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, &
                         IWORK, LIWORK, BWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVS, SENSE, SORT
      INTEGER            INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
      DOUBLE PRECISION   RCONDE, RCONDV
!     ..
!     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ), &
                         WR( * )
!     ..
!     .. Function Arguments ..
      LOGICAL            SELECT
      EXTERNAL           SELECT
!     ..
!
!  Purpose
!  =======
!
!  DGEESX computes for an N-by-N real nonsymmetric matrix A, the
!  eigenvalues, the real Schur form T, and, optionally, the matrix of
!  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
!
!  Optionally, it also orders the eigenvalues on the diagonal of the
!  real Schur form so that selected eigenvalues are at the top left;
!  computes a reciprocal condition number for the average of the
!  selected eigenvalues (RCONDE); and computes a reciprocal condition
!  number for the right invariant subspace corresponding to the
!  selected eigenvalues (RCONDV).  The leading columns of Z form an
!  orthonormal basis for this invariant subspace.
!
!  For further explanation of the reciprocal condition numbers RCONDE
!  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
!  these quantities are called s and sep respectively).
!
!  A real matrix is in real Schur form if it is upper quasi-triangular
!  with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!  the form
!            [  a  b  ]
!            [  c  a  ]
!
!  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
!
!  Arguments
!  =========
!
!  JOBVS   (input) CHARACTER*1
!          = 'N': Schur vectors are not computed;
!          = 'V': Schur vectors are computed.
!
!  SORT    (input) CHARACTER*1
!          Specifies whether or not to order the eigenvalues on the
!          diagonal of the Schur form.
!          = 'N': Eigenvalues are not ordered;
!          = 'S': Eigenvalues are ordered (see SELECT).
!
!  SELECT  (input) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
!          SELECT must be declared EXTERNAL in the calling subroutine.
!          If SORT = 'S', SELECT is used to select eigenvalues to sort
!          to the top left of the Schur form.
!          If SORT = 'N', SELECT is not referenced.
!          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
!          SELECT(WR(j),WI(j)) is true; i.e., if either one of a
!          complex conjugate pair of eigenvalues is selected, then both
!          are.  Note that a selected complex eigenvalue may no longer
!          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
!          ordering may change the value of complex eigenvalues
!          (especially if the eigenvalue is ill-conditioned); in this
!          case INFO may be set to N+3 (see INFO below).
!
!  SENSE   (input) CHARACTER*1
!          Determines which reciprocal condition numbers are computed.
!          = 'N': None are computed;
!          = 'E': Computed for average of selected eigenvalues only;
!          = 'V': Computed for selected right invariant subspace only;
!          = 'B': Computed for both.
!          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
!
!  N       (input) INTEGER
!          The order of the matrix A. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the N-by-N matrix A.
!          On exit, A is overwritten by its real Schur form T.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  SDIM    (output) INTEGER
!          If SORT = 'N', SDIM = 0.
!          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!                         for which SELECT is true. (Complex conjugate
!                         pairs for which SELECT is true for either
!                         eigenvalue count as 2.)
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          WR and WI contain the real and imaginary parts, respectively,
!          of the computed eigenvalues, in the same order that they
!          appear on the diagonal of the output Schur form T.  Complex
!          conjugate pairs of eigenvalues appear consecutively with the
!          eigenvalue having the positive imaginary part first.
!
!  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)
!          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
!          vectors.
!          If JOBVS = 'N', VS is not referenced.
!
!  LDVS    (input) INTEGER
!          The leading dimension of the array VS.  LDVS >= 1, and if
!          JOBVS = 'V', LDVS >= N.
!
!  RCONDE  (output) DOUBLE PRECISION
!          If SENSE = 'E' or 'B', RCONDE contains the reciprocal
!          condition number for the average of the selected eigenvalues.
!          Not referenced if SENSE = 'N' or 'V'.
!
!  RCONDV  (output) DOUBLE PRECISION
!          If SENSE = 'V' or 'B', RCONDV contains the reciprocal
!          condition number for the selected right invariant subspace.
!          Not referenced if SENSE = 'N' or 'E'.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,3*N).
!          Also, if SENSE = 'E' or 'V' or 'B',
!          LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
!          selected eigenvalues computed by this routine.  Note that
!          N+2*SDIM*(N-SDIM) <= N+N*N/2.
!          For good performance, LWORK must generally be larger.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          Not referenced if SENSE = 'N' or 'E'.
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
!
!  BWORK   (workspace) LOGICAL array, dimension (N)
!          Not referenced if SORT = 'N'.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, and i is
!             <= N: the QR algorithm failed to compute all the
!                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
!                   contain those eigenvalues which have converged; if
!                   JOBVS = 'V', VS contains the transformation which
!                   reduces A to its partially converged Schur form.
!             = N+1: the eigenvalues could not be reordered because some
!                   eigenvalues were too close to separate (the problem
!                   is very ill-conditioned);
!             = N+2: after reordering, roundoff changed values of some
!                   complex eigenvalues so that leading eigenvalues in
!                   the Schur form no longer satisfy SELECT=.TRUE.  This
!                   could also be caused by underflow due to scaling.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            CURSL, LASTSL, LST2SL, SCALEA, WANTSB, WANTSE, &
                         WANTSN, WANTST, WANTSV, WANTVS
      INTEGER            HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL, &
                         IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB, &
                         MAXWRK, MINWRK
      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SMLNUM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, &
                         DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      WANTVS = LSAME( JOBVS, 'V' )
      WANTST = LSAME( SORT, 'S' )
      WANTSN = LSAME( SENSE, 'N' )
      WANTSE = LSAME( SENSE, 'E' )
      WANTSV = LSAME( SENSE, 'V' )
      WANTSB = LSAME( SENSE, 'B' )
      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. &
               ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
         INFO = -12
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "RWorkspace:" describe the
!       minimal amount of real workspace needed at that point in the
!       code, as well as the preferred amount for good performance.
!       IWorkspace refers to integer workspace.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by DHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.
!       If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
!       depends on SDIM, which is computed by the routine DTRSEN later
!       in the code.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
         MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
         MINWRK = MAX( 1, 3*N )
         IF( .NOT.WANTVS ) THEN
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
         ELSE
            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* &
                     ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( LWORK.LT.MINWRK ) THEN
         INFO = -16
      END IF
      IF( LIWORK.LT.1 ) THEN
         INFO = -18
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEESX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA ) &
         CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
!
!     Permute the matrix to make it more nearly triangular
!     (RWorkspace: need N)
!
      IBAL = 1
      CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
!
!     Reduce to upper Hessenberg form
!     (RWorkspace: need 3*N, prefer 2*N+N*NB)
!
      ITAU = N + IBAL
      IWRK = N + ITAU
      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), &
                   LWORK-IWRK+1, IERR )
!
      IF( WANTVS ) THEN
!
!        Copy Householder vectors to VS
!
         CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
!
!        Generate orthogonal matrix in VS
!        (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
      END IF
!
      SDIM = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
!
      IWRK = ITAU
      CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS, &
                   WORK( IWRK ), LWORK-IWRK+1, IEVAL )
      IF( IEVAL.GT.0 ) &
         INFO = IEVAL
!
!     Sort eigenvalues if desired
!
      IF( WANTST .AND. INFO.EQ.0 ) THEN
         IF( SCALEA ) THEN
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
         END IF
         DO I = 1, N
            BWORK( I ) = SELECT( WR( I ), WI( I ) )
         end do
!
!        Reorder eigenvalues, transform Schur vectors, and compute
!        reciprocal condition numbers
!        (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
!                     otherwise, need N )
!        (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
!                     otherwise, need 0 )
!
         CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI, &
                      SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1, &
                      IWORK, LIWORK, ICOND )
         IF( .NOT.WANTSN ) &
            MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
         IF( ICOND.EQ.-15 ) THEN
!
!           Not enough real workspace
!
            INFO = -16
         ELSE IF( ICOND.EQ.-17 ) THEN
!
!           Not enough integer workspace
!
            INFO = -18
         ELSE IF( ICOND.GT.0 ) THEN
!
!           DTRSEN failed to reorder or to restore standard Schur form
!
            INFO = ICOND + N
         END IF
      END IF
!
      IF( WANTVS ) THEN
!
!        Undo balancing
!        (RWorkspace: need N)
!
         CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS, &
                      IERR )
      END IF
!
      IF( SCALEA ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
         CALL DCOPY( N, A, LDA+1, WR, 1 )
         IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
            DUM( 1 ) = RCONDV
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
            RCONDV = DUM( 1 )
         END IF
         IF( CSCALE.EQ.SMLNUM ) THEN
!
!           If scaling back towards underflow, adjust WI if an
!           offdiagonal element of a 2-by-2 block in the Schur form
!           underflows.
!
            IF( IEVAL.GT.0 ) THEN
               I1 = IEVAL + 1
               I2 = IHI - 1
               CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, &
                            IERR )
            ELSE IF( WANTST ) THEN
               I1 = 1
               I2 = N - 1
            ELSE
               I1 = ILO
               I2 = IHI - 1
            END IF
            INXT = I1 - 1
            DO 20 I = I1, I2
               IF( I.LT.INXT ) &
                  GO TO 20
               IF( WI( I ).EQ.ZERO ) THEN
                  INXT = I + 1
               ELSE
                  IF( A( I+1, I ).EQ.ZERO ) THEN
                     WI( I ) = ZERO
                     WI( I+1 ) = ZERO
                  ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ. &
                           ZERO ) THEN
                     WI( I ) = ZERO
                     WI( I+1 ) = ZERO
                     IF( I.GT.1 ) &
                        CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
                     IF( N.GT.I+1 ) &
                        CALL DSWAP( N-I-1, A( I, I+2 ), LDA, &
                                    A( I+1, I+2 ), LDA )
                     CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
                     A( I, I+1 ) = A( I+1, I )
                     A( I+1, I ) = ZERO
                  END IF
                  INXT = I + 2
               END IF
   20       CONTINUE
         END IF
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1, &
                      WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
      END IF
!
      IF( WANTST .AND. INFO.EQ.0 ) THEN
!
!        Check if reordering successful
!
         LASTSL = .TRUE.
         LST2SL = .TRUE.
         SDIM = 0
         IP = 0
         DO 30 I = 1, N
            CURSL = SELECT( WR( I ), WI( I ) )
            IF( WI( I ).EQ.ZERO ) THEN
               IF( CURSL ) &
                  SDIM = SDIM + 1
               IP = 0
               IF( CURSL .AND. .NOT.LASTSL ) &
                  INFO = N + 2
            ELSE
               IF( IP.EQ.1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
                  CURSL = CURSL .OR. LASTSL
                  LASTSL = CURSL
                  IF( CURSL ) &
                     SDIM = SDIM + 2
                  IP = -1
                  IF( CURSL .AND. .NOT.LST2SL ) &
                     INFO = N + 2
               ELSE
!
!                 First eigenvalue of conjugate pair
!
                  IP = 1
               END IF
            END IF
            LST2SL = LASTSL
            LASTSL = CURSL
   30    CONTINUE
      END IF
!
      WORK( 1 ) = MAXWRK
      IF( WANTSV .OR. WANTSB ) THEN
         IWORK( 1 ) = SDIM*( N-SDIM )
      ELSE
         IWORK( 1 ) = 1
      END IF
!
      RETURN
!
!     End of DGEESX
!
      END
      SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, &
                        LDVR, WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     December 8, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), &
                         WI( * ), WORK( * ), WR( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEEV computes for an N-by-N real nonsymmetric matrix A, the
!  eigenvalues and, optionally, the left and/or right eigenvectors.
!
!  The right eigenvector v(j) of A satisfies
!                   A * v(j) = lambda(j) * v(j)
!  where lambda(j) is its eigenvalue.
!  The left eigenvector u(j) of A satisfies
!                u(j)**H * A = lambda(j) * u(j)**H
!  where u(j)**H denotes the conjugate transpose of u(j).
!
!  The computed eigenvectors are normalized to have Euclidean norm
!  equal to 1 and largest component real.
!
!  Arguments
!  =========
!
!  JOBVL   (input) CHARACTER*1
!          = 'N': left eigenvectors of A are not computed;
!          = 'V': left eigenvectors of A are computed.
!
!  JOBVR   (input) CHARACTER*1
!          = 'N': right eigenvectors of A are not computed;
!          = 'V': right eigenvectors of A are computed.
!
!  N       (input) INTEGER
!          The order of the matrix A. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N matrix A.
!          On exit, A has been overwritten.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          WR and WI contain the real and imaginary parts,
!          respectively, of the computed eigenvalues.  Complex
!          conjugate pairs of eigenvalues appear consecutively
!          with the eigenvalue having the positive imaginary part
!          first.
!
!  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
!          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!          after another in the columns of VL, in the same order
!          as their eigenvalues.
!          If JOBVL = 'N', VL is not referenced.
!          If the j-th eigenvalue is real, then u(j) = VL(:,j),
!          the j-th column of VL.
!          If the j-th and (j+1)-st eigenvalues form a complex
!          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
!          u(j+1) = VL(:,j) - i*VL(:,j+1).
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL.  LDVL >= 1; if
!          JOBVL = 'V', LDVL >= N.
!
!  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
!          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!          after another in the columns of VR, in the same order
!          as their eigenvalues.
!          If JOBVR = 'N', VR is not referenced.
!          If the j-th eigenvalue is real, then v(j) = VR(:,j),
!          the j-th column of VR.
!          If the j-th and (j+1)-st eigenvalues form a complex
!          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
!          v(j+1) = VR(:,j) - i*VR(:,j+1).
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.  LDVR >= 1; if
!          JOBVR = 'V', LDVR >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,3*N), and
!          if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N.  For good
!          performance, LWORK must generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, the QR algorithm failed to compute all the
!                eigenvalues, and no eigenvectors have been computed;
!                elements i+1:N of WR and WI contain eigenvalues which
!                have converged.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
      CHARACTER          SIDE
      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K, &
                         MAXB, MAXWRK, MINWRK, NOUT
      DOUBLE PRECISION   ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, &
                         SN
!     ..
!     .. Local Arrays ..
      LOGICAL            SELECT( 1 )
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, &
                         DLASCL, DORGHR, DROT, DSCAL, DTREVC, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE, DLAPY2, DNRM2
      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, &
                         DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVL = LSAME( JOBVL, 'V' )
      WANTVR = LSAME( JOBVR, 'V' )
      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
         INFO = -9
      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
         INFO = -11
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by DHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
         IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
            MINWRK = MAX( 1, 3*N )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
         ELSE
            MINWRK = MAX( 1, 4*N )
            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* &
                     ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
            MAXWRK = MAX( MAXWRK, 4*N )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEEV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA ) &
         CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
!
!     Balance the matrix
!     (Workspace: need N)
!
      IBAL = 1
      CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
!
!     Reduce to upper Hessenberg form
!     (Workspace: need 3*N, prefer 2*N+N*NB)
!
      ITAU = IBAL + N
      IWRK = ITAU + N
      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), &
                   LWORK-IWRK+1, IERR )
!
      IF( WANTVL ) THEN
!
!        Want left eigenvectors
!        Copy Householder vectors to VL
!
         SIDE = 'L'
         CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
!
!        Generate orthogonal matrix in VL
!        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
!
!        Perform QR iteration, accumulating Schur vectors in VL
!        (Workspace: need N+1, prefer N+HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
!
         IF( WANTVR ) THEN
!
!           Want left and right eigenvectors
!           Copy Schur vectors to VR
!
            SIDE = 'B'
            CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
         END IF
!
      ELSE IF( WANTVR ) THEN
!
!        Want right eigenvectors
!        Copy Householder vectors to VR
!
         SIDE = 'R'
         CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
!
!        Generate orthogonal matrix in VR
!        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
!
!        Perform QR iteration, accumulating Schur vectors in VR
!        (Workspace: need N+1, prefer N+HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
!
      ELSE
!
!        Compute eigenvalues only
!        (Workspace: need N+1, prefer N+HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
      END IF
!
!     If INFO > 0 from DHSEQR, then quit
!
      IF( INFO.GT.0 ) &
         GO TO 50
!
      IF( WANTVL .OR. WANTVR ) THEN
!
!        Compute left and/or right eigenvectors
!        (Workspace: need 4*N)
!
         CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, &
                      N, NOUT, WORK( IWRK ), IERR )
      END IF
!
      IF( WANTVL ) THEN
!
!        Undo balancing of left eigenvectors
!        (Workspace: need N)
!
         CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL, &
                      IERR )
!
!        Normalize left eigenvectors and make largest component real
!
         DO 20 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), &
                     DNRM2( N, VL( 1, I+1 ), 1 ) )
               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
               CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
               DO K = 1, N
                  WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
               end do
               K = IDAMAX( N, WORK( IWRK ), 1 )
               CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
               CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
               VL( K, I+1 ) = ZERO
            END IF
   20    CONTINUE
      END IF
!
      IF( WANTVR ) THEN
!
!        Undo balancing of right eigenvectors
!        (Workspace: need N)
!
         CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR, &
                      IERR )
!
!        Normalize right eigenvectors and make largest component real
!
         DO 40 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), &
                     DNRM2( N, VR( 1, I+1 ), 1 ) )
               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
               CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
               DO 30 K = 1, N
                  WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
   30          CONTINUE
               K = IDAMAX( N, WORK( IWRK ), 1 )
               CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
               CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
               VR( K, I+1 ) = ZERO
            END IF
   40    CONTINUE
      END IF
!
!     Undo scaling if necessary
!
   50 CONTINUE
      IF( SCALEA ) THEN
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), &
                      MAX( N-INFO, 1 ), IERR )
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), &
                      MAX( N-INFO, 1 ), IERR )
         IF( INFO.GT.0 ) THEN
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, &
                         IERR )
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, &
                         IERR )
         END IF
      END IF
!
      WORK( 1 ) = MAXWRK
      RETURN
!
!     End of DGEEV
!
      END
      SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, &
                         VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, &
                         RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
      INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
      DOUBLE PRECISION   ABNRM
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), RCONDE( * ), RCONDV( * ), &
                         SCALE( * ), VL( LDVL, * ), VR( LDVR, * ), &
                         WI( * ), WORK( * ), WR( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!  eigenvalues and, optionally, the left and/or right eigenvectors.
!
!  Optionally also, it computes a balancing transformation to improve
!  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!  (RCONDE), and reciprocal condition numbers for the right
!  eigenvectors (RCONDV).
!
!  The right eigenvector v(j) of A satisfies
!                   A * v(j) = lambda(j) * v(j)
!  where lambda(j) is its eigenvalue.
!  The left eigenvector u(j) of A satisfies
!                u(j)**H * A = lambda(j) * u(j)**H
!  where u(j)**H denotes the conjugate transpose of u(j).
!
!  The computed eigenvectors are normalized to have Euclidean norm
!  equal to 1 and largest component real.
!
!  Balancing a matrix means permuting the rows and columns to make it
!  more nearly upper triangular, and applying a diagonal similarity
!  transformation D * A * D**(-1), where D is a diagonal matrix, to
!  make its rows and columns closer in norm and the condition numbers
!  of its eigenvalues and eigenvectors smaller.  The computed
!  reciprocal condition numbers correspond to the balanced matrix.
!  Permuting rows and columns will not change the condition numbers
!  (in exact arithmetic) but diagonal scaling will.  For further
!  explanation of balancing, see section 4.10.2 of the LAPACK
!  Users' Guide.
!
!  Arguments
!  =========
!
!  BALANC  (input) CHARACTER*1
!          Indicates how the input matrix should be diagonally scaled
!          and/or permuted to improve the conditioning of its
!          eigenvalues.
!          = 'N': Do not diagonally scale or permute;
!          = 'P': Perform permutations to make the matrix more nearly
!                 upper triangular. Do not diagonally scale;
!          = 'S': Diagonally scale the matrix, i.e. replace A by
!                 D*A*D**(-1), where D is a diagonal matrix chosen
!                 to make the rows and columns of A more equal in
!                 norm. Do not permute;
!          = 'B': Both diagonally scale and permute A.
!
!          Computed reciprocal condition numbers will be for the matrix
!          after balancing and/or permuting. Permuting does not change
!          condition numbers (in exact arithmetic), but balancing does.
!
!  JOBVL   (input) CHARACTER*1
!          = 'N': left eigenvectors of A are not computed;
!          = 'V': left eigenvectors of A are computed.
!          If SENSE = 'E' or 'B', JOBVL must = 'V'.
!
!  JOBVR   (input) CHARACTER*1
!          = 'N': right eigenvectors of A are not computed;
!          = 'V': right eigenvectors of A are computed.
!          If SENSE = 'E' or 'B', JOBVR must = 'V'.
!
!  SENSE   (input) CHARACTER*1
!          Determines which reciprocal condition numbers are computed.
!          = 'N': None are computed;
!          = 'E': Computed for eigenvalues only;
!          = 'V': Computed for right eigenvectors only;
!          = 'B': Computed for eigenvalues and right eigenvectors.
!
!          If SENSE = 'E' or 'B', both left and right eigenvectors
!          must also be computed (JOBVL = 'V' and JOBVR = 'V').
!
!  N       (input) INTEGER
!          The order of the matrix A. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N matrix A.
!          On exit, A has been overwritten.  If JOBVL = 'V' or
!          JOBVR = 'V', A contains the real Schur form of the balanced
!          version of the input matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          WR and WI contain the real and imaginary parts,
!          respectively, of the computed eigenvalues.  Complex
!          conjugate pairs of eigenvalues will appear consecutively
!          with the eigenvalue having the positive imaginary part
!          first.
!
!  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
!          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!          after another in the columns of VL, in the same order
!          as their eigenvalues.
!          If JOBVL = 'N', VL is not referenced.
!          If the j-th eigenvalue is real, then u(j) = VL(:,j),
!          the j-th column of VL.
!          If the j-th and (j+1)-st eigenvalues form a complex
!          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
!          u(j+1) = VL(:,j) - i*VL(:,j+1).
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL.  LDVL >= 1; if
!          JOBVL = 'V', LDVL >= N.
!
!  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
!          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!          after another in the columns of VR, in the same order
!          as their eigenvalues.
!          If JOBVR = 'N', VR is not referenced.
!          If the j-th eigenvalue is real, then v(j) = VR(:,j),
!          the j-th column of VR.
!          If the j-th and (j+1)-st eigenvalues form a complex
!          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
!          v(j+1) = VR(:,j) - i*VR(:,j+1).
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.  LDVR >= 1, and if
!          JOBVR = 'V', LDVR >= N.
!
!  ILO,IHI (output) INTEGER
!          ILO and IHI are integer values determined when A was
!          balanced.  The balanced A(i,j) = 0 if I > J and
!          J = 1,...,ILO-1 or I = IHI+1,...,N.
!
!  SCALE   (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied
!          when balancing A.  If P(j) is the index of the row and column
!          interchanged with row and column j, and D(j) is the scaling
!          factor applied to row and column j, then
!          SCALE(J) = P(J),    for J = 1,...,ILO-1
!                   = D(J),    for J = ILO,...,IHI
!                   = P(J)     for J = IHI+1,...,N.
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  ABNRM   (output) DOUBLE PRECISION
!          The one-norm of the balanced matrix (the maximum
!          of the sum of absolute values of elements of any column).
!
!  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
!          RCONDE(j) is the reciprocal condition number of the j-th
!          eigenvalue.
!
!  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
!          RCONDV(j) is the reciprocal condition number of the j-th
!          right eigenvector.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.   If SENSE = 'N' or 'E',
!          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
!          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).
!          For good performance, LWORK must generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (2*N-2)
!          If SENSE = 'N' or 'E', not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, the QR algorithm failed to compute all the
!                eigenvalues, and no eigenvectors or condition numbers
!                have been computed; elements 1:ILO-1 and i+1:N of WR
!                and WI contain eigenvalues which have converged.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE, &
                         WNTSNN, WNTSNV
      CHARACTER          JOB, SIDE
      INTEGER            HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXB, &
                         MAXWRK, MINWRK, NOUT
      DOUBLE PRECISION   ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM, &
                         SN
!     ..
!     .. Local Arrays ..
      LOGICAL            SELECT( 1 )
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY, DLARTG, &
                         DLASCL, DORGHR, DROT, DSCAL, DTREVC, DTRSNA, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE, DLAPY2, DNRM2
      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2, &
                         DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      WANTVL = LSAME( JOBVL, 'V' )
      WANTVR = LSAME( JOBVR, 'V' )
      WNTSNN = LSAME( SENSE, 'N' )
      WNTSNE = LSAME( SENSE, 'E' )
      WNTSNV = LSAME( SENSE, 'V' )
      WNTSNB = LSAME( SENSE, 'B' )
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, &
          'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) &
           THEN
         INFO = -1
      ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR. &
               ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND. &
               WANTVR ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
         INFO = -13
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by DHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
         IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
            MINWRK = MAX( 1, 2*N )
            IF( .NOT.WNTSNN ) &
               MINWRK = MAX( MINWRK, N*N+6*N )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 )
            IF( WNTSNN ) THEN
               K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, &
                   1, N, -1 ) ) )
            ELSE
               K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, &
                   1, N, -1 ) ) )
            END IF
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, 1, HSWORK )
            IF( .NOT.WNTSNN ) &
               MAXWRK = MAX( MAXWRK, N*N+6*N )
         ELSE
            MINWRK = MAX( 1, 3*N )
            IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) &
               MINWRK = MAX( MINWRK, N*N+6*N )
            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 )
            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1, &
                N, -1 ) ) )
            HSWORK = MAX( K*( K+2 ), 2*N )
            MAXWRK = MAX( MAXWRK, 1, HSWORK )
            MAXWRK = MAX( MAXWRK, N+( N-1 )* &
                     ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
            IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) ) &
               MAXWRK = MAX( MAXWRK, N*N+6*N )
            MAXWRK = MAX( MAXWRK, 3*N, 1 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -21
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEEVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ICOND = 0
      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
      SCALEA = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         SCALEA = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF( SCALEA ) &
         CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
!
!     Balance the matrix and compute ABNRM
!
      CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
      ABNRM = DLANGE( '1', N, N, A, LDA, DUM )
      IF( SCALEA ) THEN
         DUM( 1 ) = ABNRM
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
         ABNRM = DUM( 1 )
      END IF
!
!     Reduce to upper Hessenberg form
!     (Workspace: need 2*N, prefer N+N*NB)
!
      ITAU = 1
      IWRK = ITAU + N
      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), &
                   LWORK-IWRK+1, IERR )
!
      IF( WANTVL ) THEN
!
!        Want left eigenvectors
!        Copy Householder vectors to VL
!
         SIDE = 'L'
         CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
!
!        Generate orthogonal matrix in VL
!        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
!
!        Perform QR iteration, accumulating Schur vectors in VL
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
!
         IF( WANTVR ) THEN
!
!           Want left and right eigenvectors
!           Copy Schur vectors to VR
!
            SIDE = 'B'
            CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
         END IF
!
      ELSE IF( WANTVR ) THEN
!
!        Want right eigenvectors
!        Copy Householder vectors to VR
!
         SIDE = 'R'
         CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
!
!        Generate orthogonal matrix in VR
!        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
!
         CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), &
                      LWORK-IWRK+1, IERR )
!
!        Perform QR iteration, accumulating Schur vectors in VR
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
!
      ELSE
!
!        Compute eigenvalues only
!        If condition numbers desired, compute Schur form
!
         IF( WNTSNN ) THEN
            JOB = 'E'
         ELSE
            JOB = 'S'
         END IF
!
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         IWRK = ITAU
         CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR, &
                      WORK( IWRK ), LWORK-IWRK+1, INFO )
      END IF
!
!     If INFO > 0 from DHSEQR, then quit
!
      IF( INFO.GT.0 ) &
         GO TO 50
!
      IF( WANTVL .OR. WANTVR ) THEN
!
!        Compute left and/or right eigenvectors
!        (Workspace: need 3*N)
!
         CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, &
                      N, NOUT, WORK( IWRK ), IERR )
      END IF
!
!     Compute condition numbers if desired
!     (Workspace: need N*N+6*N unless SENSE = 'E')
!
      IF( .NOT.WNTSNN ) THEN
         CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, &
                      RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK, &
                      ICOND )
      END IF
!
      IF( WANTVL ) THEN
!
!        Undo balancing of left eigenvectors
!
         CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL, &
                      IERR )
!
!        Normalize left eigenvectors and make largest component real
!
         DO 20 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ), &
                     DNRM2( N, VL( 1, I+1 ), 1 ) )
               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
               CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
               DO K = 1, N
                  WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
               end do
               K = IDAMAX( N, WORK, 1 )
               CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
               CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
               VL( K, I+1 ) = ZERO
            END IF
   20    CONTINUE
      END IF
!
      IF( WANTVR ) THEN
!
!        Undo balancing of right eigenvectors
!
         CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR, &
                      IERR )
!
!        Normalize right eigenvectors and make largest component real
!
         DO 40 I = 1, N
            IF( WI( I ).EQ.ZERO ) THEN
               SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
            ELSE IF( WI( I ).GT.ZERO ) THEN
               SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ), &
                     DNRM2( N, VR( 1, I+1 ), 1 ) )
               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
               CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
               DO 30 K = 1, N
                  WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
   30          CONTINUE
               K = IDAMAX( N, WORK, 1 )
               CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
               CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
               VR( K, I+1 ) = ZERO
            END IF
   40    CONTINUE
      END IF
!
!     Undo scaling if necessary
!
   50 CONTINUE
      IF( SCALEA ) THEN
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), &
                      MAX( N-INFO, 1 ), IERR )
         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), &
                      MAX( N-INFO, 1 ), IERR )
         IF( INFO.EQ.0 ) THEN
            IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 ) &
               CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N, &
                            IERR )
         ELSE
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, &
                         IERR )
            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, &
                         IERR )
         END IF
      END IF
!
      WORK( 1 ) = MAXWRK
      RETURN
!
!     End of DGEEVX
!
      END
      SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, &
                        ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, &
                        LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVSL, JOBVSR
      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), VSL( LDVSL, * ), &
                         VSR( LDVSR, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DGGES.
!
!  DGEGS computes for a pair of N-by-N real nonsymmetric matrices A, B:
!  the generalized eigenvalues (alphar +/- alphai*i, beta), the real
!  Schur form (A, B), and optionally left and/or right Schur vectors
!  (VSL and VSR).
!
!  (If only the generalized eigenvalues are needed, use the driver DGEGV
!  instead.)
!
!  A generalized eigenvalue for a pair of matrices (A,B) is, roughly
!  speaking, a scalar w or a ratio  alpha/beta = w, such that  A - w*B
!  is singular.  It is usually represented as the pair (alpha,beta),
!  as there is a reasonable interpretation for beta=0, and even for
!  both being zero.  A good beginning reference is the book, "Matrix
!  Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
!
!  The (generalized) Schur form of a pair of matrices is the result of
!  multiplying both matrices on the left by one orthogonal matrix and
!  both on the right by another orthogonal matrix, these two orthogonal
!  matrices being chosen so as to bring the pair of matrices into
!  (real) Schur form.
!
!  A pair of matrices A, B is in generalized real Schur form if B is
!  upper triangular with non-negative diagonal and A is block upper
!  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
!  to real generalized eigenvalues, while 2-by-2 blocks of A will be
!  "standardized" by making the corresponding elements of B have the
!  form:
!          [  a  0  ]
!          [  0  b  ]
!
!  and the pair of corresponding 2-by-2 blocks in A and B will
!  have a complex conjugate pair of generalized eigenvalues.
!
!  The left and right Schur vectors are the columns of VSL and VSR,
!  respectively, where VSL and VSR are the orthogonal matrices
!  which reduce A and B to Schur form:
!
!  Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) )
!
!  Arguments
!  =========
!
!  JOBVSL  (input) CHARACTER*1
!          = 'N':  do not compute the left Schur vectors;
!          = 'V':  compute the left Schur vectors.
!
!  JOBVSR  (input) CHARACTER*1
!          = 'N':  do not compute the right Schur vectors;
!          = 'V':  compute the right Schur vectors.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the first of the pair of matrices whose generalized
!          eigenvalues and (optionally) Schur vectors are to be
!          computed.
!          On exit, the generalized Schur form of A.
!          Note: to avoid overflow, the Frobenius norm of the matrix
!          A should be less than the overflow threshold.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the second of the pair of matrices whose
!          generalized eigenvalues and (optionally) Schur vectors are
!          to be computed.
!          On exit, the generalized Schur form of B.
!          Note: to avoid overflow, the Frobenius norm of the matrix
!          B should be less than the overflow threshold.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,
!          j=1,...,N  and  BETA(j),j=1,...,N  are the diagonals of the
!          complex Schur form (A,B) that would result if the 2-by-2
!          diagonal blocks of the real Schur form of (A,B) were further
!          reduced to triangular form using 2-by-2 complex unitary
!          transformations.  If ALPHAI(j) is zero, then the j-th
!          eigenvalue is real; if positive, then the j-th and (j+1)-st
!          eigenvalues are a complex conjugate pair, with ALPHAI(j+1)
!          negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio
!          alpha/beta.  However, ALPHAR and ALPHAI will be always less
!          than and usually comparable with norm(A) in magnitude, and
!          BETA always less than and usually comparable with norm(B).
!
!  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)
!          If JOBVSL = 'V', VSL will contain the left Schur vectors.
!          (See "Purpose", above.)
!          Not referenced if JOBVSL = 'N'.
!
!  LDVSL   (input) INTEGER
!          The leading dimension of the matrix VSL. LDVSL >=1, and
!          if JOBVSL = 'V', LDVSL >= N.
!
!  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)
!          If JOBVSR = 'V', VSR will contain the right Schur vectors.
!          (See "Purpose", above.)
!          Not referenced if JOBVSR = 'N'.
!
!  LDVSR   (input) INTEGER
!          The leading dimension of the matrix VSR. LDVSR >= 1, and
!          if JOBVSR = 'V', LDVSR >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,4*N).
!          For good performance, LWORK must generally be larger.
!          To compute the optimal value of LWORK, call ILAENV to get
!          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:
!          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
!          The optimal LWORK is  2*N + N*(NB+1).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  (A,B) are not in Schur
!                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
!                be correct for j=INFO+1,...,N.
!          > N:  errors that usually indicate LAPACK problems:
!                =N+1: error return from DGGBAL
!                =N+2: error return from DGEQRF
!                =N+3: error return from DORMQR
!                =N+4: error return from DORGQR
!                =N+5: error return from DGGHRD
!                =N+6: error return from DHGEQZ (other than failed
!                                                iteration)
!                =N+7: error return from DGGBAK (computing VSL)
!                =N+8: error return from DGGBAK (computing VSR)
!                =N+9: error return from DLASCL (various places)
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, &
                         IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, &
                         LWKOPT, NB, NB1, NB2, NB3
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, &
                         SAFMIN, SMLNUM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, &
                         DLASCL, DLASET, DORGQR, DORMQR, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVSL, 'N' ) ) THEN
         IJOBVL = 1
         ILVSL = .FALSE.
      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
         IJOBVL = 2
         ILVSL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVSL = .FALSE.
      END IF
!
      IF( LSAME( JOBVSR, 'N' ) ) THEN
         IJOBVR = 1
         ILVSR = .FALSE.
      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
         IJOBVR = 2
         ILVSR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVSR = .FALSE.
      END IF
!
!     Test the input arguments
!
      LWKMIN = MAX( 4*N, 1 )
      LWKOPT = LWKMIN
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      INFO = 0
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
         INFO = -16
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
         NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
         NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
         NB = MAX( NB1, NB2, NB3 )
         LOPT = 2*N + N*( NB+1 )
         WORK( 1 ) = LOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEGS ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
      SAFMIN = DLAMCH( 'S' )
      SMLNUM = N*SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
!
!     Permute the matrix to make it more nearly triangular
!     Workspace layout:  (2*N words -- "work..." not actually used)
!        left_permutation, right_permutation, work...
!
      ILEFT = 1
      IRIGHT = N + 1
      IWORK = IRIGHT + N
      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), &
                   WORK( IRIGHT ), WORK( IWORK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 1
         GO TO 10
      END IF
!
!     Reduce B to triangular form, and initialize VSL and/or VSR
!     Workspace layout:  ("work..." must have at least N words)
!        left_permutation, right_permutation, tau, work...
!
      IROWS = IHI + 1 - ILO
      ICOLS = N + 1 - ILO
      ITAU = IWORK
      IWORK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 2
         GO TO 10
      END IF
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), &
                   LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 3
         GO TO 10
      END IF
!
      IF( ILVSL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VSL( ILO+1, ILO ), LDVSL )
         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, &
                      WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, &
                      IINFO )
         IF( IINFO.GE.0 ) &
            LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 4
            GO TO 10
         END IF
      END IF
!
      IF( ILVSR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
!
!     Reduce to generalized Hessenberg form
!
      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, &
                   LDVSL, VSR, LDVSR, IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 5
         GO TO 10
      END IF
!
!     Perform QZ algorithm, computing Schur vectors if desired
!     Workspace layout:  ("work..." must have at least 1 word)
!        left_permutation, right_permutation, work...
!
      IWORK = ITAU
      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, &
                   WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
            INFO = IINFO
         ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
            INFO = IINFO - N
         ELSE
            INFO = N + 6
         END IF
         GO TO 10
      END IF
!
!     Apply permutation to VSL and VSR
!
      IF( ILVSL ) THEN
         CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 7
            GO TO 10
         END IF
      END IF
      IF( ILVSR ) THEN
         CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 8
            GO TO 10
         END IF
      END IF
!
!     Undo scaling
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
         CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, &
                      IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
         CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, &
                      IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
         CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
!
   10 CONTINUE
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DGEGS
!
      END
      SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, &
                        BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), VL( LDVL, * ), &
                         VR( LDVR, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DGGEV.
!
!  DGEGV computes for a pair of n-by-n real nonsymmetric matrices A and
!  B, the generalized eigenvalues (alphar +/- alphai*i, beta), and
!  optionally, the left and/or right generalized eigenvectors (VL and
!  VR).
!
!  A generalized eigenvalue for a pair of matrices (A,B) is, roughly
!  speaking, a scalar w or a ratio  alpha/beta = w, such that  A - w*B
!  is singular.  It is usually represented as the pair (alpha,beta),
!  as there is a reasonable interpretation for beta=0, and even for
!  both being zero.  A good beginning reference is the book, "Matrix
!  Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
!
!  A right generalized eigenvector corresponding to a generalized
!  eigenvalue  w  for a pair of matrices (A,B) is a vector  r  such
!  that  (A - w B) r = 0 .  A left generalized eigenvector is a vector
!  l such that l**H * (A - w B) = 0, where l**H is the
!  conjugate-transpose of l.
!
!  Note: this routine performs "full balancing" on A and B -- see
!  "Further Details", below.
!
!  Arguments
!  =========
!
!  JOBVL   (input) CHARACTER*1
!          = 'N':  do not compute the left generalized eigenvectors;
!          = 'V':  compute the left generalized eigenvectors.
!
!  JOBVR   (input) CHARACTER*1
!          = 'N':  do not compute the right generalized eigenvectors;
!          = 'V':  compute the right generalized eigenvectors.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VL, and VR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the first of the pair of matrices whose
!          generalized eigenvalues and (optionally) generalized
!          eigenvectors are to be computed.
!          On exit, the contents will have been destroyed.  (For a
!          description of the contents of A on exit, see "Further
!          Details", below.)
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the second of the pair of matrices whose
!          generalized eigenvalues and (optionally) generalized
!          eigenvectors are to be computed.
!          On exit, the contents will have been destroyed.  (For a
!          description of the contents of B on exit, see "Further
!          Details", below.)
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
!          the j-th eigenvalue is real; if positive, then the j-th and
!          (j+1)-st eigenvalues are a complex conjugate pair, with
!          ALPHAI(j+1) negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio
!          alpha/beta.  However, ALPHAR and ALPHAI will be always less
!          than and usually comparable with norm(A) in magnitude, and
!          BETA always less than and usually comparable with norm(B).
!
!  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
!          If JOBVL = 'V', the left generalized eigenvectors.  (See
!          "Purpose", above.)  Real eigenvectors take one column,
!          complex take two columns, the first for the real part and
!          the second for the imaginary part.  Complex eigenvectors
!          correspond to an eigenvalue with positive imaginary part.
!          Each eigenvector will be scaled so the largest component
!          will have abs(real part) + abs(imag. part) = 1, *except*
!          that for eigenvalues with alpha=beta=0, a zero vector will
!          be returned as the corresponding eigenvector.
!          Not referenced if JOBVL = 'N'.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the matrix VL. LDVL >= 1, and
!          if JOBVL = 'V', LDVL >= N.
!
!  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
!          If JOBVR = 'V', the right generalized eigenvectors.  (See
!          "Purpose", above.)  Real eigenvectors take one column,
!          complex take two columns, the first for the real part and
!          the second for the imaginary part.  Complex eigenvectors
!          correspond to an eigenvalue with positive imaginary part.
!          Each eigenvector will be scaled so the largest component
!          will have abs(real part) + abs(imag. part) = 1, *except*
!          that for eigenvalues with alpha=beta=0, a zero vector will
!          be returned as the corresponding eigenvector.
!          Not referenced if JOBVR = 'N'.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the matrix VR. LDVR >= 1, and
!          if JOBVR = 'V', LDVR >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,8*N).
!          For good performance, LWORK must generally be larger.
!          To compute the optimal value of LWORK, call ILAENV to get
!          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:
!          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;
!          The optimal LWORK is:
!              2*N + MAX( 6*N, N*(NB+1) ).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  No eigenvectors have been
!                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!                should be correct for j=INFO+1,...,N.
!          > N:  errors that usually indicate LAPACK problems:
!                =N+1: error return from DGGBAL
!                =N+2: error return from DGEQRF
!                =N+3: error return from DORMQR
!                =N+4: error return from DORGQR
!                =N+5: error return from DGGHRD
!                =N+6: error return from DHGEQZ (other than failed
!                                                iteration)
!                =N+7: error return from DTGEVC
!                =N+8: error return from DGGBAK (computing VL)
!                =N+9: error return from DGGBAK (computing VR)
!                =N+10: error return from DLASCL (various calls)
!
!  Further Details
!  ===============
!
!  Balancing
!  ---------
!
!  This driver calls DGGBAL to both permute and scale rows and columns
!  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
!  and PL*B*R will be upper triangular except for the diagonal blocks
!  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
!  possible.  The diagonal scaling matrices DL and DR are chosen so
!  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
!  one (except for the elements that start out zero.)
!
!  After the eigenvalues and eigenvectors of the balanced matrices
!  have been computed, DGGBAK transforms the eigenvectors back to what
!  they would have been (in perfect arithmetic) if they had not been
!  balanced.
!
!  Contents of A and B on Exit
!  -------- -- - --- - -- ----
!
!  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
!  both), then on exit the arrays A and B will contain the real Schur
!  form[*] of the "balanced" versions of A and B.  If no eigenvectors
!  are computed, then only the diagonal blocks will be correct.
!
!  [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
!      by Golub & van Loan, pub. by Johns Hopkins U. Press.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILIMIT, ILV, ILVL, ILVR, LQUERY
      CHARACTER          CHTEMP
      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, &
                         IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT, &
                         LWKMIN, LWKOPT, NB, NB1, NB2, NB3
      DOUBLE PRECISION   ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM, &
                         BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN, &
                         SALFAI, SALFAR, SBETA, SCALE, TEMP
!     ..
!     .. Local Arrays ..
      LOGICAL            LDUMMA( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, &
                         DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVL, 'N' ) ) THEN
         IJOBVL = 1
         ILVL = .FALSE.
      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
         IJOBVL = 2
         ILVL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVL = .FALSE.
      END IF
!
      IF( LSAME( JOBVR, 'N' ) ) THEN
         IJOBVR = 1
         ILVR = .FALSE.
      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
         IJOBVR = 2
         ILVR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVR = .FALSE.
      END IF
      ILV = ILVL .OR. ILVR
!
!     Test the input arguments
!
      LWKMIN = MAX( 8*N, 1 )
      LWKOPT = LWKMIN
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      INFO = 0
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
         INFO = -16
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
         NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
         NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
         NB = MAX( NB1, NB2, NB3 )
         LOPT = 2*N + MAX( 6*N, N*( NB+1 ) )
         WORK( 1 ) = LOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEGV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
      SAFMIN = DLAMCH( 'S' )
      SAFMIN = SAFMIN + SAFMIN
      SAFMAX = ONE / SAFMIN
      ONEPLS = ONE + ( 4*EPS )
!
!     Scale A
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ANRM1 = ANRM
      ANRM2 = ONE
      IF( ANRM.LT.ONE ) THEN
         IF( SAFMAX*ANRM.LT.ONE ) THEN
            ANRM1 = SAFMIN
            ANRM2 = SAFMAX*ANRM
         END IF
      END IF
!
      IF( ANRM.GT.ZERO ) THEN
         CALL DLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 10
            RETURN
         END IF
      END IF
!
!     Scale B
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      BNRM1 = BNRM
      BNRM2 = ONE
      IF( BNRM.LT.ONE ) THEN
         IF( SAFMAX*BNRM.LT.ONE ) THEN
            BNRM1 = SAFMIN
            BNRM2 = SAFMAX*BNRM
         END IF
      END IF
!
      IF( BNRM.GT.ZERO ) THEN
         CALL DLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 10
            RETURN
         END IF
      END IF
!
!     Permute the matrix to make it more nearly triangular
!     Workspace layout:  (8*N words -- "work" requires 6*N words)
!        left_permutation, right_permutation, work...
!
      ILEFT = 1
      IRIGHT = N + 1
      IWORK = IRIGHT + N
      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), &
                   WORK( IRIGHT ), WORK( IWORK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 1
         GO TO 120
      END IF
!
!     Reduce B to triangular form, and initialize VL and/or VR
!     Workspace layout:  ("work..." must have at least N words)
!        left_permutation, right_permutation, tau, work...
!
      IROWS = IHI + 1 - ILO
      IF( ILV ) THEN
         ICOLS = N + 1 - ILO
      ELSE
         ICOLS = IROWS
      END IF
      ITAU = IWORK
      IWORK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 2
         GO TO 120
      END IF
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), &
                   LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 3
         GO TO 120
      END IF
!
      IF( ILVL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VL( ILO+1, ILO ), LDVL )
         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, &
                      WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, &
                      IINFO )
         IF( IINFO.GE.0 ) &
            LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 4
            GO TO 120
         END IF
      END IF
!
      IF( ILVR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
!
!     Reduce to generalized Hessenberg form
!
      IF( ILV ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, &
                      LDVL, VR, LDVR, IINFO )
      ELSE
         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, &
                      B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
      END IF
      IF( IINFO.NE.0 ) THEN
         INFO = N + 5
         GO TO 120
      END IF
!
!     Perform QZ algorithm
!     Workspace layout:  ("work..." must have at least 1 word)
!        left_permutation, right_permutation, work...
!
      IWORK = ITAU
      IF( ILV ) THEN
         CHTEMP = 'S'
      ELSE
         CHTEMP = 'E'
      END IF
      CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, &
                   WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 ) &
         LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
            INFO = IINFO
         ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
            INFO = IINFO - N
         ELSE
            INFO = N + 6
         END IF
         GO TO 120
      END IF
!
      IF( ILV ) THEN
!
!        Compute Eigenvectors  (DTGEVC requires 6*N words of workspace)
!
         IF( ILVL ) THEN
            IF( ILVR ) THEN
               CHTEMP = 'B'
            ELSE
               CHTEMP = 'L'
            END IF
         ELSE
            CHTEMP = 'R'
         END IF
!
         CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, &
                      VR, LDVR, N, IN, WORK( IWORK ), IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 7
            GO TO 120
         END IF
!
!        Undo balancing on VL and VR, rescale
!
         IF( ILVL ) THEN
            CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), &
                         WORK( IRIGHT ), N, VL, LDVL, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = N + 8
               GO TO 120
            END IF
            DO 50 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO ) &
                  GO TO 50
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
                  end do
               ELSE
                  DO 20 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ &
                            ABS( VL( JR, JC+1 ) ) )
   20             CONTINUE
               END IF
               IF( TEMP.LT.SAFMIN ) &
                  GO TO 50
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 30 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
   30             CONTINUE
               ELSE
                  DO 40 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
                     VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
   40             CONTINUE
               END IF
   50       CONTINUE
         END IF
         IF( ILVR ) THEN
            CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), &
                         WORK( IRIGHT ), N, VR, LDVR, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = N + 9
               GO TO 120
            END IF
            DO 100 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO ) &
                  GO TO 100
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 60 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
   60             CONTINUE
               ELSE
                  DO 70 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ &
                            ABS( VR( JR, JC+1 ) ) )
   70             CONTINUE
               END IF
               IF( TEMP.LT.SAFMIN ) &
                  GO TO 100
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 80 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
   80             CONTINUE
               ELSE
                  DO 90 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
                     VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
!
!        End of eigenvector calculation
!
      END IF
!
!     Undo scaling in alpha, beta
!
!     Note: this does not give the alpha and beta for the unscaled
!     problem.
!
!     Un-scaling is limited to avoid underflow in alpha and beta
!     if they are significant.
!
      DO 110 JC = 1, N
         ABSAR = ABS( ALPHAR( JC ) )
         ABSAI = ABS( ALPHAI( JC ) )
         ABSB = ABS( BETA( JC ) )
         SALFAR = ANRM*ALPHAR( JC )
         SALFAI = ANRM*ALPHAI( JC )
         SBETA = BNRM*BETA( JC )
         ILIMIT = .FALSE.
         SCALE = ONE
!
!        Check for significant underflow in ALPHAI
!
         IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE. &
             MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
            ILIMIT = .TRUE.
            SCALE = ( ONEPLS*SAFMIN / ANRM1 ) / &
                    MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
!
         ELSE IF( SALFAI.EQ.ZERO ) THEN
!
!           If insignificant underflow in ALPHAI, then make the
!           conjugate eigenvalue real.
!
            IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
               ALPHAI( JC-1 ) = ZERO
            ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
               ALPHAI( JC+1 ) = ZERO
            END IF
         END IF
!
!        Check for significant underflow in ALPHAR
!
         IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE. &
             MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
            ILIMIT = .TRUE.
            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) / &
                    MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
         END IF
!
!        Check for significant underflow in BETA
!
         IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE. &
             MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
            ILIMIT = .TRUE.
            SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) / &
                    MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
         END IF
!
!        Check for possible overflow when limiting scaling
!
         IF( ILIMIT ) THEN
            TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ), &
                   ABS( SBETA ) )
            IF( TEMP.GT.ONE ) &
               SCALE = SCALE / TEMP
            IF( SCALE.LT.ONE ) &
               ILIMIT = .FALSE.
         END IF
!
!        Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
!
         IF( ILIMIT ) THEN
            SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
            SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
            SBETA = ( SCALE*BETA( JC ) )*BNRM
         END IF
         ALPHAR( JC ) = SALFAR
         ALPHAI( JC ) = SALFAI
         BETA( JC ) = SBETA
  110 CONTINUE
!
  120 CONTINUE
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DGEGV
!
      END
      SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
!  an orthogonal similarity transformation:  Q' * A * Q = H .
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that A is already upper triangular in rows
!          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
!          set by a previous call to DGEBAL; otherwise they should be
!          set to 1 and N respectively. See Further Details.
!          1 <= ILO <= IHI <= max(1,N).
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the n by n general matrix to be reduced.
!          On exit, the upper triangle and the first subdiagonal of A
!          are overwritten with the upper Hessenberg matrix H, and the
!          elements below the first subdiagonal, with the array TAU,
!          represent the orthogonal matrix Q as a product of elementary
!          reflectors. See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of (ihi-ilo) elementary
!  reflectors
!
!     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!  exit in A(i+2:ihi,i), and tau in TAU(i).
!
!  The contents of A are illustrated by the following example, with
!  n = 7, ilo = 2 and ihi = 6:
!
!  on entry,                        on exit,
!
!  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!  (                         a )    (                          a )
!
!  where a denotes an element of the original matrix A, h denotes a
!  modified element of the upper Hessenberg matrix H, and vi denotes an
!  element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   AII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEHD2', -INFO )
         RETURN
      END IF
!
      DO 10 I = ILO, IHI - 1
!
!        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
!
         CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, &
                      TAU( I ) )
         AII = A( I+1, I )
         A( I+1, I ) = ONE
!
!        Apply H(i) to A(1:ihi,i+1:ihi) from the right
!
         CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), &
                     A( 1, I+1 ), LDA, WORK )
!
!        Apply H(i) to A(i+1:ihi,i+1:n) from the left
!
         CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), &
                     A( I+1, I+1 ), LDA, WORK )
!
         A( I+1, I ) = AII
   10 CONTINUE
!
      RETURN
!
!     End of DGEHD2
!
      END
      SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEHRD reduces a real general matrix A to upper Hessenberg form H by
!  an orthogonal similarity transformation:  Q' * A * Q = H .
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that A is already upper triangular in rows
!          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
!          set by a previous call to DGEBAL; otherwise they should be
!          set to 1 and N respectively. See Further Details.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N general matrix to be reduced.
!          On exit, the upper triangle and the first subdiagonal of A
!          are overwritten with the upper Hessenberg matrix H, and the
!          elements below the first subdiagonal, with the array TAU,
!          represent the orthogonal matrix Q as a product of elementary
!          reflectors. See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors (see Further
!          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
!          zero.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,N).
!          For optimum performance LWORK >= N*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of (ihi-ilo) elementary
!  reflectors
!
!     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
!  exit in A(i+2:ihi,i), and tau in TAU(i).
!
!  The contents of A are illustrated by the following example, with
!  n = 7, ilo = 2 and ihi = 6:
!
!  on entry,                        on exit,
!
!  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
!  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
!  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
!  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
!  (                         a )    (                          a )
!
!  where a denotes an element of the original matrix A, h denotes a
!  modified element of the upper Hessenberg matrix H, and vi denotes an
!  element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, LDWORK, LWKOPT, NB, NBMIN, &
                         NH, NX
      DOUBLE PRECISION   EI
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEHRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
!
      TAU(1:ilo-1) = ZERO
      DO 20 I = MAX( 1, IHI ), N - 1
         TAU( I ) = ZERO
   20 CONTINUE
!
!     Quick return if possible
!
      NH = IHI - ILO + 1
      IF( NH.LE.1 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Determine the block size.
!
      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
      NBMIN = 2
      IWS = 1
      IF( NB.GT.1 .AND. NB.LT.NH ) THEN
!
!        Determine when to cross over from blocked to unblocked code
!        (last block is always handled by unblocked code).
!
         NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
         IF( NX.LT.NH ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            IWS = N*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  determine the
!              minimum value of NB, and reduce NB or force use of
!              unblocked code.
!
               NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI, &
                       -1 ) )
               IF( LWORK.GE.N*NBMIN ) THEN
                  NB = LWORK / N
               ELSE
                  NB = 1
               END IF
            END IF
         END IF
      END IF
      LDWORK = N
!
      IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
!
!        Use unblocked code below
!
         I = ILO
!
      ELSE
!
!        Use blocked code
!
         DO 30 I = ILO, IHI - 1 - NX, NB
            IB = MIN( NB, IHI-I )
!
!           Reduce columns i:i+ib-1 to Hessenberg form, returning the
!           matrices V and T of the block reflector H = I - V*T*V'
!           which performs the reduction, and also the matrix Y = A*V*T
!
            CALL DLAHRD( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT, &
                         WORK, LDWORK )
!
!           Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
!           right, computing  A := A - Y * V'. V(i+ib,ib-1) must be set
!           to 1.
!
            EI = A( I+IB, I+IB-1 )
            A( I+IB, I+IB-1 ) = ONE
            CALL DGEMM( 'No transpose', 'Transpose', IHI, IHI-I-IB+1, &
                        IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, &
                        A( 1, I+IB ), LDA )
            A( I+IB, I+IB-1 ) = EI
!
!           Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
!           left
!
            CALL DLARFB( 'Left', 'Transpose', 'Forward', 'Columnwise', &
                         IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT, &
                         A( I+1, I+IB ), LDA, WORK, LDWORK )
   30    CONTINUE
      END IF
!
!     Use unblocked code to reduce the rest of the matrix
!
      CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
      WORK( 1 ) = IWS
!
      RETURN
!
!     End of DGEHRD
!
      END
      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELQ2 computes an LQ factorization of a real m by n matrix A:
!  A = L * Q.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix A.
!          On exit, the elements on and below the diagonal of the array
!          contain the m by min(m,n) lower trapezoidal matrix L (L is
!          lower triangular if m <= n); the elements above the diagonal,
!          with the array TAU, represent the orthogonal matrix Q as a
!          product of elementary reflectors (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!  and tau in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELQ2', -INFO )
         RETURN
      END IF
!
      K = MIN( M, N )
!
      DO 10 I = 1, K
!
!        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
!
         CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, &
                      TAU( I ) )
         IF( I.LT.M ) THEN
!
!           Apply H(i) to A(i+1:m,i:n) from the right
!
            AII = A( I, I )
            A( I, I ) = ONE
            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), &
                        A( I+1, I ), LDA, WORK )
            A( I, I ) = AII
         END IF
   10 CONTINUE
      RETURN
!
!     End of DGELQ2
!
      END
      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELQF computes an LQ factorization of a real M-by-N matrix A:
!  A = L * Q.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the elements on and below the diagonal of the array
!          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
!          lower triangular if m <= n); the elements above the diagonal,
!          with the array TAU, represent the orthogonal matrix Q as a
!          product of elementary reflectors (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,M).
!          For optimum performance LWORK >= M*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
!  and tau in TAU(i).
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, &
                         NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGELQ2, DLARFB, DLARFT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
      LWKOPT = M*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, &
                       -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code initially
!
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
!
!           Compute the LQ factorization of the current block
!           A(i:i+ib-1,i:n)
!
            CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, &
                         IINFO )
            IF( I+IB.LE.M ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), &
                            LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H to A(i+ib:m,i:n) from the right
!
               CALL DLARFB( 'Right', 'No transpose', 'Forward', &
                            'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), &
                            LDA, WORK, LDWORK, A( I+IB, I ), LDA, &
                            WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
!
!     Use unblocked code to factor the last or only block.
!
      IF( I.LE.K ) &
         CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, &
                      IINFO )
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGELQF
!
      END
      SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, &
                        INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELS solves overdetermined or underdetermined real linear systems
!  involving an M-by-N matrix A, or its transpose, using a QR or LQ
!  factorization of A.  It is assumed that A has full rank.
!
!  The following options are provided:
!
!  1. If TRANS = 'N' and m >= n:  find the least squares solution of
!     an overdetermined system, i.e., solve the least squares problem
!                  minimize || B - A*X ||.
!
!  2. If TRANS = 'N' and m < n:  find the minimum norm solution of
!     an underdetermined system A * X = B.
!
!  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
!     an undetermined system A**T * X = B.
!
!  4. If TRANS = 'T' and m < n:  find the least squares solution of
!     an overdetermined system, i.e., solve the least squares problem
!                  minimize || B - A**T * X ||.
!
!  Several right hand side vectors b and solution vectors x can be
!  handled in a single call; they are stored as the columns of the
!  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!  matrix X.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER
!          = 'N': the linear system involves A;
!          = 'T': the linear system involves A**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of
!          columns of the matrices B and X. NRHS >=0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit,
!            if M >= N, A is overwritten by details of its QR
!                       factorization as returned by DGEQRF;
!            if M <  N, A is overwritten by details of its LQ
!                       factorization as returned by DGELQF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the matrix B of right hand side vectors, stored
!          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
!          if TRANS = 'T'.
!          On exit, B is overwritten by the solution vectors, stored
!          columnwise:
!          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
!          squares solution vectors; the residual sum of squares for the
!          solution in each column is given by the sum of squares of
!          elements N+1 to M in that column;
!          if TRANS = 'N' and m < n, rows 1 to N of B contain the
!          minimum norm solution vectors;
!          if TRANS = 'T' and m >= n, rows 1 to M of B contain the
!          minimum norm solution vectors;
!          if TRANS = 'T' and m < n, rows 1 to M of B contain the
!          least squares solution vectors; the residual sum of squares
!          for the solution in each column is given by the sum of
!          squares of elements M+1 to N in that column.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= MAX(1,M,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          LWORK >= max( 1, MN + max( MN, NRHS ) ).
!          For optimal performance,
!          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
!          where MN = min(M,N) and NB is the optimum block size.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, TPSD
      INTEGER            BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMLNUM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   RWORK( 1 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR, &
                         DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      INFO = 0
      MN = MIN( M, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY ) &
                THEN
         INFO = -10
      END IF
!
!     Figure out optimal block size
!
      IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
!
         TPSD = .TRUE.
         IF( LSAME( TRANS, 'N' ) ) &
            TPSD = .FALSE.
!
         IF( M.GE.N ) THEN
            NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
            IF( TPSD ) THEN
               NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, &
                    -1 ) )
            ELSE
               NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, &
                    -1 ) )
            END IF
         ELSE
            NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
            IF( TPSD ) THEN
               NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, &
                    -1 ) )
            ELSE
               NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, &
                    -1 ) )
            END IF
         END IF
!
         WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
         WORK( 1 ) = DBLE( WSIZE )
!
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELS ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
         CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RETURN
      END IF
!
!     Get machine parameters
!
      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Scale A, B if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         GO TO 50
      END IF
!
      BROW = M
      IF( TPSD ) &
         BROW = N
      BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, &
                      INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, &
                      INFO )
         IBSCL = 2
      END IF
!
      IF( M.GE.N ) THEN
!
!        compute QR factorization of A
!
         CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, &
                      INFO )
!
!        workspace at least N, optimally N*NB
!
         IF( .NOT.TPSD ) THEN
!
!           Least-Squares Problem min || A * X - B ||
!
!           B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
!
            CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, &
                         WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, &
                         INFO )
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
!
            CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, &
                        NRHS, ONE, A, LDA, B, LDB )
!
            SCLLEN = N
!
         ELSE
!
!           Overdetermined system of equations A' * X = B
!
!           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
!
            CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, &
                        NRHS, ONE, A, LDA, B, LDB )
!
!           B(N+1:M,1:NRHS) = ZERO
!
            DO 20 J = 1, NRHS
               DO 10 I = N + 1, M
                  B( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
!
!           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
!
            CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA, &
                         WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, &
                         INFO )
!
!           workspace at least NRHS, optimally NRHS*NB
!
            SCLLEN = M
!
         END IF
!
      ELSE
!
!        Compute LQ factorization of A
!
         CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, &
                      INFO )
!
!        workspace at least M, optimally M*NB.
!
         IF( .NOT.TPSD ) THEN
!
!           underdetermined system of equations A * X = B
!
!           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
!
            CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', M, &
                        NRHS, ONE, A, LDA, B, LDB )
!
!           B(M+1:N,1:NRHS) = 0
!
            DO 40 J = 1, NRHS
               DO 30 I = M + 1, N
                  B( I, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
!
!           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
!
            CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, &
                         WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, &
                         INFO )
!
!           workspace at least NRHS, optimally NRHS*NB
!
            SCLLEN = N
!
         ELSE
!
!           overdetermined system min || A' * X - B ||
!
!           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
!
            CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA, &
                         WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, &
                         INFO )
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
!
            CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', M, &
                        NRHS, ONE, A, LDA, B, LDB )
!
            SCLLEN = M
!
         END IF
!
      END IF
!
!     Undo scaling
!
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, &
                      INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, &
                      INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, &
                      INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, &
                      INFO )
      END IF
!
   50 CONTINUE
      WORK( 1 ) = DBLE( WSIZE )
!
      RETURN
!
!     End of DGELS
!
      END
      SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, &
                         WORK, LWORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELSD computes the minimum-norm solution to a real linear least
!  squares problem:
!      minimize 2-norm(| b - A*x |)
!  using the singular value decomposition (SVD) of A. A is an M-by-N
!  matrix which may be rank-deficient.
!
!  Several right hand side vectors b and solution vectors x can be
!  handled in a single call; they are stored as the columns of the
!  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!  matrix X.
!
!  The problem is solved in three steps:
!  (1) Reduce the coefficient matrix A to bidiagonal form with
!      Householder transformations, reducing the original problem
!      into a "bidiagonal least squares problem" (BLS)
!  (2) Solve the BLS using a divide and conquer approach.
!  (3) Apply back all the Householder tranformations to solve
!      the original least squares problem.
!
!  The effective rank of A is determined by treating as zero those
!  singular values which are less than RCOND times the largest singular
!  value.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of A. N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X. NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A has been destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the M-by-NRHS right hand side matrix B.
!          On exit, B is overwritten by the N-by-NRHS solution
!          matrix X.  If m >= n and RANK = n, the residual
!          sum-of-squares for the solution in the i-th column is given
!          by the sum of squares of elements n+1:m in that column.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,max(M,N)).
!
!  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The singular values of A in decreasing order.
!          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!
!  RCOND   (input) DOUBLE PRECISION
!          RCOND is used to determine the effective rank of A.
!          Singular values S(i) <= RCOND*S(1) are treated as zero.
!          If RCOND < 0, machine precision is used instead.
!
!  RANK    (output) INTEGER
!          The effective rank of A, i.e., the number of singular values
!          which are greater than RCOND*S(1).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK must be at least 1.
!          The exact minimum amount of workspace needed depends on M,
!          N and NRHS. As long as LWORK is at least
!              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
!          if M is greater than or equal to N or
!              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
!          if M is less than N, the code will execute correctly.
!          SMLSIZ is returned by ILAENV and is equal to the maximum
!          size of the subproblems at the bottom of the computation
!          tree (usually about 25), and
!             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
!          For good performance, LWORK should generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (LIWORK)
!          LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
!          where MINMN = MIN( M,N ).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  the algorithm for computing the SVD failed to converge;
!                if INFO = i, i off-diagonal elements of an intermediate
!                bidiagonal form did not converge to zero.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!       California at Berkeley, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ, &
                         LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM, &
                         MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD, &
                         DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, LOG, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      INFO = 0
      MINMN = MIN( M, N )
      MAXMN = MAX( M, N )
      MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
         INFO = -7
      END IF
!
      SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
!
!     Compute workspace.
!     (Note: Comments in the code beginning "Workspace:" describe the
!     minimal amount of workspace needed at that point in the code,
!     as well as the preferred amount for good performance.
!     NB refers to the optimal block size for the immediately
!     following subroutine, as returned by ILAENV.)
!
      MINWRK = 1
      MINMN = MAX( 1, MINMN )
      NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) / &
             LOG( TWO ) ) + 1, 0 )
!
      IF( INFO.EQ.0 ) THEN
         MAXWRK = 0
         MM = M
         IF( M.GE.N .AND. M.GE.MNTHR ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns.
!
            MM = N
            MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, &
                     -1, -1 ) )
            MAXWRK = MAX( MAXWRK, N+NRHS* &
                     ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
         END IF
         IF( M.GE.N ) THEN
!
!           Path 1 - overdetermined or exactly determined.
!
            MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* &
                     ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
            MAXWRK = MAX( MAXWRK, 3*N+NRHS* &
                     ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
            MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* &
                     ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) )
            WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
            MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
            MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
         END IF
         IF( N.GT.M ) THEN
            WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
            IF( N.GE.MNTHR ) THEN
!
!              Path 2a - underdetermined, with many more columns
!              than rows.
!
               MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
               MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* &
                        ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* &
                        ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* &
                        ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) )
               IF( NRHS.GT.1 ) THEN
                  MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
               ELSE
                  MAXWRK = MAX( MAXWRK, M*M+2*M )
               END IF
               MAXWRK = MAX( MAXWRK, M+NRHS* &
                        ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
            ELSE
!
!              Path 2 - remaining underdetermined cases.
!
               MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, &
                        -1, -1 )
               MAXWRK = MAX( MAXWRK, 3*M+NRHS* &
                        ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) )
               MAXWRK = MAX( MAXWRK, 3*M+M* &
                        ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
            END IF
            MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
         END IF
         MINWRK = MIN( MINWRK, MAXWRK )
         WORK( 1 ) = MAXWRK
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         GO TO 10
      END IF
!
!     Quick return if possible.
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
!
!     Get machine parameters.
!
      EPS = DLAMCH( 'P' )
      SFMIN = DLAMCH( 'S' )
      SMLNUM = SFMIN / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Scale A if max entry outside range [SMLNUM,BIGNUM].
!
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM.
!
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM.
!
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
         RANK = 0
         GO TO 10
      END IF
!
!     Scale B if max entry outside range [SMLNUM,BIGNUM].
!
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM.
!
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM.
!
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
!
!     If M < N make sure certain entries of B are zero.
!
      IF( M.LT.N ) &
         CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
!
!     Overdetermined case.
!
      IF( M.GE.N ) THEN
!
!        Path 1 - overdetermined or exactly determined.
!
         MM = M
         IF( M.GE.MNTHR ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns.
!
            MM = N
            ITAU = 1
            NWORK = ITAU + N
!
!           Compute A=Q*R.
!           (Workspace: need 2*N, prefer N+N*NB)
!
            CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                         LWORK-NWORK+1, INFO )
!
!           Multiply B by transpose(Q).
!           (Workspace: need N+NRHS, prefer N+NRHS*NB)
!
            CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, &
                         LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
!           Zero out below R.
!
            IF( N.GT.1 ) THEN
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
            END IF
         END IF
!
         IE = 1
         ITAUQ = IE + N
         ITAUP = ITAUQ + N
         NWORK = ITAUP + N
!
!        Bidiagonalize R in A.
!        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
!
         CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                      INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors of R.
!        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), &
                      B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB, &
                      RCOND, RANK, WORK( NWORK ), IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
!
!        Multiply B by right bidiagonalizing vectors of R.
!
         CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ), &
                      B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ &
               MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm.
!
         LDWORK = M
         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), &
             M*LDA+M+M*NRHS ) )LDWORK = LDA
         ITAU = 1
         NWORK = M + 1
!
!        Compute A=L*Q.
!        (Workspace: need 2*M, prefer M+M*NB)
!
         CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                      LWORK-NWORK+1, INFO )
         IL = NWORK
!
!        Copy L to WORK(IL), zeroing out above its diagonal.
!
         CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
         CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), &
                      LDWORK )
         IE = IL + LDWORK*M
         ITAUQ = IE + M
         ITAUP = ITAUQ + M
         NWORK = ITAUP + M
!
!        Bidiagonalize L in WORK(IL).
!        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
!
         CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), &
                      WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), &
                      LWORK-NWORK+1, INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors of L.
!        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, &
                      WORK( ITAUQ ), B, LDB, WORK( NWORK ), &
                      LWORK-NWORK+1, INFO )
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, &
                      RCOND, RANK, WORK( NWORK ), IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
!
!        Multiply B by right bidiagonalizing vectors of L.
!
         CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK, &
                      WORK( ITAUP ), B, LDB, WORK( NWORK ), &
                      LWORK-NWORK+1, INFO )
!
!        Zero out below first M rows of B.
!
         CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
         NWORK = ITAU + M
!
!        Multiply transpose(Q) by B.
!        (Workspace: need M+NRHS, prefer M+NRHS*NB)
!
         CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, &
                      LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
      ELSE
!
!        Path 2 - remaining underdetermined cases.
!
         IE = 1
         ITAUQ = IE + M
         ITAUP = ITAUQ + M
         NWORK = ITAUP + M
!
!        Bidiagonalize A.
!        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
         CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                      WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                      INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors.
!        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), &
                      B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
!        Solve the bidiagonal least squares problem.
!
         CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB, &
                      RCOND, RANK, WORK( NWORK ), IWORK, INFO )
         IF( INFO.NE.0 ) THEN
            GO TO 10
         END IF
!
!        Multiply B by right bidiagonalizing vectors of A.
!
         CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ), &
                      B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
!
      END IF
!
!     Undo scaling.
!
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, &
                      INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, &
                      INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
!
   10 CONTINUE
      WORK( 1 ) = MAXWRK
      RETURN
!
!     End of DGELSD
!
      END
      SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELSS computes the minimum norm solution to a real linear least
!  squares problem:
!
!  Minimize 2-norm(| b - A*x |).
!
!  using the singular value decomposition (SVD) of A. A is an M-by-N
!  matrix which may be rank-deficient.
!
!  Several right hand side vectors b and solution vectors x can be
!  handled in a single call; they are stored as the columns of the
!  M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
!  X.
!
!  The effective rank of A is determined by treating as zero those
!  singular values which are less than RCOND times the largest singular
!  value.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A. N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X. NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the first min(m,n) rows of A are overwritten with
!          its right singular vectors, stored rowwise.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the M-by-NRHS right hand side matrix B.
!          On exit, B is overwritten by the N-by-NRHS solution
!          matrix X.  If m >= n and RANK = n, the residual
!          sum-of-squares for the solution in the i-th column is given
!          by the sum of squares of elements n+1:m in that column.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,max(M,N)).
!
!  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The singular values of A in decreasing order.
!          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!
!  RCOND   (input) DOUBLE PRECISION
!          RCOND is used to determine the effective rank of A.
!          Singular values S(i) <= RCOND*S(1) are treated as zero.
!          If RCOND < 0, machine precision is used instead.
!
!  RANK    (output) INTEGER
!          The effective rank of A, i.e., the number of singular values
!          which are greater than RCOND*S(1).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= 1, and also:
!          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
!          For good performance, LWORK should generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  the algorithm for computing the SVD failed to converge;
!                if INFO = i, i off-diagonal elements of an intermediate
!                bidiagonal form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, &
                         ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, &
                         MAXWRK, MINMN, MINWRK, MM, MNTHR
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   VDUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, &
                         DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, &
                         DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      MINMN = MIN( M, N )
      MAXMN = MAX( M, N )
      MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
         INFO = -7
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = 0
         MM = M
         IF( M.GE.N .AND. M.GE.MNTHR ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns
!
            MM = N
            MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, &
                     -1, -1 ) )
            MAXWRK = MAX( MAXWRK, N+NRHS* &
                     ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
         END IF
         IF( M.GE.N ) THEN
!
!           Path 1 - overdetermined or exactly determined
!
!           Compute workspace needed for DBDSQR
!
            BDSPAC = MAX( 1, 5*N )
            MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* &
                     ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
            MAXWRK = MAX( MAXWRK, 3*N+NRHS* &
                     ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
            MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* &
                     ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
            MAXWRK = MAX( MAXWRK, BDSPAC )
            MAXWRK = MAX( MAXWRK, N*NRHS )
            MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC )
            MAXWRK = MAX( MINWRK, MAXWRK )
         END IF
         IF( N.GT.M ) THEN
!
!           Compute workspace needed for DBDSQR
!
            BDSPAC = MAX( 1, 5*M )
            MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
            IF( N.GE.MNTHR ) THEN
!
!              Path 2a - underdetermined, with many more columns
!              than rows
!
               MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
               MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* &
                        ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* &
                        ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* &
                        ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
               MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC )
               IF( NRHS.GT.1 ) THEN
                  MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
               ELSE
                  MAXWRK = MAX( MAXWRK, M*M+2*M )
               END IF
               MAXWRK = MAX( MAXWRK, M+NRHS* &
                        ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
            ELSE
!
!              Path 2 - underdetermined
!
               MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, &
                        -1, -1 )
               MAXWRK = MAX( MAXWRK, 3*M+NRHS* &
                        ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
               MAXWRK = MAX( MAXWRK, 3*M+M* &
                        ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC )
               MAXWRK = MAX( MAXWRK, N*NRHS )
            END IF
         END IF
         MAXWRK = MAX( MINWRK, MAXWRK )
         WORK( 1 ) = MAXWRK
      END IF
!
      MINWRK = MAX( MINWRK, 1 )
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) &
         INFO = -12
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSS', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
!
!     Get machine parameters
!
      EPS = DLAMCH( 'P' )
      SFMIN = DLAMCH( 'S' )
      SMLNUM = SFMIN / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
         RANK = 0
         GO TO 70
      END IF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
!
!     Overdetermined case
!
      IF( M.GE.N ) THEN
!
!        Path 1 - overdetermined or exactly determined
!
         MM = M
         IF( M.GE.MNTHR ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns
!
            MM = N
            ITAU = 1
            IWORK = ITAU + N
!
!           Compute A=Q*R
!           (Workspace: need 2*N, prefer N+N*NB)
!
            CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), &
                         LWORK-IWORK+1, INFO )
!
!           Multiply B by transpose(Q)
!           (Workspace: need N+NRHS, prefer N+NRHS*NB)
!
            CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, &
                         LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
!
!           Zero out below R
!
            IF( N.GT.1 ) &
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
         END IF
!
         IE = 1
         ITAUQ = IE + N
         ITAUP = ITAUQ + N
         IWORK = ITAUP + N
!
!        Bidiagonalize R in A
!        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
!
         CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                      INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors of R
!        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), &
                      B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
!
!        Generate right bidiagonalizing vectors of R in A
!        (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
         CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), &
                      WORK( IWORK ), LWORK-IWORK+1, INFO )
         IWORK = IE + N
!
!        Perform bidiagonal QR iteration
!          multiply B by transpose of left singular vectors
!          compute right singular vectors in A
!        (Workspace: need BDSPAC)
!
         CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, &
                      1, B, LDB, WORK( IWORK ), INFO )
         IF( INFO.NE.0 ) &
            GO TO 70
!
!        Multiply B by reciprocals of singular values
!
         THR = MAX( RCOND*S( 1 ), SFMIN )
         IF( RCOND.LT.ZERO ) &
            THR = MAX( EPS*S( 1 ), SFMIN )
         RANK = 0
         DO 10 I = 1, N
            IF( S( I ).GT.THR ) THEN
               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
               RANK = RANK + 1
            ELSE
               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
            END IF
   10    CONTINUE
!
!        Multiply B by right singular vectors
!        (Workspace: need N, prefer N*NRHS)
!
         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
            CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, &
                        WORK, LDB )
            CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
         ELSE IF( NRHS.GT.1 ) THEN
            CHUNK = LWORK / N
            DO 20 I = 1, NRHS, CHUNK
               BL = MIN( NRHS-I+1, CHUNK )
               CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), &
                           LDB, ZERO, WORK, N )
               CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
   20       CONTINUE
         ELSE
            CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
            CALL DCOPY( N, WORK, 1, B, 1 )
         END IF
!
      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ &
               MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm
!
         LDWORK = M
         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), &
             M*LDA+M+M*NRHS ) )LDWORK = LDA
         ITAU = 1
         IWORK = M + 1
!
!        Compute A=L*Q
!        (Workspace: need 2*M, prefer M+M*NB)
!
         CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), &
                      LWORK-IWORK+1, INFO )
         IL = IWORK
!
!        Copy L to WORK(IL), zeroing out above it
!
         CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
         CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), &
                      LDWORK )
         IE = IL + LDWORK*M
         ITAUQ = IE + M
         ITAUP = ITAUQ + M
         IWORK = ITAUP + M
!
!        Bidiagonalize L in WORK(IL)
!        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
!
         CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), &
                      WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), &
                      LWORK-IWORK+1, INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors of L
!        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, &
                      WORK( ITAUQ ), B, LDB, WORK( IWORK ), &
                      LWORK-IWORK+1, INFO )
!
!        Generate right bidiagonalizing vectors of R in WORK(IL)
!        (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
!
         CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), &
                      WORK( IWORK ), LWORK-IWORK+1, INFO )
         IWORK = IE + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of L in WORK(IL) and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need M*M+M+BDSPAC)
!
         CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), &
                      LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
         IF( INFO.NE.0 ) &
            GO TO 70
!
!        Multiply B by reciprocals of singular values
!
         THR = MAX( RCOND*S( 1 ), SFMIN )
         IF( RCOND.LT.ZERO ) &
            THR = MAX( EPS*S( 1 ), SFMIN )
         RANK = 0
         DO 30 I = 1, M
            IF( S( I ).GT.THR ) THEN
               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
               RANK = RANK + 1
            ELSE
               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
            END IF
   30    CONTINUE
         IWORK = IE
!
!        Multiply B by right singular vectors of L in WORK(IL)
!        (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
!
         IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
            CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, &
                        B, LDB, ZERO, WORK( IWORK ), LDB )
            CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
         ELSE IF( NRHS.GT.1 ) THEN
            CHUNK = ( LWORK-IWORK+1 ) / M
            DO 40 I = 1, NRHS, CHUNK
               BL = MIN( NRHS-I+1, CHUNK )
               CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, &
                           B( 1, I ), LDB, ZERO, WORK( IWORK ), N )
               CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B( 1, I ), &
                            LDB )
   40       CONTINUE
         ELSE
            CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), &
                        1, ZERO, WORK( IWORK ), 1 )
            CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
         END IF
!
!        Zero out below first M rows of B
!
         CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
         IWORK = ITAU + M
!
!        Multiply transpose(Q) by B
!        (Workspace: need M+NRHS, prefer M+NRHS*NB)
!
         CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, &
                      LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
!
      ELSE
!
!        Path 2 - remaining underdetermined cases
!
         IE = 1
         ITAUQ = IE + M
         ITAUP = ITAUQ + M
         IWORK = ITAUP + M
!
!        Bidiagonalize A
!        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
         CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                      INFO )
!
!        Multiply B by transpose of left bidiagonalizing vectors
!        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
!
         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), &
                      B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
!
!        Generate right bidiagonalizing vectors in A
!        (Workspace: need 4*M, prefer 3*M+M*NB)
!
         CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), &
                      WORK( IWORK ), LWORK-IWORK+1, INFO )
         IWORK = IE + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of A in A and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need BDSPAC)
!
         CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, &
                      1, B, LDB, WORK( IWORK ), INFO )
         IF( INFO.NE.0 ) &
            GO TO 70
!
!        Multiply B by reciprocals of singular values
!
         THR = MAX( RCOND*S( 1 ), SFMIN )
         IF( RCOND.LT.ZERO ) &
            THR = MAX( EPS*S( 1 ), SFMIN )
         RANK = 0
         DO 50 I = 1, M
            IF( S( I ).GT.THR ) THEN
               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
               RANK = RANK + 1
            ELSE
               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
            END IF
   50    CONTINUE
!
!        Multiply B by right singular vectors of A
!        (Workspace: need N, prefer N*NRHS)
!
         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
            CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, &
                        WORK, LDB )
            CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
         ELSE IF( NRHS.GT.1 ) THEN
            CHUNK = LWORK / N
            DO 60 I = 1, NRHS, CHUNK
               BL = MIN( NRHS-I+1, CHUNK )
               CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), &
                           LDB, ZERO, WORK, N )
               CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
   60       CONTINUE
         ELSE
            CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
            CALL DCOPY( N, WORK, 1, B, 1 )
         END IF
      END IF
!
!     Undo scaling
!
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, &
                      INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, &
                      INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
!
   70 CONTINUE
      WORK( 1 ) = MAXWRK
      RETURN
!
!     End of DGELSS
!
      END
      SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, &
                         WORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DGELSY.
!
!  DGELSX computes the minimum-norm solution to a real linear least
!  squares problem:
!      minimize || A * X - B ||
!  using a complete orthogonal factorization of A.  A is an M-by-N
!  matrix which may be rank-deficient.
!
!  Several right hand side vectors b and solution vectors x can be
!  handled in a single call; they are stored as the columns of the
!  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!  matrix X.
!
!  The routine first computes a QR factorization with column pivoting:
!      A * P = Q * [ R11 R12 ]
!                  [  0  R22 ]
!  with R11 defined as the largest leading submatrix whose estimated
!  condition number is less than 1/RCOND.  The order of R11, RANK,
!  is the effective rank of A.
!
!  Then, R22 is considered to be negligible, and R12 is annihilated
!  by orthogonal transformations from the right, arriving at the
!  complete orthogonal factorization:
!     A * P = Q * [ T11 0 ] * Z
!                 [  0  0 ]
!  The minimum-norm solution is then
!     X = P * Z' [ inv(T11)*Q1'*B ]
!                [        0       ]
!  where Q1 consists of the first RANK columns of Q.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of
!          columns of matrices B and X. NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A has been overwritten by details of its
!          complete orthogonal factorization.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the M-by-NRHS right hand side matrix B.
!          On exit, the N-by-NRHS solution matrix X.
!          If m >= n and RANK = n, the residual sum-of-squares for
!          the solution in the i-th column is given by the sum of
!          squares of elements N+1:M in that column.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,M,N).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          On entry, if JPVT(i) .ne. 0, the i-th column of A is an
!          initial column, otherwise it is a free column.  Before
!          the QR factorization of A, all initial columns are
!          permuted to the leading positions; only the remaining
!          free columns are moved as a result of column pivoting
!          during the factorization.
!          On exit, if JPVT(i) = k, then the i-th column of A*P
!          was the k-th column of A.
!
!  RCOND   (input) DOUBLE PRECISION
!          RCOND is used to determine the effective rank of A, which
!          is defined as the order of the largest leading triangular
!          submatrix R11 in the QR factorization with pivoting of A,
!          whose estimated condition number < 1/RCOND.
!
!  RANK    (output) INTEGER
!          The effective rank of A, i.e., the order of the submatrix
!          R11.  This is the same as the order of the submatrix T11
!          in the complete orthogonal factorization of A.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                      (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, &
                         NTDONE = ONE )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, &
                         SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R, &
                         DTRSM, DTZRQF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      MN = MIN( M, N )
      ISMIN = MN + 1
      ISMAX = 2*MN + 1
!
!     Test the input arguments.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -7
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
!
!     Get machine parameters
!
      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Scale A, B if max elements outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         GO TO 100
      END IF
!
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
!
!     Compute QR factorization with column pivoting of A:
!        A * P = Q * R
!
      CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
!
!     workspace 3*N. Details of Householder rotations stored
!     in WORK(1:MN).
!
!     Determine RANK using incremental condition estimation
!
      WORK( ISMIN ) = ONE
      WORK( ISMAX ) = ONE
      SMAX = ABS( A( 1, 1 ) )
      SMIN = SMAX
      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
         RANK = 0
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         GO TO 100
      ELSE
         RANK = 1
      END IF
!
   10 CONTINUE
      IF( RANK.LT.MN ) THEN
         I = RANK + 1
         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), &
                      A( I, I ), SMINPR, S1, C1 )
         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), &
                      A( I, I ), SMAXPR, S2, C2 )
!
         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
            DO 20 I = 1, RANK
               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
   20       CONTINUE
            WORK( ISMIN+RANK ) = C1
            WORK( ISMAX+RANK ) = C2
            SMIN = SMINPR
            SMAX = SMAXPR
            RANK = RANK + 1
            GO TO 10
         END IF
      END IF
!
!     Logically partition R = [ R11 R12 ]
!                             [  0  R22 ]
!     where R11 = R(1:RANK,1:RANK)
!
!     [R11,R12] = [ T11, 0 ] * Y
!
      IF( RANK.LT.N ) &
         CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
!
!     Details of Householder rotations stored in WORK(MN+1:2*MN)
!
!     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
!
      CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), &
                   B, LDB, WORK( 2*MN+1 ), INFO )
!
!     workspace NRHS
!
!     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
!
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, &
                  NRHS, ONE, A, LDA, B, LDB )
!
      DO 40 I = RANK + 1, N
         DO 30 J = 1, NRHS
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
!
!     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
!
      IF( RANK.LT.N ) THEN
         DO 50 I = 1, RANK
            CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA, &
                         WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB, &
                         WORK( 2*MN+1 ) )
   50    CONTINUE
      END IF
!
!     workspace NRHS
!
!     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
!
      DO 90 J = 1, NRHS
         DO 60 I = 1, N
            WORK( 2*MN+I ) = NTDONE
   60    CONTINUE
         DO 80 I = 1, N
            IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
               IF( JPVT( I ).NE.I ) THEN
                  K = I
                  T1 = B( K, J )
                  T2 = B( JPVT( K ), J )
   70             CONTINUE
                  B( JPVT( K ), J ) = T1
                  WORK( 2*MN+K ) = DONE
                  T1 = T2
                  K = JPVT( K )
                  T2 = B( JPVT( K ), J )
                  IF( JPVT( K ).NE.I ) &
                     GO TO 70
                  B( I, J ) = T1
                  WORK( 2*MN+K ) = DONE
               END IF
            END IF
   80    CONTINUE
   90 CONTINUE
!
!     Undo scaling
!
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, &
                      INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, &
                      INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
!
  100 CONTINUE
!
      RETURN
!
!     End of DGELSX
!
      END
      SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGELSY computes the minimum-norm solution to a real linear least
!  squares problem:
!      minimize || A * X - B ||
!  using a complete orthogonal factorization of A.  A is an M-by-N
!  matrix which may be rank-deficient.
!
!  Several right hand side vectors b and solution vectors x can be
!  handled in a single call; they are stored as the columns of the
!  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!  matrix X.
!
!  The routine first computes a QR factorization with column pivoting:
!      A * P = Q * [ R11 R12 ]
!                  [  0  R22 ]
!  with R11 defined as the largest leading submatrix whose estimated
!  condition number is less than 1/RCOND.  The order of R11, RANK,
!  is the effective rank of A.
!
!  Then, R22 is considered to be negligible, and R12 is annihilated
!  by orthogonal transformations from the right, arriving at the
!  complete orthogonal factorization:
!     A * P = Q * [ T11 0 ] * Z
!                 [  0  0 ]
!  The minimum-norm solution is then
!     X = P * Z' [ inv(T11)*Q1'*B ]
!                [        0       ]
!  where Q1 consists of the first RANK columns of Q.
!
!  This routine is basically identical to the original xGELSX except
!  three differences:
!    o The call to the subroutine xGEQPF has been substituted by the
!      the call to the subroutine xGEQP3. This subroutine is a Blas-3
!      version of the QR factorization with column pivoting.
!    o Matrix B (the right hand side) is updated with Blas-3.
!    o The permutation of matrix B (the right hand side) is faster and
!      more simple.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of
!          columns of matrices B and X. NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A has been overwritten by details of its
!          complete orthogonal factorization.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the M-by-NRHS right hand side matrix B.
!          On exit, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,M,N).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!          to the front of AP, otherwise column i is a free column.
!          On exit, if JPVT(i) = k, then the i-th column of AP
!          was the k-th column of A.
!
!  RCOND   (input) DOUBLE PRECISION
!          RCOND is used to determine the effective rank of A, which
!          is defined as the order of the largest leading triangular
!          submatrix R11 in the QR factorization with pivoting of A,
!          whose estimated condition number < 1/RCOND.
!
!  RANK    (output) INTEGER
!          The effective rank of A, i.e., the order of the submatrix
!          R11.  This is the same as the order of the submatrix T11
!          in the complete orthogonal factorization of A.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          The unblocked strategy requires that:
!             LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
!          where MN = min( M, N ).
!          The block algorithm requires that:
!             LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
!          where NB is an upper bound on the blocksize returned
!          by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
!          and DORMRZ.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: If INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
!    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN, &
                         NB, NB1, NB2, NB3, NB4
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX, &
                         SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           ILAENV, DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET, &
                         DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      MN = MIN( M, N )
      ISMIN = MN + 1
      ISMAX = 2*MN + 1
!
!     Test the input arguments.
!
      INFO = 0
      NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
      NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
      NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
      NB = MAX( NB1, NB2, NB3, NB4 )
      LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS )
      WORK( 1 ) = DBLE( LWKOPT )
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
         INFO = -7
      ELSE IF( LWORK.LT.MAX( 1, MN+3*N+1, 2*MN+NRHS ) .AND. .NOT. &
               LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGELSY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
         RANK = 0
         RETURN
      END IF
!
!     Get machine parameters
!
      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
      IASCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
         IASCL = 1
      ELSE IF( ANRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
         IASCL = 2
      ELSE IF( ANRM.EQ.ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         RANK = 0
         GO TO 70
      END IF
!
      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
      IBSCL = 0
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 1
      ELSE IF( BNRM.GT.BIGNUM ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
         IBSCL = 2
      END IF
!
!     Compute QR factorization with column pivoting of A:
!        A * P = Q * R
!
      CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), &
                   LWORK-MN, INFO )
      WSIZE = MN + WORK( MN+1 )
!
!     workspace: MN+2*N+NB*(N+1).
!     Details of Householder rotations stored in WORK(1:MN).
!
!     Determine RANK using incremental condition estimation
!
      WORK( ISMIN ) = ONE
      WORK( ISMAX ) = ONE
      SMAX = ABS( A( 1, 1 ) )
      SMIN = SMAX
      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
         RANK = 0
         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
         GO TO 70
      ELSE
         RANK = 1
      END IF
!
   10 CONTINUE
      IF( RANK.LT.MN ) THEN
         I = RANK + 1
         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ), &
                      A( I, I ), SMINPR, S1, C1 )
         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ), &
                      A( I, I ), SMAXPR, S2, C2 )
!
         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
            DO 20 I = 1, RANK
               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
   20       CONTINUE
            WORK( ISMIN+RANK ) = C1
            WORK( ISMAX+RANK ) = C2
            SMIN = SMINPR
            SMAX = SMAXPR
            RANK = RANK + 1
            GO TO 10
         END IF
      END IF
!
!     workspace: 3*MN.
!
!     Logically partition R = [ R11 R12 ]
!                             [  0  R22 ]
!     where R11 = R(1:RANK,1:RANK)
!
!     [R11,R12] = [ T11, 0 ] * Y
!
      IF( RANK.LT.N ) &
         CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ), &
                      LWORK-2*MN, INFO )
!
!     workspace: 2*MN.
!     Details of Householder rotations stored in WORK(MN+1:2*MN)
!
!     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
!
      CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ), &
                   B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
      WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
!
!     workspace: 2*MN+NB*NRHS.
!
!     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
!
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, &
                  NRHS, ONE, A, LDA, B, LDB )
!
      DO 40 J = 1, NRHS
         DO 30 I = RANK + 1, N
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
!
!     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
!
      IF( RANK.LT.N ) THEN
         CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, &
                      LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ), &
                      LWORK-2*MN, INFO )
      END IF
!
!     workspace: 2*MN+NRHS.
!
!     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
!
      DO 60 J = 1, NRHS
         DO 50 I = 1, N
            WORK( JPVT( I ) ) = B( I, J )
   50    CONTINUE
         CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
   60 CONTINUE
!
!     workspace: N.
!
!     Undo scaling
!
      IF( IASCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, &
                      INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, &
                      INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
      END IF
!
   70 CONTINUE
      WORK( 1 ) = DBLE( LWKOPT )
!
      RETURN
!
!     End of DGELSY
!
      END
      SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEQL2 computes a QL factorization of a real m by n matrix A:
!  A = Q * L.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix A.
!          On exit, if m >= n, the lower triangle of the subarray
!          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
!          if m <= n, the elements on and below the (n-m)-th
!          superdiagonal contain the m by n lower trapezoidal matrix L;
!          the remaining elements, with the array TAU, represent the
!          orthogonal matrix Q as a product of elementary reflectors
!          (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQL2', -INFO )
         RETURN
      END IF
!
      K = MIN( M, N )
!
      DO 10 I = K, 1, -1
!
!        Generate elementary reflector H(i) to annihilate
!        A(1:m-k+i-1,n-k+i)
!
         CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1, &
                      TAU( I ) )
!
!        Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
!
         AII = A( M-K+I, N-K+I )
         A( M-K+I, N-K+I ) = ONE
         CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ), &
                     A, LDA, WORK )
         A( M-K+I, N-K+I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DGEQL2
!
      END
      SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEQLF computes a QL factorization of a real M-by-N matrix A:
!  A = Q * L.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit,
!          if m >= n, the lower triangle of the subarray
!          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
!          if m <= n, the elements on and below the (n-m)-th
!          superdiagonal contain the M-by-N lower trapezoidal matrix L;
!          the remaining elements, with the array TAU, represent the
!          orthogonal matrix Q as a product of elementary reflectors
!          (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,N).
!          For optimum performance LWORK >= N*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(k) . . . H(2) H(1), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
!  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, &
                         MU, NB, NBMIN, NU, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQL2, DLARFB, DLARFT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQLF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 1
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1, &
                       -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code initially.
!        The last kk columns are handled by the block method.
!
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
!
         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
            IB = MIN( K-I+1, NB )
!
!           Compute the QL factorization of the current block
!           A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
!
            CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ), &
                         WORK, IINFO )
            IF( N-K+I.GT.1 ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i+ib-1) . . . H(i+1) H(i)
!
               CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, &
                            A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
!
               CALL DLARFB( 'Left', 'Transpose', 'Backward', &
                            'Columnwise', M-K+I+IB-1, N-K+I-1, IB, &
                            A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, &
                            WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
         MU = M - K + I + NB - 1
         NU = N - K + I + NB - 1
      ELSE
         MU = M
         NU = N
      END IF
!
!     Use unblocked code to factor the last or only block
!
      IF( MU.GT.0 .AND. NU.GT.0 ) &
         CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGEQLF
!
      END
      SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEQP3 computes a QR factorization with column pivoting of a
!  matrix A:  A*P = Q*R  using Level 3 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the upper triangle of the array contains the
!          min(M,N)-by-N upper trapezoidal matrix R; the elements below
!          the diagonal, together with the array TAU, represent the
!          orthogonal matrix Q as a product of min(M,N) elementary
!          reflectors.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
!          to the front of A*P (a leading column); if JPVT(J)=0,
!          the J-th column of A is a free column.
!          On exit, if JPVT(J)=K, then the J-th column of A*P was the
!          the K-th column of A.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= 3*N+1.
!          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
!          is the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real/complex scalar, and v is a real/complex vector
!  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
!  A(i+1:m,i), and tau in TAU(i).
!
!  Based on contributions by
!    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
!    X. Sun, Computer Science Dept., Duke University, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            INB, INBMIN, IXOVER
      PARAMETER          ( INB = 1, INBMIN = 2, IXOVER = 3 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB, &
                         NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DNRM2
      EXTERNAL           ILAENV, DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      IWS = 3*N + 1
      MINMN = MIN( M, N )
!
!     Test input arguments
!     ====================
!
      INFO = 0
      NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 )
      LWKOPT = 2*N + ( N+1 )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQP3', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( MINMN.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Move initial columns up front.
!
      NFXD = 1
      DO 10 J = 1, N
         IF( JPVT( J ).NE.0 ) THEN
            IF( J.NE.NFXD ) THEN
               CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
               JPVT( J ) = JPVT( NFXD )
               JPVT( NFXD ) = J
            ELSE
               JPVT( J ) = J
            END IF
            NFXD = NFXD + 1
         ELSE
            JPVT( J ) = J
         END IF
   10 CONTINUE
      NFXD = NFXD - 1
!
!     Factorize fixed columns
!     =======================
!
!     Compute the QR factorization of fixed columns and update
!     remaining columns.
!
      IF( NFXD.GT.0 ) THEN
         NA = MIN( M, NFXD )
!CC      CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
         CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
         IWS = MAX( IWS, INT( WORK( 1 ) ) )
         IF( NA.LT.N ) THEN
!CC         CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
!CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
            CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU, &
                         A( 1, NA+1 ), LDA, WORK, LWORK, INFO )
            IWS = MAX( IWS, INT( WORK( 1 ) ) )
         END IF
      END IF
!
!     Factorize free columns
!     ======================
!
      IF( NFXD.LT.MINMN ) THEN
!
         SM = M - NFXD
         SN = N - NFXD
         SMINMN = MINMN - NFXD
!
!        Determine the block size.
!
         NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 )
         NBMIN = 2
         NX = 0
!
         IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
!
!           Determine when to cross over from blocked to unblocked code.
!
            NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1, &
                 -1 ) )
!
!
            IF( NX.LT.SMINMN ) THEN
!
!              Determine if workspace is large enough for blocked code.
!
               MINWS = 2*SN + ( SN+1 )*NB
               IWS = MAX( IWS, MINWS )
               IF( LWORK.LT.MINWS ) THEN
!
!                 Not enough workspace to use optimal NB: Reduce NB and
!                 determine the minimum value of NB.
!
                  NB = ( LWORK-2*SN ) / ( SN+1 )
                  NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN, &
                          -1, -1 ) )
!
!
               END IF
            END IF
         END IF
!
!        Initialize partial column norms. The first N elements of work
!        store the exact column norms.
!
         DO 20 J = NFXD + 1, N
            WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 )
            WORK( N+J ) = WORK( J )
   20    CONTINUE
!
         IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND. &
             ( NX.LT.SMINMN ) ) THEN
!
!           Use blocked code initially.
!
            J = NFXD + 1
!
!           Compute factorization: while loop.
!
!
            TOPBMN = MINMN - NX
   30       CONTINUE
            IF( J.LE.TOPBMN ) THEN
               JB = MIN( NB, TOPBMN-J+1 )
!
!              Factorize JB columns among columns J:N.
!
               CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA, &
                            JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ), &
                            WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 )
!
               J = J + FJB
               GO TO 30
            END IF
         ELSE
            J = NFXD + 1
         END IF
!
!        Use unblocked code to factor the last or only block.
!
!
         IF( J.LE.MINMN ) &
            CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ), &
                         TAU( J ), WORK( J ), WORK( N+J ), &
                         WORK( 2*N+1 ) )
!
      END IF
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGEQP3
!
      END
      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
!
!  -- LAPACK test routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DGEQP3.
!
!  DGEQPF computes a QR factorization with column pivoting of a
!  real M-by-N matrix A: A*P = Q*R.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A. N >= 0
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the upper triangle of the array contains the
!          min(M,N)-by-N upper triangular matrix R; the elements
!          below the diagonal, together with the array TAU,
!          represent the orthogonal matrix Q as a product of
!          min(m,n) elementary reflectors.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!          to the front of A*P (a leading column); if JPVT(i) = 0,
!          the i-th column of A is a free column.
!          On exit, if JPVT(i) = k, then the i-th column of A*P
!          was the k-th column of A.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(n)
!
!  Each H(i) has the form
!
!     H = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
!
!  The matrix P is represented in jpvt as follows: If
!     jpvt(j) = i
!  then the jth column of P is the ith canonical unit vector.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ITEMP, J, MA, MN, PVT
      DOUBLE PRECISION   AII, TEMP, TEMP2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DNRM2
      EXTERNAL           IDAMAX, DNRM2
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQPF', -INFO )
         RETURN
      END IF
!
      MN = MIN( M, N )
!
!     Move initial columns up front
!
      ITEMP = 1
      DO 10 I = 1, N
         IF( JPVT( I ).NE.0 ) THEN
            IF( I.NE.ITEMP ) THEN
               CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
               JPVT( I ) = JPVT( ITEMP )
               JPVT( ITEMP ) = I
            ELSE
               JPVT( I ) = I
            END IF
            ITEMP = ITEMP + 1
         ELSE
            JPVT( I ) = I
         END IF
   10 CONTINUE
      ITEMP = ITEMP - 1
!
!     Compute the QR factorization and update remaining columns
!
      IF( ITEMP.GT.0 ) THEN
         MA = MIN( ITEMP, M )
         CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
         IF( MA.LT.N ) THEN
            CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU, &
                         A( 1, MA+1 ), LDA, WORK, INFO )
         END IF
      END IF
!
      IF( ITEMP.LT.MN ) THEN
!
!        Initialize partial column norms. The first n elements of
!        work store the exact column norms.
!
         DO 20 I = ITEMP + 1, N
            WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
            WORK( N+I ) = WORK( I )
   20    CONTINUE
!
!        Compute factorization
!
         DO 40 I = ITEMP + 1, MN
!
!           Determine ith pivot column and swap if necessary
!
            PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )
!
            IF( PVT.NE.I ) THEN
               CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
               ITEMP = JPVT( PVT )
               JPVT( PVT ) = JPVT( I )
               JPVT( I ) = ITEMP
               WORK( PVT ) = WORK( I )
               WORK( N+PVT ) = WORK( N+I )
            END IF
!
!           Generate elementary reflector H(i)
!
            IF( I.LT.M ) THEN
               CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
            ELSE
               CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
            END IF
!
            IF( I.LT.N ) THEN
!
!              Apply H(i) to A(i:m,i+1:n) from the left
!
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), &
                           A( I, I+1 ), LDA, WORK( 2*N+1 ) )
               A( I, I ) = AII
            END IF
!
!           Update partial column norms
!
            DO 30 J = I + 1, N
               IF( WORK( J ).NE.ZERO ) THEN
                  TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2
                  TEMP = MAX( TEMP, ZERO )
                  TEMP2 = ONE + 0.05D0*TEMP* &
                          ( WORK( J ) / WORK( N+J ) )**2
                  IF( TEMP2.EQ.ONE ) THEN
                     IF( M-I.GT.0 ) THEN
                        WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )
                        WORK( N+J ) = WORK( J )
                     ELSE
                        WORK( J ) = ZERO
                        WORK( N+J ) = ZERO
                     END IF
                  ELSE
                     WORK( J ) = WORK( J )*SQRT( TEMP )
                  END IF
               END IF
   30       CONTINUE
!
   40    CONTINUE
      END IF
      RETURN
!
!     End of DGEQPF
!
      END
      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEQR2 computes a QR factorization of a real m by n matrix A:
!  A = Q * R.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix A.
!          On exit, the elements on and above the diagonal of the array
!          contain the min(m,n) by n upper trapezoidal matrix R (R is
!          upper triangular if m >= n); the elements below the diagonal,
!          with the array TAU, represent the orthogonal matrix Q as a
!          product of elementary reflectors (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!  and tau in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQR2', -INFO )
         RETURN
      END IF
!
      K = MIN( M, N )
!
      DO 10 I = 1, K
!
!        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
!
         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, &
                      TAU( I ) )
         IF( I.LT.N ) THEN
!
!           Apply H(i) to A(i:m,i+1:n) from the left
!
            AII = A( I, I )
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), &
                        A( I, I+1 ), LDA, WORK )
            A( I, I ) = AII
         END IF
   10 CONTINUE
      RETURN
!
!     End of DGEQR2
!
      END
      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEQRF computes a QR factorization of a real M-by-N matrix A:
!  A = Q * R.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the elements on and above the diagonal of the array
!          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
!          upper triangular if m >= n); the elements below the diagonal,
!          with the array TAU, represent the orthogonal matrix Q as a
!          product of min(m,n) elementary reflectors (see Further
!          Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,N).
!          For optimum performance LWORK >= N*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
!  and tau in TAU(i).
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, &
                         NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQR2, DLARFB, DLARFT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQRF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, &
                       -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code initially
!
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
!
!           Compute the QR factorization of the current block
!           A(i:m,i:i+ib-1)
!
            CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, &
                         IINFO )
            IF( I+IB.LE.N ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, &
                            A( I, I ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H' to A(i:m,i+ib:n) from the left
!
               CALL DLARFB( 'Left', 'Transpose', 'Forward', &
                            'Columnwise', M-I+1, N-I-IB+1, IB, &
                            A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), &
                            LDA, WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
!
!     Use unblocked code to factor the last or only block.
!
      IF( I.LE.K ) &
         CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, &
                      IINFO )
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGEQRF
!
      END
      SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, &
                         X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGERFS improves the computed solution to a system of linear
!  equations and provides error bounds and backward error estimates for
!  the solution.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The original N-by-N matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by DGETRF.
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DGETRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      CHARACTER          TRANST
      INTEGER            COUNT, I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGETRS, DLACON, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
          LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGERFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A, A**T, or A**H, depending on TRANS.
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, &
                     WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(op(A))*abs(X) + abs(B).
!
         IF( NOTRAN ) THEN
            DO 50 K = 1, N
               XK = ABS( X( K, J ) )
               DO 40 I = 1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   40          CONTINUE
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               DO 60 I = 1, N
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, &
                         INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)**T).
!
               CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ), &
                            N, INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, &
                            INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DGERFS
!
      END
      SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGERQ2 computes an RQ factorization of a real m by n matrix A:
!  A = R * Q.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix A.
!          On exit, if m <= n, the upper triangle of the subarray
!          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
!          if m >= n, the elements on and above the (m-n)-th subdiagonal
!          contain the m by n upper trapezoidal matrix R; the remaining
!          elements, with the array TAU, represent the orthogonal matrix
!          Q as a product of elementary reflectors (see Further
!          Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGERQ2', -INFO )
         RETURN
      END IF
!
      K = MIN( M, N )
!
      DO 10 I = K, 1, -1
!
!        Generate elementary reflector H(i) to annihilate
!        A(m-k+i,1:n-k+i-1)
!
         CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, &
                      TAU( I ) )
!
!        Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
!
         AII = A( M-K+I, N-K+I )
         A( M-K+I, N-K+I ) = ONE
         CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, &
                     TAU( I ), A, LDA, WORK )
         A( M-K+I, N-K+I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DGERQ2
!
      END
      SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGERQF computes an RQ factorization of a real M-by-N matrix A:
!  A = R * Q.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit,
!          if m <= n, the upper triangle of the subarray
!          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
!          if m >= n, the elements on and above the (m-n)-th subdiagonal
!          contain the M-by-N upper trapezoidal matrix R;
!          the remaining elements, with the array TAU, represent the
!          orthogonal matrix Q as a product of min(m,n) elementary
!          reflectors (see Further Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,M).
!          For optimum performance LWORK >= M*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT, &
                         MU, NB, NBMIN, NU, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGERQ2, DLARFB, DLARFT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      LWKOPT = M*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGERQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 1
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, &
                       -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code initially.
!        The last kk rows are handled by the block method.
!
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
!
         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
            IB = MIN( K-I+1, NB )
!
!           Compute the RQ factorization of the current block
!           A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
!
            CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ), &
                         WORK, IINFO )
            IF( M-K+I.GT.1 ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i+ib-1) . . . H(i+1) H(i)
!
               CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, &
                            A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
!
               CALL DLARFB( 'Right', 'No transpose', 'Backward', &
                            'Rowwise', M-K+I-1, N-K+I+IB-1, IB, &
                            A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA, &
                            WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
         MU = M - K + I + NB - 1
         NU = N - K + I + NB - 1
      ELSE
         MU = M
         NU = N
      END IF
!
!     Use unblocked code to factor the last or only block
!
      IF( MU.GT.0 .AND. NU.GT.0 ) &
         CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGERQF
!
      END
      SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            LDA, N
      DOUBLE PRECISION   SCALE
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   A( LDA, * ), RHS( * )
!     ..
!
!  Purpose
!  =======
!
!  DGESC2 solves a system of linear equations
!
!            A * X = scale* RHS
!
!  with a general N-by-N matrix A using the LU factorization with
!  complete pivoting computed by DGETC2.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the  LU part of the factorization of the n-by-n
!          matrix A computed by DGETC2:  A = P * L * U * Q
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1, N).
!
!  RHS     (input/output) DOUBLE PRECISION array, dimension (N).
!          On entry, the right hand side vector b.
!          On exit, the solution vector X.
!
!  IPIV    (iput) INTEGER array, dimension (N).
!          The pivot indices; for 1 <= i <= N, row i of the
!          matrix has been interchanged with row IPIV(i).
!
!  JPIV    (iput) INTEGER array, dimension (N).
!          The pivot indices; for 1 <= j <= N, column j of the
!          matrix has been interchanged with column JPIV(j).
!
!  SCALE    (output) DOUBLE PRECISION
!           On exit, SCALE contains the scale factor. SCALE is chosen
!           0 <= SCALE <= 1 to prevent owerflow in the solution.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   BIGNUM, EPS, SMLNUM, TEMP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASWP, DSCAL
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           IDAMAX, DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!      Set constant to control owerflow
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Apply permutations IPIV to RHS
!
      CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
!
!     Solve for L part
!
      DO 20 I = 1, N - 1
         DO 10 J = I + 1, N
            RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
   10    CONTINUE
   20 CONTINUE
!
!     Solve for U part
!
      SCALE = ONE
!
!     Check for scaling
!
      I = IDAMAX( N, RHS, 1 )
      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
         TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
         CALL DSCAL( N, TEMP, RHS( 1 ), 1 )
         SCALE = SCALE*TEMP
      END IF
!
      DO 40 I = N, 1, -1
         TEMP = ONE / A( I, I )
         RHS( I ) = RHS( I )*TEMP
         DO 30 J = I + 1, N
            RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
   30    CONTINUE
   40 CONTINUE
!
!     Apply permutations JPIV to the solution (RHS)
!
      CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
      RETURN
!
!     End of DGESC2
!
      END
      SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, &
                         LWORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ
      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ), &
                         VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGESDD computes the singular value decomposition (SVD) of a real
!  M-by-N matrix A, optionally computing the left and right singular
!  vectors.  If singular vectors are desired, it uses a
!  divide-and-conquer algorithm.
!
!  The SVD is written
!
!       A = U * SIGMA * transpose(V)
!
!  where SIGMA is an M-by-N matrix which is zero except for its
!  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
!  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
!  are the singular values of A; they are real and non-negative, and
!  are returned in descending order.  The first min(m,n) columns of
!  U and V are the left and right singular vectors of A.
!
!  Note that the routine returns VT = V**T, not V.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          Specifies options for computing all or part of the matrix U:
!          = 'A':  all M columns of U and all N rows of V**T are
!                  returned in the arrays U and VT;
!          = 'S':  the first min(M,N) columns of U and the first
!                  min(M,N) rows of V**T are returned in the arrays U
!                  and VT;
!          = 'O':  If M >= N, the first N columns of U are overwritten
!                  on the array A and all rows of V**T are returned in
!                  the array VT;
!                  otherwise, all columns of U are returned in the
!                  array U and the first M rows of V**T are overwritten
!                  in the array VT;
!          = 'N':  no columns of U or rows of V**T are computed.
!
!  M       (input) INTEGER
!          The number of rows of the input matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the input matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit,
!          if JOBZ = 'O',  A is overwritten with the first N columns
!                          of U (the left singular vectors, stored
!                          columnwise) if M >= N;
!                          A is overwritten with the first M rows
!                          of V**T (the right singular vectors, stored
!                          rowwise) otherwise.
!          if JOBZ .ne. 'O', the contents of A are destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The singular values of A, sorted so that S(i) >= S(i+1).
!
!  U       (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
!          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
!          UCOL = min(M,N) if JOBZ = 'S'.
!          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
!          orthogonal matrix U;
!          if JOBZ = 'S', U contains the first min(M,N) columns of U
!          (the left singular vectors, stored columnwise);
!          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U.  LDU >= 1; if
!          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
!
!  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
!          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
!          N-by-N orthogonal matrix V**T;
!          if JOBZ = 'S', VT contains the first min(M,N) rows of
!          V**T (the right singular vectors, stored rowwise);
!          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
!
!  LDVT    (input) INTEGER
!          The leading dimension of the array VT.  LDVT >= 1; if
!          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
!          if JOBZ = 'S', LDVT >= min(M,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= 1.
!          If JOBZ = 'N',
!            LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
!          If JOBZ = 'O',
!            LWORK >= 3*min(M,N)*min(M,N) +
!                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
!          If JOBZ = 'S' or 'A'
!            LWORK >= 3*min(M,N)*min(M,N) +
!                     max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
!          For good performance, LWORK should generally be larger.
!          If LWORK < 0 but other input arguments are legal, WORK(1)
!          returns the optimal LWORK.
!
!  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  DBDSDC did not converge, updating process failed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
      INTEGER            BDSPAC, BLK, CHUNK, I, IE, IERR, IL, &
                         IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT, &
                         LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK, &
                         MNTHR, NWORK, WRKBL
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
!     ..
!     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, &
                         DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, ILAENV, LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      MINMN = MIN( M, N )
      MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
      WNTQA = LSAME( JOBZ, 'A' )
      WNTQS = LSAME( JOBZ, 'S' )
      WNTQAS = WNTQA .OR. WNTQS
      WNTQO = LSAME( JOBZ, 'O' )
      WNTQN = LSAME( JOBZ, 'N' )
      MINWRK = 1
      MAXWRK = 1
      LQUERY = ( LWORK.EQ.-1 )
!
      IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR. &
               ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
         INFO = -8
      ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR. &
               ( WNTQS .AND. LDVT.LT.MINMN ) .OR. &
               ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
         INFO = -10
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF( INFO.EQ.0 .AND. M.GT.0 .AND. N.GT.0 ) THEN
         IF( M.GE.N ) THEN
!
!           Compute space needed for DBDSDC
!
            IF( WNTQN ) THEN
               BDSPAC = 7*N
            ELSE
               BDSPAC = 3*N*N + 4*N
            END IF
            IF( M.GE.MNTHR ) THEN
               IF( WNTQN ) THEN
!
!                 Path 1 (M much larger than N, JOBZ='N')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, &
                          -1 )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+N )
                  MINWRK = BDSPAC + N
               ELSE IF( WNTQO ) THEN
!
!                 Path 2 (M much larger than N, JOBZ='O')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + 2*N*N
                  MINWRK = BDSPAC + 2*N*N + 3*N
               ELSE IF( WNTQS ) THEN
!
!                 Path 3 (M much larger than N, JOBZ='S')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + N*N
                  MINWRK = BDSPAC + N*N + 3*N
               ELSE IF( WNTQA ) THEN
!
!                 Path 4 (M much larger than N, JOBZ='A')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, &
                          M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + N*N
                  MINWRK = BDSPAC + N*N + 3*N
               END IF
            ELSE
!
!              Path 5 (M at least N, but not much larger)
!
               WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, &
                       -1 )
               IF( WNTQN ) THEN
                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               ELSE IF( WNTQO ) THEN
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*N )
                  MAXWRK = WRKBL + M*N
                  MINWRK = 3*N + MAX( M, N*N+BDSPAC )
               ELSE IF( WNTQS ) THEN
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               ELSE IF( WNTQA ) THEN
                  WRKBL = MAX( WRKBL, 3*N+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
                  MINWRK = 3*N + MAX( M, BDSPAC )
               END IF
            END IF
         ELSE
!
!           Compute space needed for DBDSDC
!
            IF( WNTQN ) THEN
               BDSPAC = 7*M
            ELSE
               BDSPAC = 3*M*M + 4*M
            END IF
            IF( N.GE.MNTHR ) THEN
               IF( WNTQN ) THEN
!
!                 Path 1t (N much larger than M, JOBZ='N')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, &
                          -1 )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+M )
                  MINWRK = BDSPAC + M
               ELSE IF( WNTQO ) THEN
!
!                 Path 2t (N much larger than M, JOBZ='O')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + 2*M*M
                  MINWRK = BDSPAC + 2*M*M + 3*M
               ELSE IF( WNTQS ) THEN
!
!                 Path 3t (N much larger than M, JOBZ='S')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*M
                  MINWRK = BDSPAC + M*M + 3*M
               ELSE IF( WNTQA ) THEN
!
!                 Path 4t (N much larger than M, JOBZ='A')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*M
                  MINWRK = BDSPAC + M*M + 3*M
               END IF
            ELSE
!
!              Path 5t (N greater than M, but not much larger)
!
               WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1, &
                       -1 )
               IF( WNTQN ) THEN
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               ELSE IF( WNTQO ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC+3*M )
                  MAXWRK = WRKBL + M*N
                  MINWRK = 3*M + MAX( N, M*M+BDSPAC )
               ELSE IF( WNTQS ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               ELSE IF( WNTQA ) THEN
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
                  MAXWRK = MAX( WRKBL, BDSPAC+3*M )
                  MINWRK = 3*M + MAX( N, BDSPAC )
               END IF
            END IF
         END IF
         WORK( 1 ) = MAXWRK
      END IF
!
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESDD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         IF( LWORK.GE.1 ) &
            WORK( 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
      END IF
!
      IF( M.GE.N ) THEN
!
!        A has at least as many rows as columns. If A has sufficiently
!        more rows than columns, first reduce using the QR
!        decomposition (if sufficient workspace available)
!
         IF( M.GE.MNTHR ) THEN
!
            IF( WNTQN ) THEN
!
!              Path 1 (M much larger than N, JOBZ='N')
!              No singular vectors to be computed
!
               ITAU = 1
               NWORK = ITAU + N
!
!              Compute A=Q*R
!              (Workspace: need 2*N, prefer N+N*NB)
!
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Zero out below R
!
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
               IE = 1
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               NWORK = ITAUP + N
!
!              Bidiagonalize R in A
!              (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                            IERR )
               NWORK = IE + N
!
!              Perform bidiagonal SVD, computing singular values only
!              (Workspace: need N+BDSPAC)
!
               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, &
                            DUM, IDUM, WORK( NWORK ), IWORK, INFO )
!
            ELSE IF( WNTQO ) THEN
!
!              Path 2 (M much larger than N, JOBZ = 'O')
!              N left singular vectors to be overwritten on A and
!              N right singular vectors to be computed in VT
!
               IR = 1
!
!              WORK(IR) is LDWRKR by N
!
               IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
                  LDWRKR = LDA
               ELSE
                  LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
               END IF
               ITAU = IR + LDWRKR*N
               NWORK = ITAU + N
!
!              Compute A=Q*R
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Copy R to WORK(IR), zeroing out below it
!
               CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), &
                            LDWRKR )
!
!              Generate Q in A
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
               IE = ITAU
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               NWORK = ITAUP + N
!
!              Bidiagonalize R in VT, copying result to WORK(IR)
!              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
               CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), &
                            WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              WORK(IU) is N by N
!
               IU = NWORK
               NWORK = IU + N*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              (Workspace: need N+N*N+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, &
                            VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite WORK(IU) by left singular vectors of R
!              and VT by right singular vectors of R
!              (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, &
                            WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IU), storing result in WORK(IR) and copying to A
!              (Workspace: need 2*N*N, prefer N*N+M*N)
!
               DO 10 I = 1, M, LDWRKR
                  CHUNK = MIN( M-I+1, LDWRKR )
                  CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), &
                              LDA, WORK( IU ), N, ZERO, WORK( IR ), &
                              LDWRKR )
                  CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, &
                               A( I, 1 ), LDA )
   10          CONTINUE
!
            ELSE IF( WNTQS ) THEN
!
!              Path 3 (M much larger than N, JOBZ='S')
!              N left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
               IR = 1
!
!              WORK(IR) is N by N
!
               LDWRKR = N
               ITAU = IR + LDWRKR*N
               NWORK = ITAU + N
!
!              Compute A=Q*R
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Copy R to WORK(IR), zeroing out below it
!
               CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), &
                            LDWRKR )
!
!              Generate Q in A
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
               IE = ITAU
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               NWORK = ITAUP + N
!
!              Bidiagonalize R in WORK(IR)
!              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
               CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), &
                            WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagoal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need N+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite U by left singular vectors of R and VT
!              by right singular vectors of R
!              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
               CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Multiply Q in A by left singular vectors of R in
!              WORK(IR), storing result in U
!              (Workspace: need N*N)
!
               CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
               CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ), &
                           LDWRKR, ZERO, U, LDU )
!
            ELSE IF( WNTQA ) THEN
!
!              Path 4 (M much larger than N, JOBZ='A')
!              M left singular vectors to be computed in U and
!              N right singular vectors to be computed in VT
!
               IU = 1
!
!              WORK(IU) is N by N
!
               LDWRKU = N
               ITAU = IU + LDWRKU*N
               NWORK = ITAU + N
!
!              Compute A=Q*R, copying result to U
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!              Generate Q in U
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
               CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!              Produce R in A, zeroing out other entries
!
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
               IE = ITAU
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               NWORK = ITAUP + N
!
!              Bidiagonalize R in A
!              (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                            IERR )
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              (Workspace: need N+N*N+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N, &
                            VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite WORK(IU) by left singular vectors of R and VT
!              by right singular vectors of R
!              (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA, &
                            WORK( ITAUQ ), WORK( IU ), LDWRKU, &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Multiply Q in U by left singular vectors of R in
!              WORK(IU), storing result in A
!              (Workspace: need N*N)
!
               CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ), &
                           LDWRKU, ZERO, A, LDA )
!
!              Copy left singular vectors of A from A to U
!
               CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
!
            END IF
!
         ELSE
!
!           M .LT. MNTHR
!
!           Path 5 (M at least N, but not much larger)
!           Reduce to bidiagonal form without QR decomposition
!
            IE = 1
            ITAUQ = IE + N
            ITAUP = ITAUQ + N
            NWORK = ITAUP + N
!
!           Bidiagonalize A
!           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
!
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                         WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                         IERR )
            IF( WNTQN ) THEN
!
!              Perform bidiagonal SVD, only computing singular values
!              (Workspace: need N+BDSPAC)
!
               CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1, &
                            DUM, IDUM, WORK( NWORK ), IWORK, INFO )
            ELSE IF( WNTQO ) THEN
               IU = NWORK
               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
!
!                 WORK( IU ) is M by N
!
                  LDWRKU = M
                  NWORK = IU + LDWRKU*N
                  CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ), &
                               LDWRKU )
               ELSE
!
!                 WORK( IU ) is N by N
!
                  LDWRKU = N
                  NWORK = IU + LDWRKU*N
!
!                 WORK(IR) is LDWRKR by N
!
                  IR = NWORK
                  LDWRKR = ( LWORK-N*N-3*N ) / N
               END IF
               NWORK = IU + LDWRKU*N
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in WORK(IU) and computing right
!              singular vectors of bidiagonal matrix in VT
!              (Workspace: need N+N*N+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), &
                            LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ), &
                            IWORK, INFO )
!
!              Overwrite VT by right singular vectors of A
!              (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
               IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
!
!                 Overwrite WORK(IU) by left singular vectors of A
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, &
                               WORK( ITAUQ ), WORK( IU ), LDWRKU, &
                               WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!                 Copy left singular vectors of A from WORK(IU) to A
!
                  CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
               ELSE
!
!                 Generate Q in A
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), &
                               WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!                 Multiply Q in A by left singular vectors of
!                 bidiagonal matrix in WORK(IU), storing result in
!                 WORK(IR) and copying to A
!                 (Workspace: need 2*N*N, prefer N*N+M*N)
!
                  DO 20 I = 1, M, LDWRKR
                     CHUNK = MIN( M-I+1, LDWRKR )
                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), &
                                 LDA, WORK( IU ), LDWRKU, ZERO, &
                                 WORK( IR ), LDWRKR )
                     CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR, &
                                  A( I, 1 ), LDA )
   20             CONTINUE
               END IF
!
            ELSE IF( WNTQS ) THEN
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need N+BDSPAC)
!
               CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU )
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              (Workspace: need 3*N, prefer 2*N+N*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
            ELSE IF( WNTQA ) THEN
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need N+BDSPAC)
!
               CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU )
               CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Set the right corner of U to identity matrix
!
               CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ), &
                            LDU )
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
            END IF
!
         END IF
!
      ELSE
!
!        A has more columns than rows. If A has sufficiently more
!        columns than rows, first reduce using the LQ decomposition (if
!        sufficient workspace available)
!
         IF( N.GE.MNTHR ) THEN
!
            IF( WNTQN ) THEN
!
!              Path 1t (N much larger than M, JOBZ='N')
!              No singular vectors to be computed
!
               ITAU = 1
               NWORK = ITAU + M
!
!              Compute A=L*Q
!              (Workspace: need 2*M, prefer M+M*NB)
!
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Zero out above L
!
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
               IE = 1
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               NWORK = ITAUP + M
!
!              Bidiagonalize L in A
!              (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                            IERR )
               NWORK = IE + M
!
!              Perform bidiagonal SVD, computing singular values only
!              (Workspace: need M+BDSPAC)
!
               CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, &
                            DUM, IDUM, WORK( NWORK ), IWORK, INFO )
!
            ELSE IF( WNTQO ) THEN
!
!              Path 2t (N much larger than M, JOBZ='O')
!              M right singular vectors to be overwritten on A and
!              M left singular vectors to be computed in U
!
               IVT = 1
!
!              IVT is M by M
!
               IL = IVT + M*M
               IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
!
!                 WORK(IL) is M by N
!
                  LDWRKL = M
                  CHUNK = N
               ELSE
                  LDWRKL = M
                  CHUNK = ( LWORK-M*M ) / M
               END IF
               ITAU = IL + LDWRKL*M
               NWORK = ITAU + M
!
!              Compute A=L*Q
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Copy L to WORK(IL), zeroing about above it
!
               CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                            WORK( IL+LDWRKL ), LDWRKL )
!
!              Generate Q in A
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
               IE = ITAU
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               NWORK = ITAUP + M
!
!              Bidiagonalize L in WORK(IL)
!              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
               CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), &
                            WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U, and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              (Workspace: need M+M*M+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, &
                            WORK( IVT ), M, DUM, IDUM, WORK( NWORK ), &
                            IWORK, INFO )
!
!              Overwrite U by left singular vectors of L and WORK(IVT)
!              by right singular vectors of L
!              (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, &
                            WORK( ITAUP ), WORK( IVT ), M, &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!              Multiply right singular vectors of L in WORK(IVT) by Q
!              in A, storing result in WORK(IL) and copying to A
!              (Workspace: need 2*M*M, prefer M*M+M*N)
!
               DO 30 I = 1, N, CHUNK
                  BLK = MIN( N-I+1, CHUNK )
                  CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M, &
                              A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
                  CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL, &
                               A( 1, I ), LDA )
   30          CONTINUE
!
            ELSE IF( WNTQS ) THEN
!
!              Path 3t (N much larger than M, JOBZ='S')
!              M right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
               IL = 1
!
!              WORK(IL) is M by M
!
               LDWRKL = M
               ITAU = IL + LDWRKL*M
               NWORK = ITAU + M
!
!              Compute A=L*Q
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Copy L to WORK(IL), zeroing out above it
!
               CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                            WORK( IL+LDWRKL ), LDWRKL )
!
!              Generate Q in A
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
               IE = ITAU
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               NWORK = ITAUP + M
!
!              Bidiagonalize L in WORK(IU), copying result to U
!              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
               CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ), &
                            WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need M+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite U by left singular vectors of L and VT
!              by right singular vectors of L
!              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
!              Multiply right singular vectors of L in WORK(IL) by
!              Q in A, storing result in VT
!              (Workspace: need M*M)
!
               CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
               CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL, &
                           A, LDA, ZERO, VT, LDVT )
!
            ELSE IF( WNTQA ) THEN
!
!              Path 4t (N much larger than M, JOBZ='A')
!              N right singular vectors to be computed in VT and
!              M left singular vectors to be computed in U
!
               IVT = 1
!
!              WORK(IVT) is M by M
!
               LDWKVT = M
               ITAU = IVT + LDWKVT*M
               NWORK = ITAU + M
!
!              Compute A=L*Q, copying result to VT
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!              Generate Q in VT
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!              Produce L in A, zeroing out other entries
!
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
               IE = ITAU
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               NWORK = ITAUP + M
!
!              Bidiagonalize L in A
!              (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                            IERR )
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              (Workspace: need M+M*M+BDSPAC)
!
               CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, &
                            WORK( IVT ), LDWKVT, DUM, IDUM, &
                            WORK( NWORK ), IWORK, INFO )
!
!              Overwrite U by left singular vectors of L and WORK(IVT)
!              by right singular vectors of L
!              (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA, &
                            WORK( ITAUP ), WORK( IVT ), LDWKVT, &
                            WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!              Multiply right singular vectors of L in WORK(IVT) by
!              Q in VT, storing result in A
!              (Workspace: need M*M)
!
               CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT, &
                           VT, LDVT, ZERO, A, LDA )
!
!              Copy right singular vectors of A from A to VT
!
               CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
!
            END IF
!
         ELSE
!
!           N .LT. MNTHR
!
!           Path 5t (N greater than M, but not much larger)
!           Reduce to bidiagonal form without LQ decomposition
!
            IE = 1
            ITAUQ = IE + M
            ITAUP = ITAUQ + M
            NWORK = ITAUP + M
!
!           Bidiagonalize A
!           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                         WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1, &
                         IERR )
            IF( WNTQN ) THEN
!
!              Perform bidiagonal SVD, only computing singular values
!              (Workspace: need M+BDSPAC)
!
               CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1, &
                            DUM, IDUM, WORK( NWORK ), IWORK, INFO )
            ELSE IF( WNTQO ) THEN
               LDWKVT = M
               IVT = NWORK
               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
!
!                 WORK( IVT ) is M by N
!
                  CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ), &
                               LDWKVT )
                  NWORK = IVT + LDWKVT*N
               ELSE
!
!                 WORK( IVT ) is M by M
!
                  NWORK = IVT + LDWKVT*M
                  IL = NWORK
!
!                 WORK(IL) is M by CHUNK
!
                  CHUNK = ( LWORK-M*M-3*M ) / M
               END IF
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in WORK(IVT)
!              (Workspace: need M*M+BDSPAC)
!
               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, &
                            WORK( IVT ), LDWKVT, DUM, IDUM, &
                            WORK( NWORK ), IWORK, INFO )
!
!              Overwrite U by left singular vectors of A
!              (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
!
               IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
!
!                 Overwrite WORK(IVT) by left singular vectors of A
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, &
                               WORK( ITAUP ), WORK( IVT ), LDWKVT, &
                               WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!                 Copy right singular vectors of A from WORK(IVT) to A
!
                  CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
               ELSE
!
!                 Generate P**T in A
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), &
                               WORK( NWORK ), LWORK-NWORK+1, IERR )
!
!                 Multiply Q in A by right singular vectors of
!                 bidiagonal matrix in WORK(IVT), storing result in
!                 WORK(IL) and copying to A
!                 (Workspace: need 2*M*M, prefer M*M+M*N)
!
                  DO 40 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), &
                                 LDWKVT, A( 1, I ), LDA, ZERO, &
                                 WORK( IL ), M )
                     CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ), &
                                  LDA )
   40             CONTINUE
               END IF
            ELSE IF( WNTQS ) THEN
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need M+BDSPAC)
!
               CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              (Workspace: need 3*M, prefer 2*M+M*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
            ELSE IF( WNTQA ) THEN
!
!              Perform bidiagonal SVD, computing left singular vectors
!              of bidiagonal matrix in U and computing right singular
!              vectors of bidiagonal matrix in VT
!              (Workspace: need M+BDSPAC)
!
               CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
               CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT, &
                            LDVT, DUM, IDUM, WORK( NWORK ), IWORK, &
                            INFO )
!
!              Set the right corner of VT to identity matrix
!
               CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ), &
                            LDVT )
!
!              Overwrite U by left singular vectors of A and VT
!              by right singular vectors of A
!              (Workspace: need 2*M+N, prefer 2*M+N*NB)
!
               CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA, &
                            WORK( ITAUQ ), U, LDU, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
               CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA, &
                            WORK( ITAUP ), VT, LDVT, WORK( NWORK ), &
                            LWORK-NWORK+1, IERR )
            END IF
!
         END IF
!
      END IF
!
!     Undo scaling if necessary
!
      IF( ISCL.EQ.1 ) THEN
         IF( ANRM.GT.BIGNUM ) &
            CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, &
                         IERR )
         IF( ANRM.LT.SMLNUM ) &
            CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, &
                         IERR )
      END IF
!
!     Return optimal workspace in WORK(1)
!
      WORK( 1 ) = DBLE( MAXWRK )
!
      RETURN
!
!     End of DGESDD
!
      END
      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGESV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
!
!  The LU decomposition with partial pivoting and row interchanges is
!  used to factor A as
!     A = P * L * U,
!  where P is a permutation matrix, L is unit lower triangular, and U is
!  upper triangular.  The factored form of A is then used to solve the
!  system of equations A * X = B.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N coefficient matrix A.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          The pivot indices that define the permutation matrix P;
!          row i of the matrix was interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS matrix of right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
!                has been completed, but the factor U is exactly
!                singular, so the solution could not be computed.
!
!  =====================================================================
!
!     .. External Subroutines ..
      EXTERNAL           DGETRF, DGETRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESV ', -INFO )
         RETURN
      END IF
!
!     Compute the LU factorization of A.
!
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, &
                      INFO )
      END IF
      RETURN
!
!     End of DGESV
!
      END
      SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBU, JOBVT
      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ), &
                         VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGESVD computes the singular value decomposition (SVD) of a real
!  M-by-N matrix A, optionally computing the left and/or right singular
!  vectors. The SVD is written
!
!       A = U * SIGMA * transpose(V)
!
!  where SIGMA is an M-by-N matrix which is zero except for its
!  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
!  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
!  are the singular values of A; they are real and non-negative, and
!  are returned in descending order.  The first min(m,n) columns of
!  U and V are the left and right singular vectors of A.
!
!  Note that the routine returns V**T, not V.
!
!  Arguments
!  =========
!
!  JOBU    (input) CHARACTER*1
!          Specifies options for computing all or part of the matrix U:
!          = 'A':  all M columns of U are returned in array U:
!          = 'S':  the first min(m,n) columns of U (the left singular
!                  vectors) are returned in the array U;
!          = 'O':  the first min(m,n) columns of U (the left singular
!                  vectors) are overwritten on the array A;
!          = 'N':  no columns of U (no left singular vectors) are
!                  computed.
!
!  JOBVT   (input) CHARACTER*1
!          Specifies options for computing all or part of the matrix
!          V**T:
!          = 'A':  all N rows of V**T are returned in the array VT;
!          = 'S':  the first min(m,n) rows of V**T (the right singular
!                  vectors) are returned in the array VT;
!          = 'O':  the first min(m,n) rows of V**T (the right singular
!                  vectors) are overwritten on the array A;
!          = 'N':  no rows of V**T (no right singular vectors) are
!                  computed.
!
!          JOBVT and JOBU cannot both be 'O'.
!
!  M       (input) INTEGER
!          The number of rows of the input matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the input matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit,
!          if JOBU = 'O',  A is overwritten with the first min(m,n)
!                          columns of U (the left singular vectors,
!                          stored columnwise);
!          if JOBVT = 'O', A is overwritten with the first min(m,n)
!                          rows of V**T (the right singular vectors,
!                          stored rowwise);
!          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
!                          are destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The singular values of A, sorted so that S(i) >= S(i+1).
!
!  U       (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
!          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
!          If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
!          if JOBU = 'S', U contains the first min(m,n) columns of U
!          (the left singular vectors, stored columnwise);
!          if JOBU = 'N' or 'O', U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U.  LDU >= 1; if
!          JOBU = 'S' or 'A', LDU >= M.
!
!  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
!          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
!          V**T;
!          if JOBVT = 'S', VT contains the first min(m,n) rows of
!          V**T (the right singular vectors, stored rowwise);
!          if JOBVT = 'N' or 'O', VT is not referenced.
!
!  LDVT    (input) INTEGER
!          The leading dimension of the array VT.  LDVT >= 1; if
!          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
!          if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
!          superdiagonal elements of an upper bidiagonal matrix B
!          whose diagonal is in S (not necessarily sorted). B
!          satisfies A = U * B * VT, so it has the same singular values
!          as A, and singular vectors related by U and VT.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= 1.
!          LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
!          For good performance, LWORK should generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if DBDSQR did not converge, INFO specifies how many
!                superdiagonals of an intermediate bidiagonal form B
!                did not converge to zero. See the description of WORK
!                above for details.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, &
                         WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
      INTEGER            BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL, &
                         ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, &
                         MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, &
                         NRVT, WRKBL
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY, &
                         DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      MINMN = MIN( M, N )
      MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
      WNTUA = LSAME( JOBU, 'A' )
      WNTUS = LSAME( JOBU, 'S' )
      WNTUAS = WNTUA .OR. WNTUS
      WNTUO = LSAME( JOBU, 'O' )
      WNTUN = LSAME( JOBU, 'N' )
      WNTVA = LSAME( JOBVT, 'A' )
      WNTVS = LSAME( JOBVT, 'S' )
      WNTVAS = WNTVA .OR. WNTVS
      WNTVO = LSAME( JOBVT, 'O' )
      WNTVN = LSAME( JOBVT, 'N' )
      MINWRK = 1
      LQUERY = ( LWORK.EQ.-1 )
!
      IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. &
               ( WNTVO .AND. WNTUO ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
         INFO = -9
      ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. &
               ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
         INFO = -11
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. &
          N.GT.0 ) THEN
         IF( M.GE.N ) THEN
!
!           Compute space needed for DBDSQR
!
            BDSPAC = 5*N
            IF( M.GE.MNTHR ) THEN
               IF( WNTUN ) THEN
!
!                 Path 1 (M much larger than N, JOBU='N')
!
                  MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, &
                           -1 )
                  MAXWRK = MAX( MAXWRK, 3*N+2*N* &
                           ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  IF( WNTVO .OR. WNTVAS ) &
                     MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* &
                              ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  MAXWRK = MAX( MAXWRK, BDSPAC )
                  MINWRK = MAX( 4*N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUO .AND. WNTVN ) THEN
!
!                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUO .AND. WNTVAS ) THEN
!
!                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
!                 'A')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+( N-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUS .AND. WNTVN ) THEN
!
!                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUS .AND. WNTVO ) THEN
!
!                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+( N-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = 2*N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUS .AND. WNTVAS ) THEN
!
!                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
!                 'A')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M, &
                          N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+( N-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUA .AND. WNTVN ) THEN
!
!                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, &
                          M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUA .AND. WNTVO ) THEN
!
!                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, &
                          M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+( N-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = 2*N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTUA .AND. WNTVAS ) THEN
!
!                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
!                 'A')
!
                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M, &
                          M, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+2*N* &
                          ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+N* &
                          ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, 3*N+( N-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = N*N + WRKBL
                  MINWRK = MAX( 3*N+M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               END IF
            ELSE
!
!              Path 10 (M at least N, but not much larger)
!
               MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, &
                        -1, -1 )
               IF( WNTUS .OR. WNTUO ) &
                  MAXWRK = MAX( MAXWRK, 3*N+N* &
                           ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
               IF( WNTUA ) &
                  MAXWRK = MAX( MAXWRK, 3*N+M* &
                           ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
               IF( .NOT.WNTVN ) &
                  MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* &
                           ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC )
               MINWRK = MAX( 3*N+M, BDSPAC )
               MAXWRK = MAX( MAXWRK, MINWRK )
            END IF
         ELSE
!
!           Compute space needed for DBDSQR
!
            BDSPAC = 5*M
            IF( N.GE.MNTHR ) THEN
               IF( WNTVN ) THEN
!
!                 Path 1t(N much larger than M, JOBVT='N')
!
                  MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, &
                           -1 )
                  MAXWRK = MAX( MAXWRK, 3*M+2*M* &
                           ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  IF( WNTUO .OR. WNTUAS ) &
                     MAXWRK = MAX( MAXWRK, 3*M+M* &
                              ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  MAXWRK = MAX( MAXWRK, BDSPAC )
                  MINWRK = MAX( 4*M, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVO .AND. WNTUN ) THEN
!
!                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVO .AND. WNTUAS ) THEN
!
!                 Path 3t(N much larger than M, JOBU='S' or 'A',
!                 JOBVT='O')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVS .AND. WNTUN ) THEN
!
!                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVS .AND. WNTUO ) THEN
!
!                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = 2*M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVS .AND. WNTUAS ) THEN
!
!                 Path 6t(N much larger than M, JOBU='S' or 'A',
!                 JOBVT='S')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVA .AND. WNTUN ) THEN
!
!                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVA .AND. WNTUO ) THEN
!
!                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = 2*M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               ELSE IF( WNTVA .AND. WNTUAS ) THEN
!
!                 Path 9t(N much larger than M, JOBU='S' or 'A',
!                 JOBVT='A')
!
                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N, &
                          N, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+2*M* &
                          ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+( M-1 )* &
                          ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, 3*M+M* &
                          ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
                  WRKBL = MAX( WRKBL, BDSPAC )
                  MAXWRK = M*M + WRKBL
                  MINWRK = MAX( 3*M+N, BDSPAC )
                  MAXWRK = MAX( MAXWRK, MINWRK )
               END IF
            ELSE
!
!              Path 10t(N greater than M, but not much larger)
!
               MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, &
                        -1, -1 )
               IF( WNTVS .OR. WNTVO ) &
                  MAXWRK = MAX( MAXWRK, 3*M+M* &
                           ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
               IF( WNTVA ) &
                  MAXWRK = MAX( MAXWRK, 3*M+N* &
                           ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
               IF( .NOT.WNTUN ) &
                  MAXWRK = MAX( MAXWRK, 3*M+( M-1 )* &
                           ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC )
               MINWRK = MAX( 3*M+N, BDSPAC )
               MAXWRK = MAX( MAXWRK, MINWRK )
            END IF
         END IF
         WORK( 1 ) = MAXWRK
      END IF
!
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         IF( LWORK.GE.1 ) &
            WORK( 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
      END IF
!
      IF( M.GE.N ) THEN
!
!        A has at least as many rows as columns. If A has sufficiently
!        more rows than columns, first reduce using the QR
!        decomposition (if sufficient workspace available)
!
         IF( M.GE.MNTHR ) THEN
!
            IF( WNTUN ) THEN
!
!              Path 1 (M much larger than N, JOBU='N')
!              No left singular vectors to be computed
!
               ITAU = 1
               IWORK = ITAU + N
!
!              Compute A=Q*R
!              (Workspace: need 2*N, prefer N+N*NB)
!
               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), &
                            LWORK-IWORK+1, IERR )
!
!              Zero out below R
!
               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
               IE = 1
               ITAUQ = IE + N
               ITAUP = ITAUQ + N
               IWORK = ITAUP + N
!
!              Bidiagonalize R in A
!              (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                            IERR )
               NCVT = 0
               IF( WNTVO .OR. WNTVAS ) THEN
!
!                 If right singular vectors desired, generate P'.
!                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                  CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  NCVT = N
               END IF
               IWORK = IE + N
!
!              Perform bidiagonal QR iteration, computing right
!              singular vectors of A in A if desired
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA, &
                            DUM, 1, DUM, 1, WORK( IWORK ), INFO )
!
!              If right singular vectors desired in VT, copy them there
!
               IF( WNTVAS ) &
                  CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
!
            ELSE IF( WNTUO .AND. WNTVN ) THEN
!
!              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
!              N left singular vectors to be overwritten on A and
!              no right singular vectors to be computed
!
               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
!
!                 Sufficient workspace for a fast algorithm
!
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
!
!                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
!
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
!
!                    WORK(IU) is LDA by N, WORK(IR) is N by N
!
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
!
!                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
!
                     LDWRKU = ( LWORK-N*N-N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
!
!                 Compute A=Q*R
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy R to WORK(IR) and zero out below it
!
                  CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ), &
                               LDWRKR )
!
!                 Generate Q in A
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + N
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
!
!                 Bidiagonalize R in WORK(IR)
!                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                  CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Generate left vectors bidiagonalizing R
!                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, &
                               WORK( ITAUQ ), WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
                  IWORK = IE + N
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of R in WORK(IR)
!                 (Workspace: need N*N+BDSPAC)
!
                  CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1, &
                               WORK( IR ), LDWRKR, DUM, 1, &
                               WORK( IWORK ), INFO )
                  IU = IE + N
!
!                 Multiply Q in A by left singular vectors of R in
!                 WORK(IR), storing result in WORK(IU) and copying to A
!                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
!
                  DO 10 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), &
                                 LDA, WORK( IR ), LDWRKR, ZERO, &
                                 WORK( IU ), LDWRKU )
                     CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, &
                                  A( I, 1 ), LDA )
   10             CONTINUE
!
               ELSE
!
!                 Insufficient workspace for a fast algorithm
!
                  IE = 1
                  ITAUQ = IE + N
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
!
!                 Bidiagonalize A
!                 (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
!
                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Generate left vectors bidiagonalizing A
!                 (Workspace: need 4*N, prefer 3*N+N*NB)
!
                  CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of A in A
!                 (Workspace: need BDSPAC)
!
                  CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1, &
                               A, LDA, DUM, 1, WORK( IWORK ), INFO )
!
               END IF
!
            ELSE IF( WNTUO .AND. WNTVAS ) THEN
!
!              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
!              N left singular vectors to be overwritten on A and
!              N right singular vectors to be computed in VT
!
               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
!
!                 Sufficient workspace for a fast algorithm
!
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
!
                     LDWRKU = LDA
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is N by N
!
                     LDWRKU = LDA
                     LDWRKR = N
                  ELSE
!
!                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
!
                     LDWRKU = ( LWORK-N*N-N ) / N
                     LDWRKR = N
                  END IF
                  ITAU = IR + LDWRKR*N
                  IWORK = ITAU + N
!
!                 Compute A=Q*R
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy R to VT, zeroing out below it
!
                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), &
                               LDVT )
!
!                 Generate Q in A
!                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + N
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
!
!                 Bidiagonalize R in VT, copying result to WORK(IR)
!                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                  CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
!
!                 Generate left vectors bidiagonalizing R in WORK(IR)
!                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, &
                               WORK( ITAUQ ), WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
!
!                 Generate right vectors bidiagonalizing R in VT
!                 (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
!
                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of R in WORK(IR) and computing right
!                 singular vectors of R in VT
!                 (Workspace: need N*N+BDSPAC)
!
                  CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT, &
                               WORK( IR ), LDWRKR, DUM, 1, &
                               WORK( IWORK ), INFO )
                  IU = IE + N
!
!                 Multiply Q in A by left singular vectors of R in
!                 WORK(IR), storing result in WORK(IU) and copying to A
!                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
!
                  DO 20 I = 1, M, LDWRKU
                     CHUNK = MIN( M-I+1, LDWRKU )
                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ), &
                                 LDA, WORK( IR ), LDWRKR, ZERO, &
                                 WORK( IU ), LDWRKU )
                     CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, &
                                  A( I, 1 ), LDA )
   20             CONTINUE
!
               ELSE
!
!                 Insufficient workspace for a fast algorithm
!
                  ITAU = 1
                  IWORK = ITAU + N
!
!                 Compute A=Q*R
!                 (Workspace: need 2*N, prefer N+N*NB)
!
                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy R to VT, zeroing out below it
!
                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), &
                               LDVT )
!
!                 Generate Q in A
!                 (Workspace: need 2*N, prefer N+N*NB)
!
                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + N
                  ITAUP = ITAUQ + N
                  IWORK = ITAUP + N
!
!                 Bidiagonalize R in VT
!                 (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                  CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Multiply Q in A by left vectors bidiagonalizing R
!                 (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                  CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, &
                               WORK( ITAUQ ), A, LDA, WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
!
!                 Generate right vectors bidiagonalizing R in VT
!                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + N
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of A in A and computing right
!                 singular vectors of A in VT
!                 (Workspace: need BDSPAC)
!
                  CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT, &
                               A, LDA, DUM, 1, WORK( IWORK ), INFO )
!
               END IF
!
            ELSE IF( WNTUS ) THEN
!
               IF( WNTVN ) THEN
!
!                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
!                 N left singular vectors to be computed in U and
!                 no right singular vectors to be computed
!
                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
!
!                       WORK(IR) is LDA by N
!
                        LDWRKR = LDA
                     ELSE
!
!                       WORK(IR) is N by N
!
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to WORK(IR), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), &
                                  LDWRKR )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IR+1 ), LDWRKR )
!
!                    Generate Q in A
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IR)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left vectors bidiagonalizing R in WORK(IR)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IR)
!                    (Workspace: need N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, &
                                  1, WORK( IR ), LDWRKR, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply Q in A by left singular vectors of R in
!                    WORK(IR), storing result in U
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, &
                                 WORK( IR ), LDWRKR, ZERO, U, LDU )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Zero out below R in A
!
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), &
                                  LDA )
!
!                    Bidiagonalize R in A
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left vectors bidiagonalizing R
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, &
                                  1, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTVO ) THEN
!
!                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
!                 N left singular vectors to be computed in U and
!                 N right singular vectors to be overwritten on A
!
                  IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
!
!                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
!
!                       WORK(IU) is LDA by N and WORK(IR) is N by N
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
!
!                       WORK(IU) is N by N and WORK(IR) is N by N
!
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R
!                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to WORK(IU), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IU+1 ), LDWRKU )
!
!                    Generate Q in A
!                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
!
                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IU), copying result to
!                    WORK(IR)
!                    (Workspace: need 2*N*N+4*N,
!                                prefer 2*N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, &
                                  WORK( IR ), LDWRKR )
!
!                    Generate left bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need 2*N*N+4*N-1,
!                                prefer 2*N*N+3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IU) and computing
!                    right singular vectors of R in WORK(IR)
!                    (Workspace: need 2*N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), &
                                  WORK( IR ), LDWRKR, WORK( IU ), &
                                  LDWRKU, DUM, 1, WORK( IWORK ), INFO )
!
!                    Multiply Q in A by left singular vectors of R in
!                    WORK(IU), storing result in U
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, &
                                 WORK( IU ), LDWRKU, ZERO, U, LDU )
!
!                    Copy right singular vectors of R to A
!                    (Workspace: need N*N)
!
                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, &
                                  LDA )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Zero out below R in A
!
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), &
                                  LDA )
!
!                    Bidiagonalize R in A
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left vectors bidiagonalizing R
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right vectors bidiagonalizing R in A
!                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in A
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, &
                                  LDA, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTVAS ) THEN
!
!                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
!                         or 'A')
!                 N left singular vectors to be computed in U and
!                 N right singular vectors to be computed in VT
!
                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
!
!                       WORK(IU) is LDA by N
!
                        LDWRKU = LDA
                     ELSE
!
!                       WORK(IU) is N by N
!
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to WORK(IU), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IU+1 ), LDWRKU )
!
!                    Generate Q in A
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IU), copying result to VT
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, &
                                  LDVT )
!
!                    Generate left bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in VT
!                    (Workspace: need N*N+4*N-1,
!                                prefer N*N+3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IU) and computing
!                    right singular vectors of R in VT
!                    (Workspace: need N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, &
                                  LDVT, WORK( IU ), LDWRKU, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply Q in A by left singular vectors of R in
!                    WORK(IU), storing result in U
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, &
                                 WORK( IU ), LDWRKU, ZERO, U, LDU )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to VT, zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), &
                                  LDVT )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in VT
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left bidiagonalizing vectors
!                    in VT
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in VT
!                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               END IF
!
            ELSE IF( WNTUA ) THEN
!
               IF( WNTVN ) THEN
!
!                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
!                 M left singular vectors to be computed in U and
!                 no right singular vectors to be computed
!
                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
!
!                       WORK(IR) is LDA by N
!
                        LDWRKR = LDA
                     ELSE
!
!                       WORK(IR) is N by N
!
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Copy R to WORK(IR), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), &
                                  LDWRKR )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IR+1 ), LDWRKR )
!
!                    Generate Q in U
!                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IR)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IR)
!                    (Workspace: need N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, &
                                  1, WORK( IR ), LDWRKR, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply Q in U by left singular vectors of R in
!                    WORK(IR), storing result in A
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, &
                                 WORK( IR ), LDWRKR, ZERO, A, LDA )
!
!                    Copy left singular vectors of A from A to U
!
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need N+M, prefer N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Zero out below R in A
!
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), &
                                  LDA )
!
!                    Bidiagonalize R in A
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left bidiagonalizing vectors
!                    in A
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, &
                                  1, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTVO ) THEN
!
!                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
!                 M left singular vectors to be computed in U and
!                 N right singular vectors to be overwritten on A
!
                  IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
!
!                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
!
!                       WORK(IU) is LDA by N and WORK(IR) is N by N
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     ELSE
!
!                       WORK(IU) is N by N and WORK(IR) is N by N
!
                        LDWRKU = N
                        IR = IU + LDWRKU*N
                        LDWRKR = N
                     END IF
                     ITAU = IR + LDWRKR*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to WORK(IU), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IU+1 ), LDWRKU )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IU), copying result to
!                    WORK(IR)
!                    (Workspace: need 2*N*N+4*N,
!                                prefer 2*N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, &
                                  WORK( IR ), LDWRKR )
!
!                    Generate left bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need 2*N*N+4*N-1,
!                                prefer 2*N*N+3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IU) and computing
!                    right singular vectors of R in WORK(IR)
!                    (Workspace: need 2*N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), &
                                  WORK( IR ), LDWRKR, WORK( IU ), &
                                  LDWRKU, DUM, 1, WORK( IWORK ), INFO )
!
!                    Multiply Q in U by left singular vectors of R in
!                    WORK(IU), storing result in A
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, &
                                 WORK( IU ), LDWRKU, ZERO, A, LDA )
!
!                    Copy left singular vectors of A from A to U
!
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
!
!                    Copy right singular vectors of R from WORK(IR) to A
!
                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, &
                                  LDA )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need N+M, prefer N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Zero out below R in A
!
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), &
                                  LDA )
!
!                    Bidiagonalize R in A
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left bidiagonalizing vectors
!                    in A
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in A
!                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in A
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A, &
                                  LDA, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTVAS ) THEN
!
!                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
!                         or 'A')
!                 M left singular vectors to be computed in U and
!                 N right singular vectors to be computed in VT
!
                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
!
!                       WORK(IU) is LDA by N
!
                        LDWRKU = LDA
                     ELSE
!
!                       WORK(IU) is N by N
!
                        LDWRKU = N
                     END IF
                     ITAU = IU + LDWRKU*N
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R to WORK(IU), zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, &
                                  WORK( IU+1 ), LDWRKU )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in WORK(IU), copying result to VT
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, &
                                  LDVT )
!
!                    Generate left bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
!
                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in VT
!                    (Workspace: need N*N+4*N-1,
!                                prefer N*N+3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of R in WORK(IU) and computing
!                    right singular vectors of R in VT
!                    (Workspace: need N*N+BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, &
                                  LDVT, WORK( IU ), LDWRKU, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply Q in U by left singular vectors of R in
!                    WORK(IU), storing result in A
!                    (Workspace: need N*N)
!
                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, &
                                 WORK( IU ), LDWRKU, ZERO, A, LDA )
!
!                    Copy left singular vectors of A from A to U
!
                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + N
!
!                    Compute A=Q*R, copying result to U
!                    (Workspace: need 2*N, prefer N+N*NB)
!
                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
!
!                    Generate Q in U
!                    (Workspace: need N+M, prefer N+M*NB)
!
                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy R from A to VT, zeroing out below it
!
                     CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, VT( 2, 1 ), &
                                  LDVT )
                     IE = ITAU
                     ITAUQ = IE + N
                     ITAUP = ITAUQ + N
                     IWORK = ITAUP + N
!
!                    Bidiagonalize R in VT
!                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
!
                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply Q in U by left bidiagonalizing vectors
!                    in VT
!                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
!
                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, &
                                  WORK( ITAUQ ), U, LDU, WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in VT
!                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + N
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               END IF
!
            END IF
!
         ELSE
!
!           M .LT. MNTHR
!
!           Path 10 (M at least N, but not much larger)
!           Reduce to bidiagonal form without QR decomposition
!
            IE = 1
            ITAUQ = IE + N
            ITAUP = ITAUQ + N
            IWORK = ITAUP + N
!
!           Bidiagonalize A
!           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
!
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                         WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                         IERR )
            IF( WNTUAS ) THEN
!
!              If left singular vectors desired in U, copy result to U
!              and generate left bidiagonalizing vectors in U
!              (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
!
               CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
               IF( WNTUS ) &
                  NCU = N
               IF( WNTUA ) &
                  NCU = M
               CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVAS ) THEN
!
!              If right singular vectors desired in VT, copy result to
!              VT and generate right bidiagonalizing vectors in VT
!              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
               CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
               CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTUO ) THEN
!
!              If left singular vectors desired in A, generate left
!              bidiagonalizing vectors in A
!              (Workspace: need 4*N, prefer 3*N+N*NB)
!
               CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
!
!              If right singular vectors desired in A, generate right
!              bidiagonalizing vectors in A
!              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
               CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IWORK = IE + N
            IF( WNTUAS .OR. WNTUO ) &
               NRU = M
            IF( WNTUN ) &
               NRU = 0
            IF( WNTVAS .OR. WNTVO ) &
               NCVT = N
            IF( WNTVN ) &
               NCVT = 0
            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in U and computing right singular
!              vectors in VT
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, &
                            LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in U and computing right singular
!              vectors in A
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA, &
                            U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in A and computing right singular
!              vectors in VT
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT, &
                            LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
            END IF
!
         END IF
!
      ELSE
!
!        A has more columns than rows. If A has sufficiently more
!        columns than rows, first reduce using the LQ decomposition (if
!        sufficient workspace available)
!
         IF( N.GE.MNTHR ) THEN
!
            IF( WNTVN ) THEN
!
!              Path 1t(N much larger than M, JOBVT='N')
!              No right singular vectors to be computed
!
               ITAU = 1
               IWORK = ITAU + M
!
!              Compute A=L*Q
!              (Workspace: need 2*M, prefer M+M*NB)
!
               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), &
                            LWORK-IWORK+1, IERR )
!
!              Zero out above L
!
               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
               IE = 1
               ITAUQ = IE + M
               ITAUP = ITAUQ + M
               IWORK = ITAUP + M
!
!              Bidiagonalize L in A
!              (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                            WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                            IERR )
               IF( WNTUO .OR. WNTUAS ) THEN
!
!                 If left singular vectors desired, generate Q
!                 (Workspace: need 4*M, prefer 3*M+M*NB)
!
                  CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
               END IF
               IWORK = IE + M
               NRU = 0
               IF( WNTUO .OR. WNTUAS ) &
                  NRU = M
!
!              Perform bidiagonal QR iteration, computing left singular
!              vectors of A in A if desired
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A, &
                            LDA, DUM, 1, WORK( IWORK ), INFO )
!
!              If left singular vectors desired in U, copy them there
!
               IF( WNTUAS ) &
                  CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
!
            ELSE IF( WNTVO .AND. WNTUN ) THEN
!
!              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
!              M right singular vectors to be overwritten on A and
!              no left singular vectors to be computed
!
               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
!
!                 Sufficient workspace for a fast algorithm
!
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
!
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is M by M
!
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
!
!                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
!
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M-M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
!
!                 Compute A=L*Q
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy L to WORK(IR) and zero out above it
!
                  CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                               WORK( IR+LDWRKR ), LDWRKR )
!
!                 Generate Q in A
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + M
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
!
!                 Bidiagonalize L in WORK(IR)
!                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                  CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Generate right vectors bidiagonalizing L
!                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
!
                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, &
                               WORK( ITAUP ), WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
                  IWORK = IE + M
!
!                 Perform bidiagonal QR iteration, computing right
!                 singular vectors of L in WORK(IR)
!                 (Workspace: need M*M+BDSPAC)
!
                  CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), &
                               WORK( IR ), LDWRKR, DUM, 1, DUM, 1, &
                               WORK( IWORK ), INFO )
                  IU = IE + M
!
!                 Multiply right singular vectors of L in WORK(IR) by Q
!                 in A, storing result in WORK(IU) and copying to A
!                 (Workspace: need M*M+2*M, prefer M*M+M*N+M)
!
                  DO 30 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), &
                                 LDWRKR, A( 1, I ), LDA, ZERO, &
                                 WORK( IU ), LDWRKU )
                     CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, &
                                  A( 1, I ), LDA )
   30             CONTINUE
!
               ELSE
!
!                 Insufficient workspace for a fast algorithm
!
                  IE = 1
                  ITAUQ = IE + M
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
!
!                 Bidiagonalize A
!                 (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Generate right vectors bidiagonalizing A
!                 (Workspace: need 4*M, prefer 3*M+M*NB)
!
                  CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
!
!                 Perform bidiagonal QR iteration, computing right
!                 singular vectors of A in A
!                 (Workspace: need BDSPAC)
!
                  CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA, &
                               DUM, 1, DUM, 1, WORK( IWORK ), INFO )
!
               END IF
!
            ELSE IF( WNTVO .AND. WNTUAS ) THEN
!
!              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
!              M right singular vectors to be overwritten on A and
!              M left singular vectors to be computed in U
!
               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
!
!                 Sufficient workspace for a fast algorithm
!
                  IR = 1
                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
!
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = LDA
                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
!
!                    WORK(IU) is LDA by N and WORK(IR) is M by M
!
                     LDWRKU = LDA
                     CHUNK = N
                     LDWRKR = M
                  ELSE
!
!                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
!
                     LDWRKU = M
                     CHUNK = ( LWORK-M*M-M ) / M
                     LDWRKR = M
                  END IF
                  ITAU = IR + LDWRKR*M
                  IWORK = ITAU + M
!
!                 Compute A=L*Q
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy L to U, zeroing about above it
!
                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), &
                               LDU )
!
!                 Generate Q in A
!                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + M
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
!
!                 Bidiagonalize L in U, copying result to WORK(IR)
!                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                  CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
!
!                 Generate right vectors bidiagonalizing L in WORK(IR)
!                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
!
                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, &
                               WORK( ITAUP ), WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
!
!                 Generate left vectors bidiagonalizing L in U
!                 (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
!
                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of L in U, and computing right
!                 singular vectors of L in WORK(IR)
!                 (Workspace: need M*M+BDSPAC)
!
                  CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), &
                               WORK( IR ), LDWRKR, U, LDU, DUM, 1, &
                               WORK( IWORK ), INFO )
                  IU = IE + M
!
!                 Multiply right singular vectors of L in WORK(IR) by Q
!                 in A, storing result in WORK(IU) and copying to A
!                 (Workspace: need M*M+2*M, prefer M*M+M*N+M))
!
                  DO 40 I = 1, N, CHUNK
                     BLK = MIN( N-I+1, CHUNK )
                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ), &
                                 LDWRKR, A( 1, I ), LDA, ZERO, &
                                 WORK( IU ), LDWRKU )
                     CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, &
                                  A( 1, I ), LDA )
   40             CONTINUE
!
               ELSE
!
!                 Insufficient workspace for a fast algorithm
!
                  ITAU = 1
                  IWORK = ITAU + M
!
!                 Compute A=L*Q
!                 (Workspace: need 2*M, prefer M+M*NB)
!
                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Copy L to U, zeroing out above it
!
                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), &
                               LDU )
!
!                 Generate Q in A
!                 (Workspace: need 2*M, prefer M+M*NB)
!
                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IE = ITAU
                  ITAUQ = IE + M
                  ITAUP = ITAUQ + M
                  IWORK = ITAUP + M
!
!                 Bidiagonalize L in U
!                 (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                  CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), &
                               WORK( ITAUQ ), WORK( ITAUP ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                 Multiply right vectors bidiagonalizing L by Q in A
!                 (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                  CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, &
                               WORK( ITAUP ), A, LDA, WORK( IWORK ), &
                               LWORK-IWORK+1, IERR )
!
!                 Generate left vectors bidiagonalizing L in U
!                 (Workspace: need 4*M, prefer 3*M+M*NB)
!
                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                               WORK( IWORK ), LWORK-IWORK+1, IERR )
                  IWORK = IE + M
!
!                 Perform bidiagonal QR iteration, computing left
!                 singular vectors of A in U and computing right
!                 singular vectors of A in A
!                 (Workspace: need BDSPAC)
!
                  CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA, &
                               U, LDU, DUM, 1, WORK( IWORK ), INFO )
!
               END IF
!
            ELSE IF( WNTVS ) THEN
!
               IF( WNTUN ) THEN
!
!                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
!                 M right singular vectors to be computed in VT and
!                 no left singular vectors to be computed
!
                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
!
!                       WORK(IR) is LDA by M
!
                        LDWRKR = LDA
                     ELSE
!
!                       WORK(IR) is M by M
!
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to WORK(IR), zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), &
                                  LDWRKR )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IR+LDWRKR ), LDWRKR )
!
!                    Generate Q in A
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IR)
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right vectors bidiagonalizing L in
!                    WORK(IR)
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing right
!                    singular vectors of L in WORK(IR)
!                    (Workspace: need M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), &
                                  WORK( IR ), LDWRKR, DUM, 1, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IR) by
!                    Q in A, storing result in VT
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), &
                                 LDWRKR, A, LDA, ZERO, VT, LDVT )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy result to VT
!
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Zero out above L in A
!
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), &
                                  LDA )
!
!                    Bidiagonalize L in A
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right vectors bidiagonalizing L by Q in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, &
                                  LDVT, DUM, 1, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTUO ) THEN
!
!                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
!                 M right singular vectors to be computed in VT and
!                 M left singular vectors to be overwritten on A
!
                  IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
!
!                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
!
!                       WORK(IU) is LDA by M and WORK(IR) is M by M
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
!
!                       WORK(IU) is M by M and WORK(IR) is M by M
!
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q
!                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to WORK(IU), zeroing out below it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IU+LDWRKU ), LDWRKU )
!
!                    Generate Q in A
!                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
!
                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IU), copying result to
!                    WORK(IR)
!                    (Workspace: need 2*M*M+4*M,
!                                prefer 2*M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, &
                                  WORK( IR ), LDWRKR )
!
!                    Generate right bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need 2*M*M+4*M-1,
!                                prefer 2*M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of L in WORK(IR) and computing
!                    right singular vectors of L in WORK(IU)
!                    (Workspace: need 2*M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), &
                                  WORK( IU ), LDWRKU, WORK( IR ), &
                                  LDWRKR, DUM, 1, WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IU) by
!                    Q in A, storing result in VT
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), &
                                 LDWRKU, A, LDA, ZERO, VT, LDVT )
!
!                    Copy left singular vectors of L to A
!                    (Workspace: need M*M)
!
                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, &
                                  LDA )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Zero out above L in A
!
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), &
                                  LDA )
!
!                    Bidiagonalize L in A
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right vectors bidiagonalizing L by Q in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors of L in A
!                    (Workspace: need 4*M, prefer 3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, compute left
!                    singular vectors of A in A and compute right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, A, LDA, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTUAS ) THEN
!
!                 Path 6t(N much larger than M, JOBU='S' or 'A',
!                         JOBVT='S')
!                 M right singular vectors to be computed in VT and
!                 M left singular vectors to be computed in U
!
                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
!
!                       WORK(IU) is LDA by N
!
                        LDWRKU = LDA
                     ELSE
!
!                       WORK(IU) is LDA by M
!
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to WORK(IU), zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IU+LDWRKU ), LDWRKU )
!
!                    Generate Q in A
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IU), copying result to U
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, &
                                  LDU )
!
!                    Generate right bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need M*M+4*M-1,
!                                prefer M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in U
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of L in U and computing right
!                    singular vectors of L in WORK(IU)
!                    (Workspace: need M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), &
                                  WORK( IU ), LDWRKU, U, LDU, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IU) by
!                    Q in A, storing result in VT
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), &
                                 LDWRKU, A, LDA, ZERO, VT, LDVT )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to U, zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), &
                                  LDU )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in U
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right bidiagonalizing vectors in U by Q
!                    in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in U
!                    (Workspace: need 4*M, prefer 3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               END IF
!
            ELSE IF( WNTVA ) THEN
!
               IF( WNTUN ) THEN
!
!                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
!                 N right singular vectors to be computed in VT and
!                 no left singular vectors to be computed
!
                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IR = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
!
!                       WORK(IR) is LDA by M
!
                        LDWRKR = LDA
                     ELSE
!
!                       WORK(IR) is M by M
!
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Copy L to WORK(IR), zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), &
                                  LDWRKR )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IR+LDWRKR ), LDWRKR )
!
!                    Generate Q in VT
!                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IR)
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate right bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need M*M+4*M-1,
!                                prefer M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing right
!                    singular vectors of L in WORK(IR)
!                    (Workspace: need M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ), &
                                  WORK( IR ), LDWRKR, DUM, 1, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IR) by
!                    Q in VT, storing result in A
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ), &
                                 LDWRKR, VT, LDVT, ZERO, A, LDA )
!
!                    Copy right singular vectors of A from A to VT
!
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need M+N, prefer M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Zero out above L in A
!
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), &
                                  LDA )
!
!                    Bidiagonalize L in A
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right bidiagonalizing vectors in A by Q
!                    in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT, &
                                  LDVT, DUM, 1, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTUO ) THEN
!
!                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
!                 N right singular vectors to be computed in VT and
!                 M left singular vectors to be overwritten on A
!
                  IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
!
!                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = LDA
                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
!
!                       WORK(IU) is LDA by M and WORK(IR) is M by M
!
                        LDWRKU = LDA
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     ELSE
!
!                       WORK(IU) is M by M and WORK(IR) is M by M
!
                        LDWRKU = M
                        IR = IU + LDWRKU*M
                        LDWRKR = M
                     END IF
                     ITAU = IR + LDWRKR*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to WORK(IU), zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IU+LDWRKU ), LDWRKU )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IU), copying result to
!                    WORK(IR)
!                    (Workspace: need 2*M*M+4*M,
!                                prefer 2*M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, &
                                  WORK( IR ), LDWRKR )
!
!                    Generate right bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need 2*M*M+4*M-1,
!                                prefer 2*M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in WORK(IR)
!                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, &
                                  WORK( ITAUQ ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of L in WORK(IR) and computing
!                    right singular vectors of L in WORK(IU)
!                    (Workspace: need 2*M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), &
                                  WORK( IU ), LDWRKU, WORK( IR ), &
                                  LDWRKR, DUM, 1, WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IU) by
!                    Q in VT, storing result in A
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), &
                                 LDWRKU, VT, LDVT, ZERO, A, LDA )
!
!                    Copy right singular vectors of A from A to VT
!
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
!
!                    Copy left singular vectors of A from WORK(IR) to A
!
                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, &
                                  LDA )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need M+N, prefer M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Zero out above L in A
!
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), &
                                  LDA )
!
!                    Bidiagonalize L in A
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right bidiagonalizing vectors in A by Q
!                    in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in A
!                    (Workspace: need 4*M, prefer 3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in A and computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, A, LDA, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               ELSE IF( WNTUAS ) THEN
!
!                 Path 9t(N much larger than M, JOBU='S' or 'A',
!                         JOBVT='A')
!                 N right singular vectors to be computed in VT and
!                 M left singular vectors to be computed in U
!
                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
!
!                    Sufficient workspace for a fast algorithm
!
                     IU = 1
                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
!
!                       WORK(IU) is LDA by M
!
                        LDWRKU = LDA
                     ELSE
!
!                       WORK(IU) is M by M
!
                        LDWRKU = M
                     END IF
                     ITAU = IU + LDWRKU*M
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to WORK(IU), zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ), &
                                  LDWRKU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, &
                                  WORK( IU+LDWRKU ), LDWRKU )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in WORK(IU), copying result to U
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S, &
                                  WORK( IE ), WORK( ITAUQ ), &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, &
                                  LDU )
!
!                    Generate right bidiagonalizing vectors in WORK(IU)
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
!
                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU, &
                                  WORK( ITAUP ), WORK( IWORK ), &
                                  LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in U
!                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of L in U and computing right
!                    singular vectors of L in WORK(IU)
!                    (Workspace: need M*M+BDSPAC)
!
                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ), &
                                  WORK( IU ), LDWRKU, U, LDU, DUM, 1, &
                                  WORK( IWORK ), INFO )
!
!                    Multiply right singular vectors of L in WORK(IU) by
!                    Q in VT, storing result in A
!                    (Workspace: need M*M)
!
                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ), &
                                 LDWRKU, VT, LDVT, ZERO, A, LDA )
!
!                    Copy right singular vectors of A from A to VT
!
                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
!
                  ELSE
!
!                    Insufficient workspace for a fast algorithm
!
                     ITAU = 1
                     IWORK = ITAU + M
!
!                    Compute A=L*Q, copying result to VT
!                    (Workspace: need 2*M, prefer M+M*NB)
!
                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
!
!                    Generate Q in VT
!                    (Workspace: need M+N, prefer M+N*NB)
!
                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Copy L to U, zeroing out above it
!
                     CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ), &
                                  LDU )
                     IE = ITAU
                     ITAUQ = IE + M
                     ITAUP = ITAUQ + M
                     IWORK = ITAUP + M
!
!                    Bidiagonalize L in U
!                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
!
                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ), &
                                  WORK( ITAUQ ), WORK( ITAUP ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Multiply right bidiagonalizing vectors in U by Q
!                    in VT
!                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
!
                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU, &
                                  WORK( ITAUP ), VT, LDVT, &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
!
!                    Generate left bidiagonalizing vectors in U
!                    (Workspace: need 4*M, prefer 3*M+M*NB)
!
                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), &
                                  WORK( IWORK ), LWORK-IWORK+1, IERR )
                     IWORK = IE + M
!
!                    Perform bidiagonal QR iteration, computing left
!                    singular vectors of A in U and computing right
!                    singular vectors of A in VT
!                    (Workspace: need BDSPAC)
!
                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT, &
                                  LDVT, U, LDU, DUM, 1, WORK( IWORK ), &
                                  INFO )
!
                  END IF
!
               END IF
!
            END IF
!
         ELSE
!
!           N .LT. MNTHR
!
!           Path 10t(N greater than M, but not much larger)
!           Reduce to bidiagonal form without LQ decomposition
!
            IE = 1
            ITAUQ = IE + M
            ITAUP = ITAUQ + M
            IWORK = ITAUP + M
!
!           Bidiagonalize A
!           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), &
                         WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, &
                         IERR )
            IF( WNTUAS ) THEN
!
!              If left singular vectors desired in U, copy result to U
!              and generate left bidiagonalizing vectors in U
!              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
!
               CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
               CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVAS ) THEN
!
!              If right singular vectors desired in VT, copy result to
!              VT and generate right bidiagonalizing vectors in VT
!              (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
!
               CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
               IF( WNTVA ) &
                  NRVT = N
               IF( WNTVS ) &
                  NRVT = M
               CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTUO ) THEN
!
!              If left singular vectors desired in A, generate left
!              bidiagonalizing vectors in A
!              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
!
               CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IF( WNTVO ) THEN
!
!              If right singular vectors desired in A, generate right
!              bidiagonalizing vectors in A
!              (Workspace: need 4*M, prefer 3*M+M*NB)
!
               CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), &
                            WORK( IWORK ), LWORK-IWORK+1, IERR )
            END IF
            IWORK = IE + M
            IF( WNTUAS .OR. WNTUO ) &
               NRU = M
            IF( WNTUN ) &
               NRU = 0
            IF( WNTVAS .OR. WNTVO ) &
               NCVT = N
            IF( WNTVN ) &
               NCVT = 0
            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in U and computing right singular
!              vectors in VT
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, &
                            LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in U and computing right singular
!              vectors in A
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA, &
                            U, LDU, DUM, 1, WORK( IWORK ), INFO )
            ELSE
!
!              Perform bidiagonal QR iteration, if desired, computing
!              left singular vectors in A and computing right singular
!              vectors in VT
!              (Workspace: need BDSPAC)
!
               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT, &
                            LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
            END IF
!
         END IF
!
      END IF
!
!     If DBDSQR failed to converge, copy unconverged superdiagonals
!     to WORK( 2:MINMN )
!
      IF( INFO.NE.0 ) THEN
         IF( IE.GT.2 ) THEN
            DO 50 I = 1, MINMN - 1
               WORK( I+1 ) = WORK( I+IE-1 )
   50       CONTINUE
         END IF
         IF( IE.LT.2 ) THEN
            DO 60 I = MINMN - 1, 1, -1
               WORK( I+1 ) = WORK( I+IE-1 )
   60       CONTINUE
         END IF
      END IF
!
!     Undo scaling if necessary
!
      IF( ISCL.EQ.1 ) THEN
         IF( ANRM.GT.BIGNUM ) &
            CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, &
                         IERR )
         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) &
            CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ), &
                         MINMN, IERR )
         IF( ANRM.LT.SMLNUM ) &
            CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, &
                         IERR )
         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) &
            CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ), &
                         MINMN, IERR )
      END IF
!
!     Return optimal workspace in WORK(1)
!
      WORK( 1 ) = MAXWRK
!
      RETURN
!
!     End of DGESVD
!
      END
      SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, &
                         EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, TRANS
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), C( * ), FERR( * ), R( * ), &
                         WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGESVX uses the LU factorization to compute the solution to a real
!  system of linear equations
!     A * X = B,
!  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'E', real scaling factors are computed to equilibrate
!     the system:
!        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
!        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
!        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
!     Whether or not the system will be equilibrated depends on the
!     scaling of the matrix A, but if equilibration is used, A is
!     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
!     or diag(C)*B (if TRANS = 'T' or 'C').
!
!  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
!     matrix A (after equilibration if FACT = 'E') as
!        A = P * L * U,
!     where P is a permutation matrix, L is a unit lower triangular
!     matrix, and U is upper triangular.
!
!  3. If some U(i,i)=0, so that U is exactly singular, then the routine
!     returns with INFO = i. Otherwise, the factored form of A is used
!     to estimate the condition number of the matrix A.  If the
!     reciprocal of the condition number is less than machine precision,
!     INFO = N+1 is returned as a warning, but the routine still goes on
!     to solve for X and compute error bounds as described below.
!
!  4. The system of equations is solved for X using the factored form
!     of A.
!
!  5. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  6. If equilibration was used, the matrix X is premultiplied by
!     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
!     that it solves the original system before equilibration.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of the matrix A is
!          supplied on entry, and if not, whether the matrix A should be
!          equilibrated before it is factored.
!          = 'F':  On entry, AF and IPIV contain the factored form of A.
!                  If EQUED is not 'N', the matrix A has been
!                  equilibrated with scaling factors given by R and C.
!                  A, AF, and IPIV are not modified.
!          = 'N':  The matrix A will be copied to AF and factored.
!          = 'E':  The matrix A will be equilibrated if necessary, then
!                  copied to AF and factored.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Transpose)
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is
!          not 'N', then A must have been equilibrated by the scaling
!          factors in R and/or C.  A is not modified if FACT = 'F' or
!          'N', or if FACT = 'E' and EQUED = 'N' on exit.
!
!          On exit, if EQUED .ne. 'N', A is scaled as follows:
!          EQUED = 'R':  A := diag(R) * A
!          EQUED = 'C':  A := A * diag(C)
!          EQUED = 'B':  A := diag(R) * A * diag(C).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
!          If FACT = 'F', then AF is an input argument and on entry
!          contains the factors L and U from the factorization
!          A = P*L*U as computed by DGETRF.  If EQUED .ne. 'N', then
!          AF is the factored form of the equilibrated matrix A.
!
!          If FACT = 'N', then AF is an output argument and on exit
!          returns the factors L and U from the factorization A = P*L*U
!          of the original matrix A.
!
!          If FACT = 'E', then AF is an output argument and on exit
!          returns the factors L and U from the factorization A = P*L*U
!          of the equilibrated matrix A (see the description of A for
!          the form of the equilibrated matrix).
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  IPIV    (input or output) INTEGER array, dimension (N)
!          If FACT = 'F', then IPIV is an input argument and on entry
!          contains the pivot indices from the factorization A = P*L*U
!          as computed by DGETRF; row i of the matrix was interchanged
!          with row IPIV(i).
!
!          If FACT = 'N', then IPIV is an output argument and on exit
!          contains the pivot indices from the factorization A = P*L*U
!          of the original matrix A.
!
!          If FACT = 'E', then IPIV is an output argument and on exit
!          contains the pivot indices from the factorization A = P*L*U
!          of the equilibrated matrix A.
!
!  EQUED   (input or output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration (always true if FACT = 'N').
!          = 'R':  Row equilibration, i.e., A has been premultiplied by
!                  diag(R).
!          = 'C':  Column equilibration, i.e., A has been postmultiplied
!                  by diag(C).
!          = 'B':  Both row and column equilibration, i.e., A has been
!                  replaced by diag(R) * A * diag(C).
!          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!          output argument.
!
!  R       (input or output) DOUBLE PRECISION array, dimension (N)
!          The row scale factors for A.  If EQUED = 'R' or 'B', A is
!          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
!          is not accessed.  R is an input argument if FACT = 'F';
!          otherwise, R is an output argument.  If FACT = 'F' and
!          EQUED = 'R' or 'B', each element of R must be positive.
!
!  C       (input or output) DOUBLE PRECISION array, dimension (N)
!          The column scale factors for A.  If EQUED = 'C' or 'B', A is
!          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
!          is not accessed.  C is an input argument if FACT = 'F';
!          otherwise, C is an output argument.  If FACT = 'F' and
!          EQUED = 'C' or 'B', each element of C must be positive.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit,
!          if EQUED = 'N', B is not modified;
!          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
!          diag(R)*B;
!          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
!          overwritten by diag(C)*B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
!          to the original system of equations.  Note that A and B are
!          modified on exit if EQUED .ne. 'N', and the solution to the
!          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
!          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
!          and EQUED = 'R' or 'B'.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A after equilibration (if done).  If RCOND is less than the
!          machine precision (in particular, if RCOND = 0), the matrix
!          is singular to working precision.  This condition is
!          indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (4*N)
!          On exit, WORK(1) contains the reciprocal pivot growth
!          factor norm(A)/norm(U). The "max absolute element" norm is
!          used. If WORK(1) is much less than 1, then the stability
!          of the LU factorization of the (equilibrated) matrix A
!          could be poor. This also means that the solution X, condition
!          estimator RCOND, and forward error bound FERR could be
!          unreliable. If factorization fails with 0<INFO<=N, then
!          WORK(1) contains the reciprocal pivot growth factor for the
!          leading INFO columns of A.
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  U(i,i) is exactly zero.  The factorization has
!                       been completed, but the factor U is exactly
!                       singular, so the solution and error bounds
!                       could not be computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
      CHARACTER          NORM
      INTEGER            I, INFEQU, J
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, &
                         ROWCND, RPVGRW, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANTR
      EXTERNAL           LSAME, DLAMCH, DLANGE, DLANTR
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, &
                         DLAQGE, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         ROWEQU = .FALSE.
         COLEQU = .FALSE.
      ELSE
         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
!
!     Test the input parameters.
!
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. &
               ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -10
      ELSE
         IF( ROWEQU ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO 10 J = 1, N
               RCMIN = MIN( RCMIN, R( J ) )
               RCMAX = MAX( RCMAX, R( J ) )
   10       CONTINUE
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -11
            ELSE IF( N.GT.0 ) THEN
               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               ROWCND = ONE
            END IF
         END IF
         IF( COLEQU .AND. INFO.EQ.0 ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO 20 J = 1, N
               RCMIN = MIN( RCMIN, C( J ) )
               RCMAX = MAX( RCMAX, C( J ) )
   20       CONTINUE
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -12
            ELSE IF( N.GT.0 ) THEN
               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               COLCND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -14
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -16
            END IF
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGESVX', -INFO )
         RETURN
      END IF
!
      IF( EQUIL ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, &
                         EQUED )
            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         END IF
      END IF
!
!     Scale the right hand side.
!
      IF( NOTRAN ) THEN
         IF( ROWEQU ) THEN
            DO 40 J = 1, NRHS
               DO 30 I = 1, N
                  B( I, J ) = R( I )*B( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE IF( COLEQU ) THEN
         DO 60 J = 1, NRHS
            DO 50 I = 1, N
               B( I, J ) = C( I )*B( I, J )
   50       CONTINUE
   60    CONTINUE
      END IF
!
      IF( NOFACT .OR. EQUIL ) THEN
!
!        Compute the LU factorization of A.
!
         CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
         CALL DGETRF( N, N, AF, LDAF, IPIV, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) THEN
!
!              Compute the reciprocal pivot growth factor of the
!              leading rank-deficient INFO columns of A.
!
               RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, &
                        WORK )
               IF( RPVGRW.EQ.ZERO ) THEN
                  RPVGRW = ONE
               ELSE
                  RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
               END IF
               WORK( 1 ) = RPVGRW
               RCOND = ZERO
            END IF
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A and the
!     reciprocal pivot growth factor RPVGRW.
!
      IF( NOTRAN ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
      ANORM = DLANGE( NORM, N, N, A, LDA, WORK )
      RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
      IF( RPVGRW.EQ.ZERO ) THEN
         RPVGRW = ONE
      ELSE
         RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
      END IF
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution matrix X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, &
                   LDX, FERR, BERR, WORK, IWORK, INFO )
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF( NOTRAN ) THEN
         IF( COLEQU ) THEN
            DO 80 J = 1, NRHS
               DO 70 I = 1, N
                  X( I, J ) = C( I )*X( I, J )
   70          CONTINUE
   80       CONTINUE
            DO 90 J = 1, NRHS
               FERR( J ) = FERR( J ) / COLCND
   90       CONTINUE
         END IF
      ELSE IF( ROWEQU ) THEN
         DO 110 J = 1, NRHS
            DO 100 I = 1, N
               X( I, J ) = R( I )*X( I, J )
  100       CONTINUE
  110    CONTINUE
         DO 120 J = 1, NRHS
            FERR( J ) = FERR( J ) / ROWCND
  120    CONTINUE
      END IF
!
      WORK( 1 ) = RPVGRW
      RETURN
!
!     End of DGESVX
!
      END
      SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETC2 computes an LU factorization with complete pivoting of the
!  n-by-n matrix A. The factorization has the form A = P * L * U * Q,
!  where P and Q are permutation matrices, L is lower triangular with
!  unit diagonal elements and U is upper triangular.
!
!  This is the Level 2 BLAS algorithm.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the n-by-n matrix A to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U*Q; the unit diagonal elements of L are not stored.
!          If U(k, k) appears to be less than SMIN, U(k, k) is given the
!          value of SMIN, i.e., giving a nonsingular perturbed system.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension(N).
!          The pivot indices; for 1 <= i <= N, row i of the
!          matrix has been interchanged with row IPIV(i).
!
!  JPIV    (output) INTEGER array, dimension(N).
!          The pivot indices; for 1 <= j <= N, column j of the
!          matrix has been interchanged with column JPIV(j).
!
!  INFO    (output) INTEGER
!           = 0: successful exit
!           > 0: if INFO = k, U(k, k) is likely to produce owerflow if
!                we try to solve for x in Ax = b. So U is perturbed to
!                avoid the overflow.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IP, IPV, J, JP, JPV
      DOUBLE PRECISION   BIGNUM, EPS, SMIN, SMLNUM, XMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DSWAP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Set constants to control overflow
!
      INFO = 0
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Factorize A using complete pivoting.
!     Set pivots less than SMIN to SMIN.
!
      DO 40 I = 1, N - 1
!
!        Find max element in matrix A
!
         XMAX = ZERO
         DO 20 IP = I, N
            DO 10 JP = I, N
               IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
                  XMAX = ABS( A( IP, JP ) )
                  IPV = IP
                  JPV = JP
               END IF
   10       CONTINUE
   20    CONTINUE
         IF( I.EQ.1 ) &
            SMIN = MAX( EPS*XMAX, SMLNUM )
!
!        Swap rows
!
         IF( IPV.NE.I ) &
            CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
         IPIV( I ) = IPV
!
!        Swap columns
!
         IF( JPV.NE.I ) &
            CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
         JPIV( I ) = JPV
!
!        Check for singularity
!
         IF( ABS( A( I, I ) ).LT.SMIN ) THEN
            INFO = I
            A( I, I ) = SMIN
         END IF
         DO 30 J = I + 1, N
            A( J, I ) = A( J, I ) / A( I, I )
   30    CONTINUE
         CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA, &
                    A( I+1, I+1 ), LDA )
   40 CONTINUE
!
      IF( ABS( A( N, N ) ).LT.SMIN ) THEN
         INFO = N
         A( N, N ) = SMIN
      END IF
!
      RETURN
!
!     End of DGETC2
!
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J ) &
               CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M ) &
               CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, &
                       A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of DGETF2
!
      END
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 ) &
               INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, &
                            IPIV, 1 )
!
!              Compute block row of U.
!
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &
                           N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &
                           LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, &
                              N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, &
                              A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), &
                              LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DGETRF
!
      END
      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRI computes the inverse of a matrix using the LU factorization
!  computed by DGETRF.
!
!  This method inverts U and then computes inv(A) by solving the system
!  inv(A)*L = inv(U) for inv(A).
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the factors L and U from the factorization
!          A = P*L*U as computed by DGETRF.
!          On exit, if INFO = 0, the inverse of the original matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,N).
!          For optimal performance LWORK >= N*NB, where NB is
!          the optimal blocksize returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
!                singular and its inverse could not be computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, &
                         NBMIN, NN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      LWKOPT = N*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
!     and the inverse is not computed.
!
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 ) &
         RETURN
!
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
!
!     Solve the equation inv(A)*L = inv(U) for inv(A).
!
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
!
!        Use unblocked code.
!
         DO 20 J = N, 1, -1
!
!           Copy current column of L to WORK and replace with zeros.
!
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
!
!           Compute current column of inv(A).
!
            IF( J.LT.N ) &
               CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), &
                           LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
!
!        Use blocked code.
!
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
!
!           Copy current block column of L to WORK and replace with
!           zeros.
!
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
!
!           Compute current block column of inv(A).
!
            IF( J+JB.LE.N ) &
               CALL DGEMM( 'No transpose', 'No transpose', N, JB, &
                           N-J-JB+1, -ONE, A( 1, J+JB ), LDA, &
                           WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, &
                        ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
!
!     Apply column interchanges.
!
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J ) &
            CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DGETRI
!
      END
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRS solves a system of linear equations
!     A * X = B  or  A' * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by DGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A'* X = B  (Transpose)
!          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by DGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
          LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, &
                     ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, &
                     NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A' * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, &
                     ONE, A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, &
                     A, LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of DGETRS
!
      END
      SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, &
                         LDV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOB, SIDE
      INTEGER            IHI, ILO, INFO, LDV, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), V( LDV, * )
!     ..
!
!  Purpose
!  =======
!
!  DGGBAK forms the right or left eigenvectors of a real generalized
!  eigenvalue problem A*x = lambda*B*x, by backward transformation on
!  the computed eigenvectors of the balanced pair of matrices output by
!  DGGBAL.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies the type of backward transformation required:
!          = 'N':  do nothing, return immediately;
!          = 'P':  do backward transformation for permutation only;
!          = 'S':  do backward transformation for scaling only;
!          = 'B':  do backward transformations for both permutation and
!                  scaling.
!          JOB must be the same as the argument JOB supplied to DGGBAL.
!
!  SIDE    (input) CHARACTER*1
!          = 'R':  V contains right eigenvectors;
!          = 'L':  V contains left eigenvectors.
!
!  N       (input) INTEGER
!          The number of rows of the matrix V.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          The integers ILO and IHI determined by DGGBAL.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  LSCALE  (input) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and/or scaling factors applied
!          to the left side of A and B, as returned by DGGBAL.
!
!  RSCALE  (input) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and/or scaling factors applied
!          to the right side of A and B, as returned by DGGBAL.
!
!  M       (input) INTEGER
!          The number of columns of the matrix V.  M >= 0.
!
!  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)
!          On entry, the matrix of right or left eigenvectors to be
!          transformed, as returned by DTGEVC.
!          On exit, V is overwritten by the transformed eigenvectors.
!
!  LDV     (input) INTEGER
!          The leading dimension of the matrix V. LDV >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  See R.C. Ward, Balancing the generalized eigenvalue problem,
!                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LEFTV, RIGHTV
      INTEGER            I, K
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      RIGHTV = LSAME( SIDE, 'R' )
      LEFTV = LSAME( SIDE, 'L' )
!
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. &
          .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -4
      ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGBAK', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
      IF( M.EQ.0 ) &
         RETURN
      IF( LSAME( JOB, 'N' ) ) &
         RETURN
!
      IF( ILO.EQ.IHI ) &
         GO TO 30
!
!     Backward balance
!
      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
!
!        Backward transformation on right eigenvectors
!
         IF( RIGHTV ) THEN
            DO 10 I = ILO, IHI
               CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
   10       CONTINUE
         END IF
!
!        Backward transformation on left eigenvectors
!
         IF( LEFTV ) THEN
            DO 20 I = ILO, IHI
               CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
   20       CONTINUE
         END IF
      END IF
!
!     Backward permutation
!
   30 CONTINUE
      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
!
!        Backward permutation on right eigenvectors
!
         IF( RIGHTV ) THEN
            IF( ILO.EQ.1 ) &
               GO TO 50
!
            DO 40 I = ILO - 1, 1, -1
               K = RSCALE( I )
               IF( K.EQ.I ) &
                  GO TO 40
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   40       CONTINUE
!
   50       CONTINUE
            IF( IHI.EQ.N ) &
               GO TO 70
            DO 60 I = IHI + 1, N
               K = RSCALE( I )
               IF( K.EQ.I ) &
                  GO TO 60
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   60       CONTINUE
         END IF
!
!        Backward permutation on left eigenvectors
!
   70    CONTINUE
         IF( LEFTV ) THEN
            IF( ILO.EQ.1 ) &
               GO TO 90
            DO 80 I = ILO - 1, 1, -1
               K = LSCALE( I )
               IF( K.EQ.I ) &
                  GO TO 80
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
   80       CONTINUE
!
   90       CONTINUE
            IF( IHI.EQ.N ) &
               GO TO 110
            DO 100 I = IHI + 1, N
               K = LSCALE( I )
               IF( K.EQ.I ) &
                  GO TO 100
               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
  100       CONTINUE
         END IF
      END IF
!
  110 CONTINUE
!
      RETURN
!
!     End of DGGBAK
!
      END
      SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, &
                         RSCALE, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), LSCALE( * ), &
                         RSCALE( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGBAL balances a pair of general real matrices (A,B).  This
!  involves, first, permuting A and B by similarity transformations to
!  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
!  elements on the diagonal; and second, applying a diagonal similarity
!  transformation to rows and columns ILO to IHI to make the rows
!  and columns as close in norm as possible. Both steps are optional.
!
!  Balancing may reduce the 1-norm of the matrices, and improve the
!  accuracy of the computed eigenvalues and/or eigenvectors in the
!  generalized eigenvalue problem A*x = lambda*B*x.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies the operations to be performed on A and B:
!          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
!                  and RSCALE(I) = 1.0 for i = 1,...,N.
!          = 'P':  permute only;
!          = 'S':  scale only;
!          = 'B':  both permute and scale.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the input matrix A.
!          On exit,  A is overwritten by the balanced matrix.
!          If JOB = 'N', A is not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the input matrix B.
!          On exit,  B is overwritten by the balanced matrix.
!          If JOB = 'N', B is not referenced.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  ILO     (output) INTEGER
!  IHI     (output) INTEGER
!          ILO and IHI are set to integers such that on exit
!          A(i,j) = 0 and B(i,j) = 0 if i > j and
!          j = 1,...,ILO-1 or i = IHI+1,...,N.
!          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!
!  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied
!          to the left side of A and B.  If P(j) is the index of the
!          row interchanged with row j, and D(j)
!          is the scaling factor applied to row j, then
!            LSCALE(j) = P(j)    for J = 1,...,ILO-1
!                      = D(j)    for J = ILO,...,IHI
!                      = P(j)    for J = IHI+1,...,N.
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied
!          to the right side of A and B.  If P(j) is the index of the
!          column interchanged with column j, and D(j)
!          is the scaling factor applied to column j, then
!            LSCALE(j) = P(j)    for J = 1,...,ILO-1
!                      = D(j)    for J = ILO,...,IHI
!                      = P(j)    for J = IHI+1,...,N.
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  See R.C. WARD, Balancing the generalized eigenvalue problem,
!                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   THREE, SCLFAC
      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, &
                         K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, &
                         M, NR, NRP2
      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, &
                         COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, &
                         SFMIN, SUM, T, TA, TB, TC
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. &
          .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGBAL', -INFO )
         RETURN
      END IF
!
      K = 1
      L = N
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( LSAME( JOB, 'N' ) ) THEN
         ILO = 1
         IHI = N
         DO 10 I = 1, N
            LSCALE( I ) = ONE
            RSCALE( I ) = ONE
   10    CONTINUE
         RETURN
      END IF
!
      IF( K.EQ.L ) THEN
         ILO = 1
         IHI = 1
         LSCALE( 1 ) = ONE
         RSCALE( 1 ) = ONE
         RETURN
      END IF
!
      IF( LSAME( JOB, 'S' ) ) &
         GO TO 190
!
      GO TO 30
!
!     Permute the matrices A and B to isolate the eigenvalues.
!
!     Find row with one nonzero in columns 1 through L
!
   20 CONTINUE
      L = LM1
      IF( L.NE.1 ) &
         GO TO 30
!
      RSCALE( 1 ) = 1
      LSCALE( 1 ) = 1
      GO TO 190
!
   30 CONTINUE
      LM1 = L - 1
      DO 80 I = L, 1, -1
         DO 40 J = 1, LM1
            JP1 = J + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) &
               GO TO 50
   40    CONTINUE
         J = L
         GO TO 70
!
   50    CONTINUE
         DO 60 J = JP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) &
               GO TO 80
   60    CONTINUE
         J = JP1 - 1
!
   70    CONTINUE
         M = L
         IFLOW = 1
         GO TO 160
   80 CONTINUE
      GO TO 100
!
!     Find column with one nonzero in rows K through N
!
   90 CONTINUE
      K = K + 1
!
  100 CONTINUE
      DO 150 J = K, L
         DO 110 I = K, LM1
            IP1 = I + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) &
               GO TO 120
  110    CONTINUE
         I = L
         GO TO 140
  120    CONTINUE
         DO 130 I = IP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO ) &
               GO TO 150
  130    CONTINUE
         I = IP1 - 1
  140    CONTINUE
         M = K
         IFLOW = 2
         GO TO 160
  150 CONTINUE
      GO TO 190
!
!     Permute rows M and I
!
  160 CONTINUE
      LSCALE( M ) = I
      IF( I.EQ.M ) &
         GO TO 170
      CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
      CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
!
!     Permute columns M and J
!
  170 CONTINUE
      RSCALE( M ) = J
      IF( J.EQ.M ) &
         GO TO 180
      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
      CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
!
  180 CONTINUE
      GO TO ( 20, 90 )IFLOW
!
  190 CONTINUE
      ILO = K
      IHI = L
!
      IF( ILO.EQ.IHI ) &
         RETURN
!
      IF( LSAME( JOB, 'P' ) ) &
         RETURN
!
!     Balance the submatrix in rows ILO to IHI.
!
      NR = IHI - ILO + 1
      DO 200 I = ILO, IHI
         RSCALE( I ) = ZERO
         LSCALE( I ) = ZERO
!
         WORK( I ) = ZERO
         WORK( I+N ) = ZERO
         WORK( I+2*N ) = ZERO
         WORK( I+3*N ) = ZERO
         WORK( I+4*N ) = ZERO
         WORK( I+5*N ) = ZERO
  200 CONTINUE
!
!     Compute right side vector in resulting linear equations
!
      BASL = LOG10( SCLFAC )
      DO 240 I = ILO, IHI
         DO 230 J = ILO, IHI
            TB = B( I, J )
            TA = A( I, J )
            IF( TA.EQ.ZERO ) &
               GO TO 210
            TA = LOG10( ABS( TA ) ) / BASL
  210       CONTINUE
            IF( TB.EQ.ZERO ) &
               GO TO 220
            TB = LOG10( ABS( TB ) ) / BASL
  220       CONTINUE
            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
  230    CONTINUE
  240 CONTINUE
!
      COEF = ONE / DBLE( 2*NR )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2 = NR + 2
      BETA = ZERO
      IT = 1
!
!     Start generalized conjugate gradient iteration
!
  250 CONTINUE
!
      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + &
              DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
!
      EW = ZERO
      EWC = ZERO
      DO 260 I = ILO, IHI
         EW = EW + WORK( I+4*N )
         EWC = EWC + WORK( I+5*N )
  260 CONTINUE
!
      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
      IF( GAMMA.EQ.ZERO ) &
         GO TO 350
      IF( IT.NE.1 ) &
         BETA = GAMMA / PGAMMA
      T = COEF5*( EWC-THREE*EW )
      TC = COEF5*( EW-THREE*EWC )
!
      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
!
      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
!
      DO 270 I = ILO, IHI
         WORK( I ) = WORK( I ) + TC
         WORK( I+N ) = WORK( I+N ) + T
  270 CONTINUE
!
!     Apply matrix to vector
!
      DO 300 I = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 290 J = ILO, IHI
            IF( A( I, J ).EQ.ZERO ) &
               GO TO 280
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  280       CONTINUE
            IF( B( I, J ).EQ.ZERO ) &
               GO TO 290
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  290    CONTINUE
         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
  300 CONTINUE
!
      DO 330 J = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 320 I = ILO, IHI
            IF( A( I, J ).EQ.ZERO ) &
               GO TO 310
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  310       CONTINUE
            IF( B( I, J ).EQ.ZERO ) &
               GO TO 320
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  320    CONTINUE
         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
  330 CONTINUE
!
      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + &
            DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
      ALPHA = GAMMA / SUM
!
!     Determine correction to current iteration
!
      CMAX = ZERO
      DO 340 I = ILO, IHI
         COR = ALPHA*WORK( I+N )
         IF( ABS( COR ).GT.CMAX ) &
            CMAX = ABS( COR )
         LSCALE( I ) = LSCALE( I ) + COR
         COR = ALPHA*WORK( I )
         IF( ABS( COR ).GT.CMAX ) &
            CMAX = ABS( COR )
         RSCALE( I ) = RSCALE( I ) + COR
  340 CONTINUE
      IF( CMAX.LT.HALF ) &
         GO TO 350
!
      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
!
      PGAMMA = GAMMA
      IT = IT + 1
      IF( IT.LE.NRP2 ) &
         GO TO 250
!
!     End generalized conjugate gradient iteration
!
  350 CONTINUE
      SFMIN = DLAMCH( 'S' )
      SFMAX = ONE / SFMIN
      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
      DO 360 I = ILO, IHI
         IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
         RAB = ABS( A( I, IRAB+ILO-1 ) )
         IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA )
         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
         LSCALE( I ) = SCLFAC**IR
         ICAB = IDAMAX( IHI, A( 1, I ), 1 )
         CAB = ABS( A( ICAB, I ) )
         ICAB = IDAMAX( IHI, B( 1, I ), 1 )
         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
         JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
         RSCALE( I ) = SCLFAC**JC
  360 CONTINUE
!
!     Row scaling of matrices A and B
!
      DO 370 I = ILO, IHI
         CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
         CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
  370 CONTINUE
!
!     Column scaling of matrices A and B
!
      DO 380 J = ILO, IHI
         CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
         CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
  380 CONTINUE
!
      RETURN
!
!     End of DGGBAL
!
      END
      SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, DELCTG, N, A, LDA, B, LDB, &
                        SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, &
                        LDVSR, WORK, LWORK, BWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVSL, JOBVSR, SORT
      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
!     ..
!     .. Array Arguments ..
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), VSL( LDVSL, * ), &
                         VSR( LDVSR, * ), WORK( * )
!     ..
!     .. Function Arguments ..
      LOGICAL            DELCTG
      EXTERNAL           DELCTG
!     ..
!
!  Purpose
!  =======
!
!  DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
!  the generalized eigenvalues, the generalized real Schur form (S,T),
!  optionally, the left and/or right matrices of Schur vectors (VSL and
!  VSR). This gives the generalized Schur factorization
!
!           (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
!
!  Optionally, it also orders the eigenvalues so that a selected cluster
!  of eigenvalues appears in the leading diagonal blocks of the upper
!  quasi-triangular matrix S and the upper triangular matrix T.The
!  leading columns of VSL and VSR then form an orthonormal basis for the
!  corresponding left and right eigenspaces (deflating subspaces).
!
!  (If only the generalized eigenvalues are needed, use the driver
!  DGGEV instead, which is faster.)
!
!  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
!  usually represented as the pair (alpha,beta), as there is a
!  reasonable interpretation for beta=0 or both being zero.
!
!  A pair of matrices (S,T) is in generalized real Schur form if T is
!  upper triangular with non-negative diagonal and S is block upper
!  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
!  to real generalized eigenvalues, while 2-by-2 blocks of S will be
!  "standardized" by making the corresponding elements of T have the
!  form:
!          [  a  0  ]
!          [  0  b  ]
!
!  and the pair of corresponding 2-by-2 blocks in S and T will have a
!  complex conjugate pair of generalized eigenvalues.
!
!
!  Arguments
!  =========
!
!  JOBVSL  (input) CHARACTER*1
!          = 'N':  do not compute the left Schur vectors;
!          = 'V':  compute the left Schur vectors.
!
!  JOBVSR  (input) CHARACTER*1
!          = 'N':  do not compute the right Schur vectors;
!          = 'V':  compute the right Schur vectors.
!
!  SORT    (input) CHARACTER*1
!          Specifies whether or not to order the eigenvalues on the
!          diagonal of the generalized Schur form.
!          = 'N':  Eigenvalues are not ordered;
!          = 'S':  Eigenvalues are ordered (see DELZTG);
!
!  DELZTG  (input) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
!          DELZTG must be declared EXTERNAL in the calling subroutine.
!          If SORT = 'N', DELZTG is not referenced.
!          If SORT = 'S', DELZTG is used to select eigenvalues to sort
!          to the top left of the Schur form.
!          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
!          DELZTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
!          one of a complex conjugate pair of eigenvalues is selected,
!          then both complex eigenvalues are selected.
!
!          Note that in the ill-conditioned case, a selected complex
!          eigenvalue may no longer satisfy DELZTG(ALPHAR(j),ALPHAI(j),
!          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
!          in this case.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the first of the pair of matrices.
!          On exit, A has been overwritten by its generalized Schur
!          form S.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the second of the pair of matrices.
!          On exit, B has been overwritten by its generalized Schur
!          form T.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  SDIM    (output) INTEGER
!          If SORT = 'N', SDIM = 0.
!          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!          for which DELZTG is true.  (Complex conjugate pairs for which
!          DELZTG is true for either eigenvalue count as 2.)
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,
!          and  BETA(j),j=1,...,N are the diagonals of the complex Schur
!          form (S,T) that would result if the 2-by-2 diagonal blocks of
!          the real Schur form of (A,B) were further reduced to
!          triangular form using 2-by-2 complex unitary transformations.
!          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
!          positive, then the j-th and (j+1)-st eigenvalues are a
!          complex conjugate pair, with ALPHAI(j+1) negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio.
!          However, ALPHAR and ALPHAI will be always less than and
!          usually comparable with norm(A) in magnitude, and BETA always
!          less than and usually comparable with norm(B).
!
!  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)
!          If JOBVSL = 'V', VSL will contain the left Schur vectors.
!          Not referenced if JOBVSL = 'N'.
!
!  LDVSL   (input) INTEGER
!          The leading dimension of the matrix VSL. LDVSL >=1, and
!          if JOBVSL = 'V', LDVSL >= N.
!
!  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)
!          If JOBVSR = 'V', VSR will contain the right Schur vectors.
!          Not referenced if JOBVSR = 'N'.
!
!  LDVSR   (input) INTEGER
!          The leading dimension of the matrix VSR. LDVSR >= 1, and
!          if JOBVSR = 'V', LDVSR >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= 8*N+16.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  BWORK   (workspace) LOGICAL array, dimension (N)
!          Not referenced if SORT = 'N'.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  (A,B) are not in Schur
!                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
!                be correct for j=INFO+1,...,N.
!          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
!                =N+2: after reordering, roundoff changed values of
!                      some complex eigenvalues so that leading
!                      eigenvalues in the Generalized Schur form no
!                      longer satisfy DELZTG=.TRUE.  This could also
!                      be caused due to scaling.
!                =N+3: reordering failed in DTGSEN.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, &
                         LQUERY, LST2SL, WANTST
      INTEGER            I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, &
                         ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK, &
                         MINWRK
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL, &
                         PVSR, SAFMAX, SAFMIN, SMLNUM
!     ..
!     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DIF( 2 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, &
                         DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVSL, 'N' ) ) THEN
         IJOBVL = 1
         ILVSL = .FALSE.
      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
         IJOBVL = 2
         ILVSL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVSL = .FALSE.
      END IF
!
      IF( LSAME( JOBVSR, 'N' ) ) THEN
         IJOBVR = 1
         ILVSR = .FALSE.
      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
         IJOBVR = 2
         ILVSR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVSR = .FALSE.
      END IF
!
      WANTST = LSAME( SORT, 'S' )
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
         INFO = -17
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MINWRK = 7*( N+1 ) + 16
         MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + &
                  16
         IF( ILVSL ) THEN
            MAXWRK = MAX( MAXWRK, 7*( N+1 )+N* &
                     ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
!
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) &
         INFO = -19
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGES ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SQRT( SAFMIN ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL ) &
         CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
      IF( ILBSCL ) &
         CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
!
!     Permute the matrix to make it more nearly triangular
!     (Workspace: need 6*N + 2*N space for storing balancing factors)
!
      ILEFT = 1
      IRIGHT = N + 1
      IWRK = IRIGHT + N
      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), &
                   WORK( IRIGHT ), WORK( IWRK ), IERR )
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Workspace: need N, prefer N*NB)
!
      IROWS = IHI + 1 - ILO
      ICOLS = N + 1 - ILO
      ITAU = IWRK
      IWRK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
!
!     Apply the orthogonal transformation to matrix A
!     (Workspace: need N, prefer N*NB)
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), &
                   LWORK+1-IWRK, IERR )
!
!     Initialize VSL
!     (Workspace: need N, prefer N*NB)
!
      IF( ILVSL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VSL( ILO+1, ILO ), LDVSL )
         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, &
                      WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
      END IF
!
!     Initialize VSR
!
      IF( ILVSR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, &
                   LDVSL, VSR, LDVSR, IERR )
!
!     Perform QZ algorithm, computing Schur vectors if desired
!     (Workspace: need N)
!
      IWRK = ITAU
      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
            INFO = IERR
         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
            INFO = IERR - N
         ELSE
            INFO = N + 1
         END IF
         GO TO 50
      END IF
!
!     Sort eigenvalues ALPHA/BETA if desired
!     (Workspace: need 4*N+16 )
!
      SDIM = 0
      IF( WANTST ) THEN
!
!        Undo scaling on eigenvalues before DELZTGing
!
         IF( ILASCL ) THEN
            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, &
                         IERR )
            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, &
                         IERR )
         END IF
         IF( ILBSCL ) &
            CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
!
!        Select eigenvalues
!
         DO 10 I = 1, N
            BWORK( I ) = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
   10    CONTINUE
!
         CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR, &
                      ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, &
                      PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, &
                      IERR )
         IF( IERR.EQ.1 ) &
            INFO = N + 3
!
      END IF
!
!     Apply back-permutation to VSL and VSR
!     (Workspace: none needed)
!
      IF( ILVSL ) &
         CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSL, LDVSL, IERR )
!
      IF( ILVSR ) &
         CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSR, LDVSR, IERR )
!
!     Check if unscaling would cause over/underflow, if so, rescale
!     (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
!     B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
!
      IF( ILASCL ) THEN
         DO 20 I = 1, N
            IF( ALPHAI( I ).NE.ZERO ) THEN
               IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. &
                   ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
                  WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. &
                        ( ANRMTO / ANRM ) .OR. &
                        ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) &
                         THEN
                  WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               END IF
            END IF
   20    CONTINUE
      END IF
!
      IF( ILBSCL ) THEN
         DO 30 I = 1, N
            IF( ALPHAI( I ).NE.ZERO ) THEN
               IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. &
                   ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
                  WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               END IF
            END IF
   30    CONTINUE
      END IF
!
!     Undo scaling
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
      END IF
!
      IF( WANTST ) THEN
!
!        Check if reordering is correct
!
         LASTSL = .TRUE.
         LST2SL = .TRUE.
         SDIM = 0
         IP = 0
         DO 40 I = 1, N
            CURSL = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
            IF( ALPHAI( I ).EQ.ZERO ) THEN
               IF( CURSL ) &
                  SDIM = SDIM + 1
               IP = 0
               IF( CURSL .AND. .NOT.LASTSL ) &
                  INFO = N + 2
            ELSE
               IF( IP.EQ.1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
                  CURSL = CURSL .OR. LASTSL
                  LASTSL = CURSL
                  IF( CURSL ) &
                     SDIM = SDIM + 2
                  IP = -1
                  IF( CURSL .AND. .NOT.LST2SL ) &
                     INFO = N + 2
               ELSE
!
!                 First eigenvalue of conjugate pair
!
                  IP = 1
               END IF
            END IF
            LST2SL = LASTSL
            LASTSL = CURSL
   40    CONTINUE
!
      END IF
!
   50 CONTINUE
!
      WORK( 1 ) = MAXWRK
!
      RETURN
!
!     End of DGGES
!
      END
      SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, DELCTG, SENSE, N, A, LDA, &
                         B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, &
                         VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, &
                         LIWORK, BWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVSL, JOBVSR, SENSE, SORT
      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N, &
                         SDIM
!     ..
!     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), RCONDE( 2 ), &
                         RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ), &
                         WORK( * )
!     ..
!     .. Function Arguments ..
      LOGICAL            DELCTG
      EXTERNAL           DELCTG
!     ..
!
!  Purpose
!  =======
!
!  DGGESX computes for a pair of N-by-N real nonsymmetric matrices
!  (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
!  optionally, the left and/or right matrices of Schur vectors (VSL and
!  VSR).  This gives the generalized Schur factorization
!
!       (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
!
!  Optionally, it also orders the eigenvalues so that a selected cluster
!  of eigenvalues appears in the leading diagonal blocks of the upper
!  quasi-triangular matrix S and the upper triangular matrix T; computes
!  a reciprocal condition number for the average of the selected
!  eigenvalues (RCONDE); and computes a reciprocal condition number for
!  the right and left deflating subspaces corresponding to the selected
!  eigenvalues (RCONDV). The leading columns of VSL and VSR then form
!  an orthonormal basis for the corresponding left and right eigenspaces
!  (deflating subspaces).
!
!  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
!  usually represented as the pair (alpha,beta), as there is a
!  reasonable interpretation for beta=0 or for both being zero.
!
!  A pair of matrices (S,T) is in generalized real Schur form if T is
!  upper triangular with non-negative diagonal and S is block upper
!  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
!  to real generalized eigenvalues, while 2-by-2 blocks of S will be
!  "standardized" by making the corresponding elements of T have the
!  form:
!          [  a  0  ]
!          [  0  b  ]
!
!  and the pair of corresponding 2-by-2 blocks in S and T will have a
!  complex conjugate pair of generalized eigenvalues.
!
!
!  Arguments
!  =========
!
!  JOBVSL  (input) CHARACTER*1
!          = 'N':  do not compute the left Schur vectors;
!          = 'V':  compute the left Schur vectors.
!
!  JOBVSR  (input) CHARACTER*1
!          = 'N':  do not compute the right Schur vectors;
!          = 'V':  compute the right Schur vectors.
!
!  SORT    (input) CHARACTER*1
!          Specifies whether or not to order the eigenvalues on the
!          diagonal of the generalized Schur form.
!          = 'N':  Eigenvalues are not ordered;
!          = 'S':  Eigenvalues are ordered (see DELZTG).
!
!  DELZTG  (input) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
!          DELZTG must be declared EXTERNAL in the calling subroutine.
!          If SORT = 'N', DELZTG is not referenced.
!          If SORT = 'S', DELZTG is used to select eigenvalues to sort
!          to the top left of the Schur form.
!          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
!          DELZTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
!          one of a complex conjugate pair of eigenvalues is selected,
!          then both complex eigenvalues are selected.
!          Note that a selected complex eigenvalue may no longer satisfy
!          DELZTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
!          since ordering may change the value of complex eigenvalues
!          (especially if the eigenvalue is ill-conditioned), in this
!          case INFO is set to N+3.
!
!  SENSE   (input) CHARACTER
!          Determines which reciprocal condition numbers are computed.
!          = 'N' : None are computed;
!          = 'E' : Computed for average of selected eigenvalues only;
!          = 'V' : Computed for selected deflating subspaces only;
!          = 'B' : Computed for both.
!          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the first of the pair of matrices.
!          On exit, A has been overwritten by its generalized Schur
!          form S.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the second of the pair of matrices.
!          On exit, B has been overwritten by its generalized Schur
!          form T.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  SDIM    (output) INTEGER
!          If SORT = 'N', SDIM = 0.
!          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!          for which DELZTG is true.  (Complex conjugate pairs for which
!          DELZTG is true for either eigenvalue count as 2.)
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
!          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
!          form (S,T) that would result if the 2-by-2 diagonal blocks of
!          the real Schur form of (A,B) were further reduced to
!          triangular form using 2-by-2 complex unitary transformations.
!          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
!          positive, then the j-th and (j+1)-st eigenvalues are a
!          complex conjugate pair, with ALPHAI(j+1) negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio.
!          However, ALPHAR and ALPHAI will be always less than and
!          usually comparable with norm(A) in magnitude, and BETA always
!          less than and usually comparable with norm(B).
!
!  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)
!          If JOBVSL = 'V', VSL will contain the left Schur vectors.
!          Not referenced if JOBVSL = 'N'.
!
!  LDVSL   (input) INTEGER
!          The leading dimension of the matrix VSL. LDVSL >=1, and
!          if JOBVSL = 'V', LDVSL >= N.
!
!  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)
!          If JOBVSR = 'V', VSR will contain the right Schur vectors.
!          Not referenced if JOBVSR = 'N'.
!
!  LDVSR   (input) INTEGER
!          The leading dimension of the matrix VSR. LDVSR >= 1, and
!          if JOBVSR = 'V', LDVSR >= N.
!
!  RCONDE  (output) DOUBLE PRECISION array, dimension ( 2 )
!          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
!          reciprocal condition numbers for the average of the selected
!          eigenvalues.
!          Not referenced if SENSE = 'N' or 'V'.
!
!  RCONDV  (output) DOUBLE PRECISION array, dimension ( 2 )
!          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
!          reciprocal condition numbers for the selected deflating
!          subspaces.
!          Not referenced if SENSE = 'N' or 'E'.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= 8*(N+1)+16.
!          If SENSE = 'E', 'V', or 'B',
!          LWORK >= MAX( 8*(N+1)+16, 2*SDIM*(N-SDIM) ).
!
!  IWORK   (workspace) INTEGER array, dimension (LIWORK)
!          Not referenced if SENSE = 'N'.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array WORK.  LIWORK >= N+6.
!
!  BWORK   (workspace) LOGICAL array, dimension (N)
!          Not referenced if SORT = 'N'.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  (A,B) are not in Schur
!                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
!                be correct for j=INFO+1,...,N.
!          > N:  =N+1: other than QZ iteration failed in DHGEQZ
!                =N+2: after reordering, roundoff changed values of
!                      some complex eigenvalues so that leading
!                      eigenvalues in the Generalized Schur form no
!                      longer satisfy DELZTG=.TRUE.  This could also
!                      be caused due to scaling.
!                =N+3: reordering failed in DTGSEN.
!
!  Further details
!  ===============
!
!  An approximate (asymptotic) bound on the average absolute error of
!  the selected eigenvalues is
!
!       EPS * norm((A, B)) / RCONDE( 1 ).
!
!  An approximate (asymptotic) bound on the maximum angular error in
!  the computed deflating subspaces is
!
!       EPS * norm((A, B)) / RCONDV( 2 ).
!
!  See LAPACK User's Guide, section 4.11 for more information.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL, &
                         LST2SL, WANTSB, WANTSE, WANTSN, WANTST, WANTSV
      INTEGER            I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR, &
                         ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK, &
                         LIWMIN, MAXWRK, MINWRK
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL, &
                         PR, SAFMAX, SAFMIN, SMLNUM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DIF( 2 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD, &
                         DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVSL, 'N' ) ) THEN
         IJOBVL = 1
         ILVSL = .FALSE.
      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
         IJOBVL = 2
         ILVSL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVSL = .FALSE.
      END IF
!
      IF( LSAME( JOBVSR, 'N' ) ) THEN
         IJOBVR = 1
         ILVSR = .FALSE.
      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
         IJOBVR = 2
         ILVSR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVSR = .FALSE.
      END IF
!
      WANTST = LSAME( SORT, 'S' )
      WANTSN = LSAME( SENSE, 'N' )
      WANTSE = LSAME( SENSE, 'E' )
      WANTSV = LSAME( SENSE, 'V' )
      WANTSB = LSAME( SENSE, 'B' )
      IF( WANTSN ) THEN
         IJOB = 0
         IWORK( 1 ) = 1
      ELSE IF( WANTSE ) THEN
         IJOB = 1
      ELSE IF( WANTSV ) THEN
         IJOB = 2
      ELSE IF( WANTSB ) THEN
         IJOB = 4
      END IF
!
!     Test the input arguments
!
      INFO = 0
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR. &
               ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
         INFO = -16
      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
         INFO = -18
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
         MINWRK = 8*( N+1 ) + 16
         MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) + &
                  16
         IF( ILVSL ) THEN
            MAXWRK = MAX( MAXWRK, 8*( N+1 )+N* &
                     ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 )+16 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
      IF( .NOT.WANTSN ) THEN
         LIWMIN = 1
      ELSE
         LIWMIN = N + 6
      END IF
      IWORK( 1 ) = LIWMIN
!
      IF( INFO.EQ.0 .AND. LWORK.LT.MINWRK ) THEN
         INFO = -22
      ELSE IF( INFO.EQ.0 .AND. IJOB.GE.1 ) THEN
         IF( LIWORK.LT.LIWMIN ) &
            INFO = -24
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGESX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SDIM = 0
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SQRT( SAFMIN ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL ) &
         CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
      IF( ILBSCL ) &
         CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
!
!     Permute the matrix to make it more nearly triangular
!     (Workspace: need 6*N + 2*N for permutation parameters)
!
      ILEFT = 1
      IRIGHT = N + 1
      IWRK = IRIGHT + N
      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), &
                   WORK( IRIGHT ), WORK( IWRK ), IERR )
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Workspace: need N, prefer N*NB)
!
      IROWS = IHI + 1 - ILO
      ICOLS = N + 1 - ILO
      ITAU = IWRK
      IWRK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
!
!     Apply the orthogonal transformation to matrix A
!     (Workspace: need N, prefer N*NB)
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), &
                   LWORK+1-IWRK, IERR )
!
!     Initialize VSL
!     (Workspace: need N, prefer N*NB)
!
      IF( ILVSL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VSL( ILO+1, ILO ), LDVSL )
         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, &
                      WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
      END IF
!
!     Initialize VSR
!
      IF( ILVSR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, &
                   LDVSL, VSR, LDVSR, IERR )
!
      SDIM = 0
!
!     Perform QZ algorithm, computing Schur vectors if desired
!     (Workspace: need N)
!
      IWRK = ITAU
      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
            INFO = IERR
         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
            INFO = IERR - N
         ELSE
            INFO = N + 1
         END IF
         GO TO 60
      END IF
!
!     Sort eigenvalues ALPHA/BETA and compute the reciprocal of
!     condition number(s)
!     (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
!                 otherwise, need 8*(N+1) )
!
      IF( WANTST ) THEN
!
!        Undo scaling on eigenvalues before DELZTGing
!
         IF( ILASCL ) THEN
            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, &
                         IERR )
            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, &
                         IERR )
         END IF
         IF( ILBSCL ) &
            CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
!
!        Select eigenvalues
!
         DO 10 I = 1, N
            BWORK( I ) = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
   10    CONTINUE
!
!        Reorder eigenvalues, transform Generalized Schur vectors, and
!        compute reciprocal condition numbers
!
         CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, &
                      ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, &
                      SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1, &
                      IWORK, LIWORK, IERR )
!
         IF( IJOB.GE.1 ) &
            MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
         IF( IERR.EQ.-22 ) THEN
!
!            not enough real workspace
!
            INFO = -22
         ELSE
            RCONDE( 1 ) = PL
            RCONDE( 2 ) = PR
            RCONDV( 1 ) = DIF( 1 )
            RCONDV( 2 ) = DIF( 2 )
            IF( IERR.EQ.1 ) &
               INFO = N + 3
         END IF
!
      END IF
!
!     Apply permutation to VSL and VSR
!     (Workspace: none needed)
!
      IF( ILVSL ) &
         CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSL, LDVSL, IERR )
!
      IF( ILVSR ) &
         CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), &
                      WORK( IRIGHT ), N, VSR, LDVSR, IERR )
!
!     Check if unscaling would cause over/underflow, if so, rescale
!     (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
!     B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
!
      IF( ILASCL ) THEN
         DO 20 I = 1, N
            IF( ALPHAI( I ).NE.ZERO ) THEN
               IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR. &
                   ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
                  WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT. &
                        ( ANRMTO / ANRM ) .OR. &
                        ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) ) &
                         THEN
                  WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               END IF
            END IF
   20    CONTINUE
      END IF
!
      IF( ILBSCL ) THEN
         DO 30 I = 1, N
            IF( ALPHAI( I ).NE.ZERO ) THEN
               IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR. &
                   ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
                  WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
                  BETA( I ) = BETA( I )*WORK( 1 )
                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
               END IF
            END IF
   30    CONTINUE
      END IF
!
!     Undo scaling
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
      END IF
!
   40 CONTINUE
!
      IF( WANTST ) THEN
!
!        Check if reordering is correct
!
         LASTSL = .TRUE.
         LST2SL = .TRUE.
         SDIM = 0
         IP = 0
         DO 50 I = 1, N
            CURSL = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
            IF( ALPHAI( I ).EQ.ZERO ) THEN
               IF( CURSL ) &
                  SDIM = SDIM + 1
               IP = 0
               IF( CURSL .AND. .NOT.LASTSL ) &
                  INFO = N + 2
            ELSE
               IF( IP.EQ.1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
                  CURSL = CURSL .OR. LASTSL
                  LASTSL = CURSL
                  IF( CURSL ) &
                     SDIM = SDIM + 2
                  IP = -1
                  IF( CURSL .AND. .NOT.LST2SL ) &
                     INFO = N + 2
               ELSE
!
!                 First eigenvalue of conjugate pair
!
                  IP = 1
               END IF
            END IF
            LST2SL = LASTSL
            LASTSL = CURSL
   50    CONTINUE
!
      END IF
!
   60 CONTINUE
!
      WORK( 1 ) = MAXWRK
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DGGESX
!
      END
      SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, &
                        BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBVL, JOBVR
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), VL( LDVL, * ), &
                         VR( LDVR, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!  the generalized eigenvalues, and optionally, the left and/or right
!  generalized eigenvectors.
!
!  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!  singular. It is usually represented as the pair (alpha,beta), as
!  there is a reasonable interpretation for beta=0, and even for both
!  being zero.
!
!  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!  of (A,B) satisfies
!
!                   A * v(j) = lambda(j) * B * v(j).
!
!  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!  of (A,B) satisfies
!
!                   u(j)**H * A  = lambda(j) * u(j)**H * B .
!
!  where u(j)**H is the conjugate-transpose of u(j).
!
!
!  Arguments
!  =========
!
!  JOBVL   (input) CHARACTER*1
!          = 'N':  do not compute the left generalized eigenvectors;
!          = 'V':  compute the left generalized eigenvectors.
!
!  JOBVR   (input) CHARACTER*1
!          = 'N':  do not compute the right generalized eigenvectors;
!          = 'V':  compute the right generalized eigenvectors.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VL, and VR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the matrix A in the pair (A,B).
!          On exit, A has been overwritten.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the matrix B in the pair (A,B).
!          On exit, B has been overwritten.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
!          the j-th eigenvalue is real; if positive, then the j-th and
!          (j+1)-st eigenvalues are a complex conjugate pair, with
!          ALPHAI(j+1) negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio
!          alpha/beta.  However, ALPHAR and ALPHAI will be always less
!          than and usually comparable with norm(A) in magnitude, and
!          BETA always less than and usually comparable with norm(B).
!
!  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
!          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!          after another in the columns of VL, in the same order as
!          their eigenvalues. If the j-th eigenvalue is real, then
!          u(j) = VL(:,j), the j-th column of VL. If the j-th and
!          (j+1)-th eigenvalues form a complex conjugate pair, then
!          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
!          Each eigenvector will be scaled so the largest component have
!          abs(real part)+abs(imag. part)=1.
!          Not referenced if JOBVL = 'N'.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the matrix VL. LDVL >= 1, and
!          if JOBVL = 'V', LDVL >= N.
!
!  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
!          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!          after another in the columns of VR, in the same order as
!          their eigenvalues. If the j-th eigenvalue is real, then
!          v(j) = VR(:,j), the j-th column of VR. If the j-th and
!          (j+1)-th eigenvalues form a complex conjugate pair, then
!          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
!          Each eigenvector will be scaled so the largest component have
!          abs(real part)+abs(imag. part)=1.
!          Not referenced if JOBVR = 'N'.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the matrix VR. LDVR >= 1, and
!          if JOBVR = 'V', LDVR >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,8*N).
!          For good performance, LWORK must generally be larger.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  No eigenvectors have been
!                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!                should be correct for j=INFO+1,...,N.
!          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
!                =N+2: error return from DTGEVC.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
      CHARACTER          CHTEMP
      INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, &
                         IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK, &
                         MINWRK
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, &
                         SMLNUM, TEMP
!     ..
!     .. Local Arrays ..
      LOGICAL            LDUMMA( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, &
                         DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVL, 'N' ) ) THEN
         IJOBVL = 1
         ILVL = .FALSE.
      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
         IJOBVL = 2
         ILVL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVL = .FALSE.
      END IF
!
      IF( LSAME( JOBVR, 'N' ) ) THEN
         IJOBVR = 1
         ILVR = .FALSE.
      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
         IJOBVR = 2
         ILVR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVR = .FALSE.
      END IF
      ILV = ILVL .OR. ILVR
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
         INFO = -14
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV. The workspace is
!       computed assuming ILO = 1 and IHI = N, the worst case.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = 7*N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
         MINWRK = MAX( 1, 8*N )
         WORK( 1 ) = MAXWRK
      END IF
!
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) &
         INFO = -16
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGEV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL ) &
         CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
      IF( ILBSCL ) &
         CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
!
!     Permute the matrices A, B to isolate eigenvalues if possible
!     (Workspace: need 6*N)
!
      ILEFT = 1
      IRIGHT = N + 1
      IWRK = IRIGHT + N
      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), &
                   WORK( IRIGHT ), WORK( IWRK ), IERR )
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Workspace: need N, prefer N*NB)
!
      IROWS = IHI + 1 - ILO
      IF( ILV ) THEN
         ICOLS = N + 1 - ILO
      ELSE
         ICOLS = IROWS
      END IF
      ITAU = IWRK
      IWRK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
!
!     Apply the orthogonal transformation to matrix A
!     (Workspace: need N, prefer N*NB)
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), &
                   LWORK+1-IWRK, IERR )
!
!     Initialize VL
!     (Workspace: need N, prefer N*NB)
!
      IF( ILVL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VL( ILO+1, ILO ), LDVL )
         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, &
                      WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
      END IF
!
!     Initialize VR
!
      IF( ILVR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      IF( ILV ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, &
                      LDVL, VR, LDVR, IERR )
      ELSE
         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, &
                      B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
      END IF
!
!     Perform QZ algorithm (Compute eigenvalues, and optionally, the
!     Schur forms and Schur vectors)
!     (Workspace: need N)
!
      IWRK = ITAU
      IF( ILV ) THEN
         CHTEMP = 'S'
      ELSE
         CHTEMP = 'E'
      END IF
      CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
            INFO = IERR
         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
            INFO = IERR - N
         ELSE
            INFO = N + 1
         END IF
         GO TO 110
      END IF
!
!     Compute Eigenvectors
!     (Workspace: need 6*N)
!
      IF( ILV ) THEN
         IF( ILVL ) THEN
            IF( ILVR ) THEN
               CHTEMP = 'B'
            ELSE
               CHTEMP = 'L'
            END IF
         ELSE
            CHTEMP = 'R'
         END IF
         CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, &
                      VR, LDVR, N, IN, WORK( IWRK ), IERR )
         IF( IERR.NE.0 ) THEN
            INFO = N + 2
            GO TO 110
         END IF
!
!        Undo balancing on VL and VR and normalization
!        (Workspace: none needed)
!
         IF( ILVL ) THEN
            CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), &
                         WORK( IRIGHT ), N, VL, LDVL, IERR )
            DO 50 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO ) &
                  GO TO 50
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 10 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
   10             CONTINUE
               ELSE
                  DO 20 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ &
                            ABS( VL( JR, JC+1 ) ) )
   20             CONTINUE
               END IF
               IF( TEMP.LT.SMLNUM ) &
                  GO TO 50
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 30 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
   30             CONTINUE
               ELSE
                  DO 40 JR = 1, N
                     VL( JR, JC ) = VL( JR, JC )*TEMP
                     VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
   40             CONTINUE
               END IF
   50       CONTINUE
         END IF
         IF( ILVR ) THEN
            CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), &
                         WORK( IRIGHT ), N, VR, LDVR, IERR )
            DO 100 JC = 1, N
               IF( ALPHAI( JC ).LT.ZERO ) &
                  GO TO 100
               TEMP = ZERO
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 60 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
   60             CONTINUE
               ELSE
                  DO 70 JR = 1, N
                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ &
                            ABS( VR( JR, JC+1 ) ) )
   70             CONTINUE
               END IF
               IF( TEMP.LT.SMLNUM ) &
                  GO TO 100
               TEMP = ONE / TEMP
               IF( ALPHAI( JC ).EQ.ZERO ) THEN
                  DO 80 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
   80             CONTINUE
               ELSE
                  DO 90 JR = 1, N
                     VR( JR, JC ) = VR( JR, JC )*TEMP
                     VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
!
!        End of eigenvector calculation
!
      END IF
!
!     Undo scaling if necessary
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
      END IF
!
  110 CONTINUE
!
      WORK( 1 ) = MAXWRK
!
      RETURN
!
!     End of DGGEV
!
      END
      SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, &
                         ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, &
                         IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, &
                         RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
      DOUBLE PRECISION   ABNRM, BBNRM
!     ..
!     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), LSCALE( * ), &
                         RCONDE( * ), RCONDV( * ), RSCALE( * ), &
                         VL( LDVL, * ), VR( LDVR, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
!  the generalized eigenvalues, and optionally, the left and/or right
!  generalized eigenvectors.
!
!  Optionally also, it computes a balancing transformation to improve
!  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
!  the eigenvalues (RCONDE), and reciprocal condition numbers for the
!  right eigenvectors (RCONDV).
!
!  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
!  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
!  singular. It is usually represented as the pair (alpha,beta), as
!  there is a reasonable interpretation for beta=0, and even for both
!  being zero.
!
!  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
!  of (A,B) satisfies
!
!                   A * v(j) = lambda(j) * B * v(j) .
!
!  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
!  of (A,B) satisfies
!
!                   u(j)**H * A  = lambda(j) * u(j)**H * B.
!
!  where u(j)**H is the conjugate-transpose of u(j).
!
!
!  Arguments
!  =========
!
!  BALANC  (input) CHARACTER*1
!          Specifies the balance option to be performed.
!          = 'N':  do not diagonally scale or permute;
!          = 'P':  permute only;
!          = 'S':  scale only;
!          = 'B':  both permute and scale.
!          Computed reciprocal condition numbers will be for the
!          matrices after permuting and/or balancing. Permuting does
!          not change condition numbers (in exact arithmetic), but
!          balancing does.
!
!  JOBVL   (input) CHARACTER*1
!          = 'N':  do not compute the left generalized eigenvectors;
!          = 'V':  compute the left generalized eigenvectors.
!
!  JOBVR   (input) CHARACTER*1
!          = 'N':  do not compute the right generalized eigenvectors;
!          = 'V':  compute the right generalized eigenvectors.
!
!  SENSE   (input) CHARACTER*1
!          Determines which reciprocal condition numbers are computed.
!          = 'N': none are computed;
!          = 'E': computed for eigenvalues only;
!          = 'V': computed for eigenvectors only;
!          = 'B': computed for eigenvalues and eigenvectors.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, VL, and VR.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the matrix A in the pair (A,B).
!          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
!          or both, then A contains the first part of the real Schur
!          form of the "balanced" versions of the input A and B.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the matrix B in the pair (A,B).
!          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
!          or both, then B contains the second part of the real Schur
!          form of the "balanced" versions of the input A and B.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  LDB >= max(1,N).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
!          the j-th eigenvalue is real; if positive, then the j-th and
!          (j+1)-st eigenvalues are a complex conjugate pair, with
!          ALPHAI(j+1) negative.
!
!          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!          may easily over- or underflow, and BETA(j) may even be zero.
!          Thus, the user should avoid naively computing the ratio
!          ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
!          than and usually comparable with norm(A) in magnitude, and
!          BETA always less than and usually comparable with norm(B).
!
!  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
!          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!          after another in the columns of VL, in the same order as
!          their eigenvalues. If the j-th eigenvalue is real, then
!          u(j) = VL(:,j), the j-th column of VL. If the j-th and
!          (j+1)-th eigenvalues form a complex conjugate pair, then
!          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
!          Each eigenvector will be scaled so the largest component have
!          abs(real part) + abs(imag. part) = 1.
!          Not referenced if JOBVL = 'N'.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the matrix VL. LDVL >= 1, and
!          if JOBVL = 'V', LDVL >= N.
!
!  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
!          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!          after another in the columns of VR, in the same order as
!          their eigenvalues. If the j-th eigenvalue is real, then
!          v(j) = VR(:,j), the j-th column of VR. If the j-th and
!          (j+1)-th eigenvalues form a complex conjugate pair, then
!          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
!          Each eigenvector will be scaled so the largest component have
!          abs(real part) + abs(imag. part) = 1.
!          Not referenced if JOBVR = 'N'.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the matrix VR. LDVR >= 1, and
!          if JOBVR = 'V', LDVR >= N.
!
!  ILO,IHI (output) INTEGER
!          ILO and IHI are integer values such that on exit
!          A(i,j) = 0 and B(i,j) = 0 if i > j and
!          j = 1,...,ILO-1 or i = IHI+1,...,N.
!          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
!
!  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied
!          to the left side of A and B.  If PL(j) is the index of the
!          row interchanged with row j, and DL(j) is the scaling
!          factor applied to row j, then
!            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
!                      = DL(j)  for j = ILO,...,IHI
!                      = PL(j)  for j = IHI+1,...,N.
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
!          Details of the permutations and scaling factors applied
!          to the right side of A and B.  If PR(j) is the index of the
!          column interchanged with column j, and DR(j) is the scaling
!          factor applied to column j, then
!            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
!                      = DR(j)  for j = ILO,...,IHI
!                      = PR(j)  for j = IHI+1,...,N
!          The order in which the interchanges are made is N to IHI+1,
!          then 1 to ILO-1.
!
!  ABNRM   (output) DOUBLE PRECISION
!          The one-norm of the balanced matrix A.
!
!  BBNRM   (output) DOUBLE PRECISION
!          The one-norm of the balanced matrix B.
!
!  RCONDE  (output) DOUBLE PRECISION array, dimension (N)
!          If SENSE = 'E' or 'B', the reciprocal condition numbers of
!          the selected eigenvalues, stored in consecutive elements of
!          the array. For a complex conjugate pair of eigenvalues two
!          consecutive elements of RCONDE are set to the same value.
!          Thus RCONDE(j), RCONDV(j), and the j-th columns of VL and VR
!          all correspond to the same eigenpair (but not in general the
!          j-th eigenpair, unless all eigenpairs are selected).
!          If SENSE = 'V', RCONDE is not referenced.
!
!  RCONDV  (output) DOUBLE PRECISION array, dimension (N)
!          If SENSE = 'V' or 'B', the estimated reciprocal condition
!          numbers of the selected eigenvectors, stored in consecutive
!          elements of the array. For a complex eigenvector two
!          consecutive elements of RCONDV are set to the same value. If
!          the eigenvalues cannot be reordered to compute RCONDV(j),
!          RCONDV(j) is set to 0; this can only occur when the true
!          value would be very small anyway.
!          If SENSE = 'E', RCONDV is not referenced.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,6*N).
!          If SENSE = 'E', LWORK >= 12*N.
!          If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (N+6)
!          If SENSE = 'E', IWORK is not referenced.
!
!  BWORK   (workspace) LOGICAL array, dimension (N)
!          If SENSE = 'N', BWORK is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1,...,N:
!                The QZ iteration failed.  No eigenvectors have been
!                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!                should be correct for j=INFO+1,...,N.
!          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
!                =N+2: error return from DTGEVC.
!
!  Further Details
!  ===============
!
!  Balancing a matrix pair (A,B) includes, first, permuting rows and
!  columns to isolate eigenvalues, second, applying diagonal similarity
!  transformation to the rows and columns to make the rows and columns
!  as close in norm as possible. The computed reciprocal condition
!  numbers correspond to the balanced matrix. Permuting rows and columns
!  will not change the condition numbers (in exact arithmetic) but
!  diagonal scaling will.  For further explanation of balancing, see
!  section 4.11.1.2 of LAPACK Users' Guide.
!
!  An approximate error bound on the chordal distance between the i-th
!  computed generalized eigenvalue w and the corresponding exact
!  eigenvalue lambda is
!
!       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
!
!  An approximate error bound for the angle between the i-th computed
!  eigenvector VL(i) or VR(i) is given by
!
!       EPS * norm(ABNRM, BBNRM) / DIF(i).
!
!  For further explanation of the reciprocal condition numbers RCONDE
!  and RCONDV, see section 4.11 of LAPACK User's Guide.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, PAIR, &
                         WANTSB, WANTSE, WANTSN, WANTSV
      CHARACTER          CHTEMP
      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS, &
                         ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, &
                         MINWRK, MM
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, &
                         SMLNUM, TEMP
!     ..
!     .. Local Arrays ..
      LOGICAL            LDUMMA( 1 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, &
                         DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, DTGSNA, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF( LSAME( JOBVL, 'N' ) ) THEN
         IJOBVL = 1
         ILVL = .FALSE.
      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
         IJOBVL = 2
         ILVL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVL = .FALSE.
      END IF
!
      IF( LSAME( JOBVR, 'N' ) ) THEN
         IJOBVR = 1
         ILVR = .FALSE.
      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
         IJOBVR = 2
         ILVR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVR = .FALSE.
      END IF
      ILV = ILVL .OR. ILVR
!
      WANTSN = LSAME( SENSE, 'N' )
      WANTSE = LSAME( SENSE, 'E' )
      WANTSV = LSAME( SENSE, 'V' )
      WANTSB = LSAME( SENSE, 'B' )
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, &
          'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) &
           THEN
         INFO = -1
      ELSE IF( IJOBVL.LE.0 ) THEN
         INFO = -2
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -3
      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) ) &
                THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
         INFO = -16
      END IF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV. The workspace is
!       computed assuming ILO = 1 and IHI = N, the worst case.)
!
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = 5*N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
         MINWRK = MAX( 1, 6*N )
         IF( WANTSE ) THEN
            MINWRK = MAX( 1, 12*N )
         ELSE IF( WANTSV .OR. WANTSB ) THEN
            MINWRK = 2*N*N + 12*N + 16
            MAXWRK = MAX( MAXWRK, 2*N*N+12*N+16 )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
!
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -26
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGEVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL ) &
         CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
      IF( ILBSCL ) &
         CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
!
!     Permute and/or balance the matrix pair (A,B)
!     (Workspace: need 6*N)
!
      CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, &
                   WORK, IERR )
!
!     Compute ABNRM and BBNRM
!
      ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) )
      IF( ILASCL ) THEN
         WORK( 1 ) = ABNRM
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1, &
                      IERR )
         ABNRM = WORK( 1 )
      END IF
!
      BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) )
      IF( ILBSCL ) THEN
         WORK( 1 ) = BBNRM
         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1, &
                      IERR )
         BBNRM = WORK( 1 )
      END IF
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Workspace: need N, prefer N*NB )
!
      IROWS = IHI + 1 - ILO
      IF( ILV .OR. .NOT.WANTSN ) THEN
         ICOLS = N + 1 - ILO
      ELSE
         ICOLS = IROWS
      END IF
      ITAU = 1
      IWRK = ITAU + IROWS
      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), &
                   WORK( IWRK ), LWORK+1-IWRK, IERR )
!
!     Apply the orthogonal transformation to A
!     (Workspace: need N, prefer N*NB)
!
      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, &
                   WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), &
                   LWORK+1-IWRK, IERR )
!
!     Initialize VL and/or VR
!     (Workspace: need N, prefer N*NB)
!
      IF( ILVL ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, &
                      VL( ILO+1, ILO ), LDVL )
         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, &
                      WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
      END IF
!
      IF( ILVR ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      IF( ILV .OR. .NOT.WANTSN ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, &
                      LDVL, VR, LDVR, IERR )
      ELSE
         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, &
                      B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
      END IF
!
!     Perform QZ algorithm (Compute eigenvalues, and optionally, the
!     Schur forms and Schur vectors)
!     (Workspace: need N)
!
      IF( ILV .OR. .NOT.WANTSN ) THEN
         CHTEMP = 'S'
      ELSE
         CHTEMP = 'E'
      END IF
!
      CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, &
                   ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, &
                   LWORK, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
            INFO = IERR
         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
            INFO = IERR - N
         ELSE
            INFO = N + 1
         END IF
         GO TO 130
      END IF
!
!     Compute Eigenvectors and estimate condition numbers if desired
!     (Workspace: DTGEVC: need 6*N
!                 DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
!                         need N otherwise )
!
      IF( ILV .OR. .NOT.WANTSN ) THEN
         IF( ILV ) THEN
            IF( ILVL ) THEN
               IF( ILVR ) THEN
                  CHTEMP = 'B'
               ELSE
                  CHTEMP = 'L'
               END IF
            ELSE
               CHTEMP = 'R'
            END IF
!
            CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, &
                         LDVL, VR, LDVR, N, IN, WORK, IERR )
            IF( IERR.NE.0 ) THEN
               INFO = N + 2
               GO TO 130
            END IF
         END IF
!
         IF( .NOT.WANTSN ) THEN
!
!           compute eigenvectors (DTGEVC) and estimate condition
!           numbers (DTGSNA). Note that the definition of the condition
!           number is not invariant under transformation (u,v) to
!           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
!           Schur form (S,T), Q and Z are orthogonal matrices. In order
!           to avoid using extra 2*N*N workspace, we have to recalculate
!           eigenvectors and estimate one condition numbers at a time.
!
            PAIR = .FALSE.
            DO 20 I = 1, N
!
               IF( PAIR ) THEN
                  PAIR = .FALSE.
                  GO TO 20
               END IF
               MM = 1
               IF( I.LT.N ) THEN
                  IF( A( I+1, I ).NE.ZERO ) THEN
                     PAIR = .TRUE.
                     MM = 2
                  END IF
               END IF
!
               DO 10 J = 1, N
                  BWORK( J ) = .FALSE.
   10          CONTINUE
               IF( MM.EQ.1 ) THEN
                  BWORK( I ) = .TRUE.
               ELSE IF( MM.EQ.2 ) THEN
                  BWORK( I ) = .TRUE.
                  BWORK( I+1 ) = .TRUE.
               END IF
!
               IWRK = MM*N + 1
               IWRK1 = IWRK + MM*N
!
!              Compute a pair of left and right eigenvectors.
!              (compute workspace: need up to 4*N + 6*N)
!
               IF( WANTSE .OR. WANTSB ) THEN
                  CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB, &
                               WORK( 1 ), N, WORK( IWRK ), N, MM, M, &
                               WORK( IWRK1 ), IERR )
                  IF( IERR.NE.0 ) THEN
                     INFO = N + 2
                     GO TO 130
                  END IF
               END IF
!
               CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB, &
                            WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ), &
                            RCONDV( I ), MM, M, WORK( IWRK1 ), &
                            LWORK-IWRK1+1, IWORK, IERR )
!
   20       CONTINUE
         END IF
      END IF
!
!     Undo balancing on VL and VR and normalization
!     (Workspace: none needed)
!
      IF( ILVL ) THEN
         CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL, &
                      LDVL, IERR )
!
         DO 70 JC = 1, N
            IF( ALPHAI( JC ).LT.ZERO ) &
               GO TO 70
            TEMP = ZERO
            IF( ALPHAI( JC ).EQ.ZERO ) THEN
               DO 30 JR = 1, N
                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
   30          CONTINUE
            ELSE
               DO 40 JR = 1, N
                  TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+ &
                         ABS( VL( JR, JC+1 ) ) )
   40          CONTINUE
            END IF
            IF( TEMP.LT.SMLNUM ) &
               GO TO 70
            TEMP = ONE / TEMP
            IF( ALPHAI( JC ).EQ.ZERO ) THEN
               DO 50 JR = 1, N
                  VL( JR, JC ) = VL( JR, JC )*TEMP
   50          CONTINUE
            ELSE
               DO 60 JR = 1, N
                  VL( JR, JC ) = VL( JR, JC )*TEMP
                  VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
   60          CONTINUE
            END IF
   70    CONTINUE
      END IF
      IF( ILVR ) THEN
         CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR, &
                      LDVR, IERR )
         DO 120 JC = 1, N
            IF( ALPHAI( JC ).LT.ZERO ) &
               GO TO 120
            TEMP = ZERO
            IF( ALPHAI( JC ).EQ.ZERO ) THEN
               DO 80 JR = 1, N
                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
   80          CONTINUE
            ELSE
               DO 90 JR = 1, N
                  TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+ &
                         ABS( VR( JR, JC+1 ) ) )
   90          CONTINUE
            END IF
            IF( TEMP.LT.SMLNUM ) &
               GO TO 120
            TEMP = ONE / TEMP
            IF( ALPHAI( JC ).EQ.ZERO ) THEN
               DO 100 JR = 1, N
                  VR( JR, JC ) = VR( JR, JC )*TEMP
  100          CONTINUE
            ELSE
               DO 110 JR = 1, N
                  VR( JR, JC ) = VR( JR, JC )*TEMP
                  VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
  110          CONTINUE
            END IF
  120    CONTINUE
      END IF
!
!     Undo scaling if necessary
!
      IF( ILASCL ) THEN
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
      END IF
!
      IF( ILBSCL ) THEN
         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
      END IF
!
  130 CONTINUE
      WORK( 1 ) = MAXWRK
!
      RETURN
!
!     End of DGGEVX
!
      END
      SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, &
                         INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( * ), WORK( * ), &
                         X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGGLM solves a general Gauss-Markov linear model (GLM) problem:
!
!          minimize || y ||_2   subject to   d = A*x + B*y
!              x
!
!  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
!  given N-vector. It is assumed that M <= N <= M+P, and
!
!             rank(A) = M    and    rank( A B ) = N.
!
!  Under these assumptions, the constrained equation is always
!  consistent, and there is a unique solution x and a minimal 2-norm
!  solution y, which is obtained using a generalized QR factorization
!  of A and B.
!
!  In particular, if matrix B is square nonsingular, then the problem
!  GLM is equivalent to the following weighted linear least squares
!  problem
!
!               minimize || inv(B)*(d-A*x) ||_2
!                   x
!
!  where inv(B) denotes the inverse of B.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of rows of the matrices A and B.  N >= 0.
!
!  M       (input) INTEGER
!          The number of columns of the matrix A.  0 <= M <= N.
!
!  P       (input) INTEGER
!          The number of columns of the matrix B.  P >= N-M.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
!          On entry, the N-by-M matrix A.
!          On exit, A is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)
!          On entry, the N-by-P matrix B.
!          On exit, B is destroyed.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, D is the left hand side of the GLM equation.
!          On exit, D is destroyed.
!
!  X       (output) DOUBLE PRECISION array, dimension (M)
!  Y       (output) DOUBLE PRECISION array, dimension (P)
!          On exit, X and Y are the solutions of the GLM problem.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N+M+P).
!          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
!          where NB is an upper bound for the optimal blocksizes for
!          DGEQRF, SGERQF, DORMQR and SORMRQ.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  ===================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, LOPT, LWKOPT, NB, NB1, NB2, NB3, NB4, NP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRSV, &
                         XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      NP = MIN( N, P )
      NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
      NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 )
      NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
      NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 )
      NB = MAX( NB1, NB2, NB3, NB4 )
      LWKOPT = M + NP + MAX( N, P )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LWORK.LT.MAX( 1, N+M+P ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGGLM', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Compute the GQR factorization of matrices A and B:
!
!            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
!                   (  0  ) N-M             (  0    T22 ) N-M
!                      M                     M+P-N  N-M
!
!     where R11 and T22 are upper triangular, and Q and Z are
!     orthogonal.
!
      CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ), &
                   WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = WORK( M+NP+1 )
!
!     Update left-hand-side vector d = Q'*d = ( d1 ) M
!                                             ( d2 ) N-M
!
      CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D, &
                   MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
!
!     Solve T22*y2 = d2 for y2
!
      CALL DTRSV( 'Upper', 'No transpose', 'Non unit', N-M, &
                  B( M+1, M+P-N+1 ), LDB, D( M+1 ), 1 )
      CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
!
!     Set y1 = 0
!
      DO 10 I = 1, M + P - N
         Y( I ) = ZERO
   10 CONTINUE
!
!     Update d1 = d1 - T12*y2
!
      CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB, &
                  Y( M+P-N+1 ), 1, ONE, D, 1 )
!
!     Solve triangular system: R11*x = d1
!
      CALL DTRSV( 'Upper', 'No Transpose', 'Non unit', M, A, LDA, D, 1 )
!
!     Copy D to X
!
      CALL DCOPY( M, D, 1, X, 1 )
!
!     Backward transformation y = Z'*y
!
      CALL DORMRQ( 'Left', 'Transpose', P, 1, NP, &
                   B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y, &
                   MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
!
      RETURN
!
!     End of DGGGLM
!
      END
      SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, &
                         LDQ, Z, LDZ, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DGGHRD reduces a pair of real matrices (A,B) to generalized upper
!  Hessenberg form using orthogonal transformations, where A is a
!  general matrix and B is upper triangular:  Q' * A * Z = H and
!  Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular,
!  and Q and Z are orthogonal, and ' means transpose.
!
!  The orthogonal matrices Q and Z are determined as products of Givens
!  rotations.  They may either be formed explicitly, or they may be
!  postmultiplied into input matrices Q1 and Z1, so that
!
!       Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)'
!       Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)'
!
!  Arguments
!  =========
!
!  COMPQ   (input) CHARACTER*1
!          = 'N': do not compute Q;
!          = 'I': Q is initialized to the unit matrix, and the
!                 orthogonal matrix Q is returned;
!          = 'V': Q must contain an orthogonal matrix Q1 on entry,
!                 and the product Q1*Q is returned.
!
!  COMPZ   (input) CHARACTER*1
!          = 'N': do not compute Z;
!          = 'I': Z is initialized to the unit matrix, and the
!                 orthogonal matrix Z is returned;
!          = 'V': Z must contain an orthogonal matrix Z1 on entry,
!                 and the product Z1*Z is returned.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that A is already upper triangular in rows and
!          columns 1:ILO-1 and IHI+1:N.  ILO and IHI are normally set
!          by a previous call to DGGBAL; otherwise they should be set
!          to 1 and N respectively.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the N-by-N general matrix to be reduced.
!          On exit, the upper triangle and the first subdiagonal of A
!          are overwritten with the upper Hessenberg matrix H, and the
!          rest is set to zero.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the N-by-N upper triangular matrix B.
!          On exit, the upper triangular matrix T = Q' B Z.  The
!          elements below the diagonal are set to zero.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
!          If COMPQ='N':  Q is not referenced.
!          If COMPQ='I':  on entry, Q need not be set, and on exit it
!                         contains the orthogonal matrix Q, where Q'
!                         is the product of the Givens transformations
!                         which are applied to A and B on the left.
!          If COMPQ='V':  on entry, Q must contain an orthogonal matrix
!                         Q1, and on exit this is overwritten by Q1*Q.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.
!          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If COMPZ='N':  Z is not referenced.
!          If COMPZ='I':  on entry, Z need not be set, and on exit it
!                         contains the orthogonal matrix Z, which is
!                         the product of the Givens transformations
!                         which are applied to A and B on the right.
!          If COMPZ='V':  on entry, Z must contain an orthogonal matrix
!                         Z1, and on exit this is overwritten by Z1*Z.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.
!          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  This routine reduces A to Hessenberg and B to triangular form by
!  an unblocked reduction, as described in _Matrix_Computations_,
!  by Golub and Van Loan (Johns Hopkins Press.)
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILQ, ILZ
      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
      DOUBLE PRECISION   C, S, TEMP
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARTG, DLASET, DROT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Decode COMPQ
!
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
!
!     Decode COMPZ
!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -4
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -11
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGHRD', -INFO )
         RETURN
      END IF
!
!     Initialize Q and Z if desired.
!
      IF( ICOMPQ.EQ.3 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
!
!     Quick return if possible
!
      IF( N.LE.1 ) &
         RETURN
!
!     Zero out lower triangle of B
!
      DO 20 JCOL = 1, N - 1
         DO 10 JROW = JCOL + 1, N
            B( JROW, JCOL ) = ZERO
   10    CONTINUE
   20 CONTINUE
!
!     Reduce A and B
!
      DO 40 JCOL = ILO, IHI - 2
!
         DO 30 JROW = IHI, JCOL + 2, -1
!
!           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
!
            TEMP = A( JROW-1, JCOL )
            CALL DLARTG( TEMP, A( JROW, JCOL ), C, S, &
                         A( JROW-1, JCOL ) )
            A( JROW, JCOL ) = ZERO
            CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, &
                       A( JROW, JCOL+1 ), LDA, C, S )
            CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, &
                       B( JROW, JROW-1 ), LDB, C, S )
            IF( ILQ ) &
               CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
!
!           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
!
            TEMP = B( JROW, JROW )
            CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S, &
                         B( JROW, JROW ) )
            B( JROW, JROW-1 ) = ZERO
            CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
            CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, &
                       S )
            IF( ILZ ) &
               CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
   30    CONTINUE
   40 CONTINUE
!
      RETURN
!
!     End of DGGHRD
!
      END
      SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, &
                         INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( * ), D( * ), &
                         WORK( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGLSE solves the linear equality-constrained least squares (LSE)
!  problem:
!
!          minimize || c - A*x ||_2   subject to   B*x = d
!
!  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
!  M-vector, and d is a given P-vector. It is assumed that
!  P <= N <= M+P, and
!
!           rank(B) = P and  rank( ( A ) ) = N.
!                                ( ( B ) )
!
!  These conditions ensure that the LSE problem has a unique solution,
!  which is obtained using a GRQ factorization of the matrices B and A.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrices A and B. N >= 0.
!
!  P       (input) INTEGER
!          The number of rows of the matrix B. 0 <= P <= N <= M+P.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the P-by-N matrix B.
!          On exit, B is destroyed.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,P).
!
!  C       (input/output) DOUBLE PRECISION array, dimension (M)
!          On entry, C contains the right hand side vector for the
!          least squares part of the LSE problem.
!          On exit, the residual sum of squares for the solution
!          is given by the sum of squares of elements N-P+1 to M of
!          vector C.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (P)
!          On entry, D contains the right hand side vector for the
!          constrained equation.
!          On exit, D is destroyed.
!
!  X       (output) DOUBLE PRECISION array, dimension (N)
!          On exit, X is the solution of the LSE problem.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,M+N+P).
!          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
!          where NB is an upper bound for the optimal blocksizes for
!          DGEQRF, SGERQF, DORMQR and SORMRQ.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKOPT, MN, NB, NB1, NB2, NB3, NB4, NR
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ, &
                         DTRMV, DTRSV, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      MN = MIN( M, N )
      NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
      NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, P, -1 )
      NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
      NB = MAX( NB1, NB2, NB3, NB4 )
      LWKOPT = P + MN + MAX( M, N )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -7
      ELSE IF( LWORK.LT.MAX( 1, M+N+P ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGLSE', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Compute the GRQ factorization of matrices B and A:
!
!            B*Q' = (  0  T12 ) P   Z'*A*Q' = ( R11 R12 ) N-P
!                     N-P  P                  (  0  R22 ) M+P-N
!                                               N-P  P
!
!     where T12 and R11 are upper triangular, and Q and Z are
!     orthogonal.
!
      CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ), &
                   WORK( P+MN+1 ), LWORK-P-MN, INFO )
      LOPT = WORK( P+MN+1 )
!
!     Update c = Z'*c = ( c1 ) N-P
!                       ( c2 ) M+P-N
!
      CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ), &
                   C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
      LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
!
!     Solve T12*x2 = d for x2
!
      CALL DTRSV( 'Upper', 'No transpose', 'Non unit', P, B( 1, N-P+1 ), &
                  LDB, D, 1 )
!
!     Update c1
!
      CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA, D, &
                  1, ONE, C, 1 )
!
!     Sovle R11*x1 = c1 for x1
!
      CALL DTRSV( 'Upper', 'No transpose', 'Non unit', N-P, A, LDA, C, &
                  1 )
!
!     Put the solutions in X
!
      CALL DCOPY( N-P, C, 1, X, 1 )
      CALL DCOPY( P, D, 1, X( N-P+1 ), 1 )
!
!     Compute the residual vector:
!
      IF( M.LT.N ) THEN
         NR = M + P - N
         CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ), &
                     LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
      ELSE
         NR = P
      END IF
      CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR, &
                  A( N-P+1, N-P+1 ), LDA, D, 1 )
      CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
!
!     Backward transformation x = Q'*x
!
      CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X, &
                   N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
      WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
!
      RETURN
!
!     End of DGGLSE
!
      END
      SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, &
                         LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGQRF computes a generalized QR factorization of an N-by-M matrix A
!  and an N-by-P matrix B:
!
!              A = Q*R,        B = Q*T*Z,
!
!  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
!  matrix, and R and T assume one of the forms:
!
!  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
!                  (  0  ) N-M                         N   M-N
!                     M
!
!  where R11 is upper triangular, and
!
!  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
!                   P-N  N                           ( T21 ) P
!                                                       P
!
!  where T12 or T21 is upper triangular.
!
!  In particular, if B is square and nonsingular, the GQR factorization
!  of A and B implicitly gives the QR factorization of inv(B)*A:
!
!               inv(B)*A = Z'*(inv(T)*R)
!
!  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
!  transpose of the matrix Z.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of rows of the matrices A and B. N >= 0.
!
!  M       (input) INTEGER
!          The number of columns of the matrix A.  M >= 0.
!
!  P       (input) INTEGER
!          The number of columns of the matrix B.  P >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
!          On entry, the N-by-M matrix A.
!          On exit, the elements on and above the diagonal of the array
!          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
!          upper triangular if N >= M); the elements below the diagonal,
!          with the array TAUA, represent the orthogonal matrix Q as a
!          product of min(N,M) elementary reflectors (see Further
!          Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  TAUA    (output) DOUBLE PRECISION array, dimension (min(N,M))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Q (see Further Details).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)
!          On entry, the N-by-P matrix B.
!          On exit, if N <= P, the upper triangle of the subarray
!          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
!          if N > P, the elements on and above the (N-P)-th subdiagonal
!          contain the N-by-P upper trapezoidal matrix T; the remaining
!          elements, with the array TAUB, represent the orthogonal
!          matrix Z as a product of elementary reflectors (see Further
!          Details).
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  TAUB    (output) DOUBLE PRECISION array, dimension (min(N,P))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Z (see Further Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N,M,P).
!          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
!          where NB1 is the optimal blocksize for the QR factorization
!          of an N-by-M matrix, NB2 is the optimal blocksize for the
!          RQ factorization of an N-by-P matrix, and NB3 is the optimal
!          blocksize for a call of DORMQR.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(n,m).
!
!  Each H(i) has the form
!
!     H(i) = I - taua * v * v'
!
!  where taua is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!  and taua in TAUA(i).
!  To form Q explicitly, use LAPACK subroutine DORGQR.
!  To use Q to update another matrix, use LAPACK subroutine DORMQR.
!
!  The matrix Z is represented as a product of elementary reflectors
!
!     Z = H(1) H(2) . . . H(k), where k = min(n,p).
!
!  Each H(i) has the form
!
!     H(i) = I - taub * v * v'
!
!  where taub is a real scalar, and v is a real vector with
!  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
!  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
!  To form Z explicitly, use LAPACK subroutine DORGRQ.
!  To use Z to update another matrix, use LAPACK subroutine DORMRQ.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGERQF, DORMQR, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
      NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 )
      NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
      NB = MAX( NB1, NB2, NB3 )
      LWKOPT = MAX( N, M, P )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGQRF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     QR factorization of N-by-M matrix A: A = Q*R
!
      CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
      LOPT = WORK( 1 )
!
!     Update B := Q'*B.
!
      CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA, &
                   B, LDB, WORK, LWORK, INFO )
      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
!
!     RQ factorization of N-by-P matrix B: B = T*Z.
!
      CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
!
      RETURN
!
!     End of DGGQRF
!
      END
      SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, &
                         LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
!  and a P-by-N matrix B:
!
!              A = R*Q,        B = Z*T*Q,
!
!  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
!  matrix, and R and T assume one of the forms:
!
!  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,
!                   N-M  M                           ( R21 ) N
!                                                       N
!
!  where R12 or R21 is upper triangular, and
!
!  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,
!                  (  0  ) P-N                         P   N-P
!                     N
!
!  where T11 is upper triangular.
!
!  In particular, if B is square and nonsingular, the GRQ factorization
!  of A and B implicitly gives the RQ factorization of A*inv(B):
!
!               A*inv(B) = (R*inv(T))*Z'
!
!  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
!  transpose of the matrix Z.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  P       (input) INTEGER
!          The number of rows of the matrix B.  P >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrices A and B. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, if M <= N, the upper triangle of the subarray
!          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
!          if M > N, the elements on and above the (M-N)-th subdiagonal
!          contain the M-by-N upper trapezoidal matrix R; the remaining
!          elements, with the array TAUA, represent the orthogonal
!          matrix Q as a product of elementary reflectors (see Further
!          Details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  TAUA    (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Q (see Further Details).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the P-by-N matrix B.
!          On exit, the elements on and above the diagonal of the array
!          contain the min(P,N)-by-N upper trapezoidal matrix T (T is
!          upper triangular if P >= N); the elements below the diagonal,
!          with the array TAUB, represent the orthogonal matrix Z as a
!          product of elementary reflectors (see Further Details).
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,P).
!
!  TAUB    (output) DOUBLE PRECISION array, dimension (min(P,N))
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Z (see Further Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N,M,P).
!          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
!          where NB1 is the optimal blocksize for the RQ factorization
!          of an M-by-N matrix, NB2 is the optimal blocksize for the
!          QR factorization of a P-by-N matrix, and NB3 is the optimal
!          blocksize for a call of DORMRQ.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INF0= -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of elementary reflectors
!
!     Q = H(1) H(2) . . . H(k), where k = min(m,n).
!
!  Each H(i) has the form
!
!     H(i) = I - taua * v * v'
!
!  where taua is a real scalar, and v is a real vector with
!  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
!  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
!  To form Q explicitly, use LAPACK subroutine DORGRQ.
!  To use Q to update another matrix, use LAPACK subroutine DORMRQ.
!
!  The matrix Z is represented as a product of elementary reflectors
!
!     Z = H(1) H(2) . . . H(k), where k = min(p,n).
!
!  Each H(i) has the form
!
!     H(i) = I - taub * v * v'
!
!  where taub is a real scalar, and v is a real vector with
!  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
!  and taub in TAUB(i).
!  To form Z explicitly, use LAPACK subroutine DORGQR.
!  To use Z to update another matrix, use LAPACK subroutine DORMQR.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGERQF, DORMRQ, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
      NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 )
      NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
      NB = MAX( NB1, NB2, NB3 )
      LWKOPT = MAX( N, M, P )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( P.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGRQF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     RQ factorization of M-by-N matrix A: A = R*Q
!
      CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
      LOPT = WORK( 1 )
!
!     Update B := B*Q'
!
      CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ), &
                   A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK, &
                   LWORK, INFO )
      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
!
!     QR factorization of P-by-N matrix B: B = Z*T
!
      CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
!
      RETURN
!
!     End of DGGRQF
!
      END
      SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, &
                         LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBQ, JOBU, JOBV
      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHA( * ), B( LDB, * ), &
                         BETA( * ), Q( LDQ, * ), U( LDU, * ), &
                         V( LDV, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGSVD computes the generalized singular value decomposition (GSVD)
!  of an M-by-N real matrix A and P-by-N real matrix B:
!
!      U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )
!
!  where U, V and Q are orthogonal matrices, and Z' is the transpose
!  of Z.  Let K+L = the effective numerical rank of the matrix (A',B')',
!  then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
!  D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
!  following structures, respectively:
!
!  If M-K-L >= 0,
!
!                      K  L
!         D1 =     K ( I  0 )
!                  L ( 0  C )
!              M-K-L ( 0  0 )
!
!                    K  L
!         D2 =   L ( 0  S )
!              P-L ( 0  0 )
!
!                  N-K-L  K    L
!    ( 0 R ) = K (  0   R11  R12 )
!              L (  0    0   R22 )
!
!  where
!
!    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
!    S = diag( BETA(K+1),  ... , BETA(K+L) ),
!    C**2 + S**2 = I.
!
!    R is stored in A(1:K+L,N-K-L+1:N) on exit.
!
!  If M-K-L < 0,
!
!                    K M-K K+L-M
!         D1 =   K ( I  0    0   )
!              M-K ( 0  C    0   )
!
!                      K M-K K+L-M
!         D2 =   M-K ( 0  S    0  )
!              K+L-M ( 0  0    I  )
!                P-L ( 0  0    0  )
!
!                     N-K-L  K   M-K  K+L-M
!    ( 0 R ) =     K ( 0    R11  R12  R13  )
!                M-K ( 0     0   R22  R23  )
!              K+L-M ( 0     0    0   R33  )
!
!  where
!
!    C = diag( ALPHA(K+1), ... , ALPHA(M) ),
!    S = diag( BETA(K+1),  ... , BETA(M) ),
!    C**2 + S**2 = I.
!
!    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
!    ( 0  R22 R23 )
!    in B(M-K+1:L,N+M-K-L+1:N) on exit.
!
!  The routine computes C, S, R, and optionally the orthogonal
!  transformation matrices U, V and Q.
!
!  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
!  A and B implicitly gives the SVD of A*inv(B):
!                       A*inv(B) = U*(D1*inv(D2))*V'.
!  If ( A',B')' has orthonormal columns, then the GSVD of A and B is
!  also equal to the CS decomposition of A and B. Furthermore, the GSVD
!  can be used to derive the solution of the eigenvalue problem:
!                       A'*A x = lambda* B'*B x.
!  In some literature, the GSVD of A and B is presented in the form
!                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )
!  where U and V are orthogonal and X is nonsingular, D1 and D2 are
!  ``diagonal''.  The former GSVD form can be converted to the latter
!  form by taking the nonsingular matrix X as
!
!                       X = Q*( I   0    )
!                             ( 0 inv(R) ).
!
!  Arguments
!  =========
!
!  JOBU    (input) CHARACTER*1
!          = 'U':  Orthogonal matrix U is computed;
!          = 'N':  U is not computed.
!
!  JOBV    (input) CHARACTER*1
!          = 'V':  Orthogonal matrix V is computed;
!          = 'N':  V is not computed.
!
!  JOBQ    (input) CHARACTER*1
!          = 'Q':  Orthogonal matrix Q is computed;
!          = 'N':  Q is not computed.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrices A and B.  N >= 0.
!
!  P       (input) INTEGER
!          The number of rows of the matrix B.  P >= 0.
!
!  K       (output) INTEGER
!  L       (output) INTEGER
!          On exit, K and L specify the dimension of the subblocks
!          described in the Purpose section.
!          K + L = effective numerical rank of (A',B')'.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A contains the triangular matrix R, or part of R.
!          See Purpose for details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the P-by-N matrix B.
!          On exit, B contains the triangular matrix R if M-K-L < 0.
!          See Purpose for details.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDA >= max(1,P).
!
!  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, ALPHA and BETA contain the generalized singular
!          value pairs of A and B;
!            ALPHA(1:K) = 1,
!            BETA(1:K)  = 0,
!          and if M-K-L >= 0,
!            ALPHA(K+1:K+L) = C,
!            BETA(K+1:K+L)  = S,
!          or if M-K-L < 0,
!            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
!            BETA(K+1:M) =S, BETA(M+1:K+L) =1
!          and
!            ALPHA(K+L+1:N) = 0
!            BETA(K+L+1:N)  = 0
!
!  U       (output) DOUBLE PRECISION array, dimension (LDU,M)
!          If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
!          If JOBU = 'N', U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U. LDU >= max(1,M) if
!          JOBU = 'U'; LDU >= 1 otherwise.
!
!  V       (output) DOUBLE PRECISION array, dimension (LDV,P)
!          If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
!          If JOBV = 'N', V is not referenced.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V. LDV >= max(1,P) if
!          JOBV = 'V'; LDV >= 1 otherwise.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
!          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
!          If JOBQ = 'N', Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= max(1,N) if
!          JOBQ = 'Q'; LDQ >= 1 otherwise.
!
!  WORK    (workspace) DOUBLE PRECISION array,
!                      dimension (max(3*N,M,P)+N)
!
!  IWORK   (workspace/output) INTEGER array, dimension (N)
!          On exit, IWORK stores the sorting information. More
!          precisely, the following loop will sort ALPHA
!             for I = K+1, min(M,K+L)
!                 swap ALPHA(I) and ALPHA(IWORK(I))
!             endfor
!          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
!
!  INFO    (output)INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, the Jacobi-type procedure failed to
!                converge.  For further details, see subroutine DTGSJA.
!
!  Internal Parameters
!  ===================
!
!  TOLA    DOUBLE PRECISION
!  TOLB    DOUBLE PRECISION
!          TOLA and TOLB are the thresholds to determine the effective
!          rank of (A',B')'. Generally, they are set to
!                   TOLA = MAX(M,N)*norm(A)*MAZHEPS,
!                   TOLB = MAX(P,N)*norm(B)*MAZHEPS.
!          The size of TOLA and TOLB may affect the size of backward
!          errors of the decomposition.
!
!  Further Details
!  ===============
!
!  2-96 Based on modifications by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            WANTQ, WANTU, WANTV
      INTEGER            I, IBND, ISUB, J, NCYCLE
      DOUBLE PRECISION   ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           LSAME, DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGGSVP, DTGSJA, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      WANTU = LSAME( JOBU, 'U' )
      WANTV = LSAME( JOBV, 'V' )
      WANTQ = LSAME( JOBQ, 'Q' )
!
      INFO = 0
      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
         INFO = -18
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -20
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGSVD', -INFO )
         RETURN
      END IF
!
!     Compute the Frobenius norm of matrices A and B
!
      ANORM = DLANGE( '1', M, N, A, LDA, WORK )
      BNORM = DLANGE( '1', P, N, B, LDB, WORK )
!
!     Get machine precision and set up threshold for determining
!     the effective numerical rank of the matrices A and B.
!
      ULP = DLAMCH( 'Precision' )
      UNFL = DLAMCH( 'Safe Minimum' )
      TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
      TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
!
!     Preprocessing
!
      CALL DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, &
                   TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK, &
                   WORK( N+1 ), INFO )
!
!     Compute the GSVD of two upper "triangular" matrices
!
      CALL DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, &
                   TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, &
                   WORK, NCYCLE, INFO )
!
!     Sort the singular values and store the pivot indices in IWORK
!     Copy ALPHA to WORK, then sort ALPHA in WORK
!
      CALL DCOPY( N, ALPHA, 1, WORK, 1 )
      IBND = MIN( L, M-K )
      DO 20 I = 1, IBND
!
!        Scan for largest ALPHA(K+I)
!
         ISUB = I
         SMAX = WORK( K+I )
         DO 10 J = I + 1, IBND
            TEMP = WORK( K+J )
            IF( TEMP.GT.SMAX ) THEN
               ISUB = J
               SMAX = TEMP
            END IF
   10    CONTINUE
         IF( ISUB.NE.I ) THEN
            WORK( K+ISUB ) = WORK( K+I )
            WORK( K+I ) = SMAX
            IWORK( K+I ) = K + ISUB
         ELSE
            IWORK( K+I ) = K + I
         END IF
   20 CONTINUE
!
      RETURN
!
!     End of DGGSVD
!
      END
      SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, &
                         TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, &
                         IWORK, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOBQ, JOBU, JOBV
      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
      DOUBLE PRECISION   TOLA, TOLB
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ), &
                         TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGGSVP computes orthogonal matrices U, V and Q such that
!
!                   N-K-L  K    L
!   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;
!                L ( 0     0   A23 )
!            M-K-L ( 0     0    0  )
!
!                   N-K-L  K    L
!          =     K ( 0    A12  A13 )  if M-K-L < 0;
!              M-K ( 0     0   A23 )
!
!                 N-K-L  K    L
!   V'*B*Q =   L ( 0     0   B13 )
!            P-L ( 0     0    0  )
!
!  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
!  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
!  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective
!  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the
!  transpose of Z.
!
!  This decomposition is the preprocessing step for computing the
!  Generalized Singular Value Decomposition (GSVD), see subroutine
!  DGGSVD.
!
!  Arguments
!  =========
!
!  JOBU    (input) CHARACTER*1
!          = 'U':  Orthogonal matrix U is computed;
!          = 'N':  U is not computed.
!
!  JOBV    (input) CHARACTER*1
!          = 'V':  Orthogonal matrix V is computed;
!          = 'N':  V is not computed.
!
!  JOBQ    (input) CHARACTER*1
!          = 'Q':  Orthogonal matrix Q is computed;
!          = 'N':  Q is not computed.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  P       (input) INTEGER
!          The number of rows of the matrix B.  P >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A contains the triangular (or trapezoidal) matrix
!          described in the Purpose section.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the P-by-N matrix B.
!          On exit, B contains the triangular matrix described in
!          the Purpose section.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,P).
!
!  TOLA    (input) DOUBLE PRECISION
!  TOLB    (input) DOUBLE PRECISION
!          TOLA and TOLB are the thresholds to determine the effective
!          numerical rank of matrix B and a subblock of A. Generally,
!          they are set to
!             TOLA = MAX(M,N)*norm(A)*MAZHEPS,
!             TOLB = MAX(P,N)*norm(B)*MAZHEPS.
!          The size of TOLA and TOLB may affect the size of backward
!          errors of the decomposition.
!
!  K       (output) INTEGER
!  L       (output) INTEGER
!          On exit, K and L specify the dimension of the subblocks
!          described in Purpose.
!          K + L = effective numerical rank of (A',B')'.
!
!  U       (output) DOUBLE PRECISION array, dimension (LDU,M)
!          If JOBU = 'U', U contains the orthogonal matrix U.
!          If JOBU = 'N', U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U. LDU >= max(1,M) if
!          JOBU = 'U'; LDU >= 1 otherwise.
!
!  V       (output) DOUBLE PRECISION array, dimension (LDV,M)
!          If JOBV = 'V', V contains the orthogonal matrix V.
!          If JOBV = 'N', V is not referenced.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V. LDV >= max(1,P) if
!          JOBV = 'V'; LDV >= 1 otherwise.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
!          If JOBQ = 'Q', Q contains the orthogonal matrix Q.
!          If JOBQ = 'N', Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= max(1,N) if
!          JOBQ = 'Q'; LDQ >= 1 otherwise.
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  TAU     (workspace) DOUBLE PRECISION array, dimension (N)
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!
!  Further Details
!  ===============
!
!  The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
!  with column pivoting to detect the effective numerical rank of the
!  a matrix. It may be replaced by a better rank determination strategy.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FORWRD, WANTQ, WANTU, WANTV
      INTEGER            I, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET, &
                         DORG2R, DORM2R, DORMR2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      WANTU = LSAME( JOBU, 'U' )
      WANTV = LSAME( JOBV, 'V' )
      WANTQ = LSAME( JOBQ, 'Q' )
      FORWRD = .TRUE.
!
      INFO = 0
      IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
         INFO = -18
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -20
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGSVP', -INFO )
         RETURN
      END IF
!
!     QR with column pivoting of B: B*P = V*( S11 S12 )
!                                           (  0   0  )
!
      DO 10 I = 1, N
         IWORK( I ) = 0
   10 CONTINUE
      CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
!
!     Update A := A*P
!
      CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK )
!
!     Determine the effective rank of matrix B.
!
      L = 0
      DO 20 I = 1, MIN( P, N )
         IF( ABS( B( I, I ) ).GT.TOLB ) &
            L = L + 1
   20 CONTINUE
!
      IF( WANTV ) THEN
!
!        Copy the details of V, and form V.
!
         CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
         IF( P.GT.1 ) &
            CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ), &
                         LDV )
         CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
      END IF
!
!     Clean up B
!
      DO 40 J = 1, L - 1
         DO 30 I = J + 1, L
            B( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
      IF( P.GT.L ) &
         CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
!
      IF( WANTQ ) THEN
!
!        Set Q = I and Update Q := Q*P
!
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
         CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
      END IF
!
      IF( P.GE.L .AND. N.NE.L ) THEN
!
!        RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
!
         CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO )
!
!        Update A := A*Z'
!
         CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A, &
                      LDA, WORK, INFO )
!
         IF( WANTQ ) THEN
!
!           Update Q := Q*Z'
!
            CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q, &
                         LDQ, WORK, INFO )
         END IF
!
!        Clean up B
!
         CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
         DO 60 J = N - L + 1, N
            DO 50 I = J - N + L + 1, L
               B( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
!
      END IF
!
!     Let              N-L     L
!                A = ( A11    A12 ) M,
!
!     then the following does the complete QR decomposition of A11:
!
!              A11 = U*(  0  T12 )*P1'
!                      (  0   0  )
!
      DO 70 I = 1, N - L
         IWORK( I ) = 0
   70 CONTINUE
      CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
!
!     Determine the effective rank of A11
!
      K = 0
      DO 80 I = 1, MIN( M, N-L )
         IF( ABS( A( I, I ) ).GT.TOLA ) &
            K = K + 1
   80 CONTINUE
!
!     Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
!
      CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA, &
                   TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
!
      IF( WANTU ) THEN
!
!        Copy the details of U, and form U
!
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
         IF( M.GT.1 ) &
            CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ), &
                         LDU )
         CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
      END IF
!
      IF( WANTQ ) THEN
!
!        Update Q( 1:N, 1:N-L )  = Q( 1:N, 1:N-L )*P1
!
         CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
      END IF
!
!     Clean up A: set the strictly lower triangular part of
!     A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
!
      DO 100 J = 1, K - 1
         DO 90 I = J + 1, K
            A( I, J ) = ZERO
   90    CONTINUE
  100 CONTINUE
      IF( M.GT.K ) &
         CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
!
      IF( N-L.GT.K ) THEN
!
!        RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
!
         CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
!
         IF( WANTQ ) THEN
!
!           Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
!
            CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU, &
                         Q, LDQ, WORK, INFO )
         END IF
!
!        Clean up A
!
         CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
         DO 120 J = N - L - K + 1, N - L
            DO 110 I = J - N + L + K + 1, K
               A( I, J ) = ZERO
  110       CONTINUE
  120    CONTINUE
!
      END IF
!
      IF( M.GT.K ) THEN
!
!        QR factorization of A( K+1:M,N-L+1:N )
!
         CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
!
         IF( WANTU ) THEN
!
!           Update U(:,K+1:M) := U(:,K+1:M)*U1
!
            CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ), &
                         A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU, &
                         WORK, INFO )
         END IF
!
!        Clean up
!
         DO 140 J = N - L + 1, N
            DO 130 I = J - N + K + L + 1, M
               A( I, J ) = ZERO
  130       CONTINUE
  140    CONTINUE
!
      END IF
!
      RETURN
!
!     End of DGGSVP
!
      END
      SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            INFO, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DGTCON estimates the reciprocal of the condition number of a real
!  tridiagonal matrix A using the LU factorization as computed by
!  DGTTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) multipliers that define the matrix L from the
!          LU factorization of A as computed by DGTTRF.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the upper triangular matrix U from
!          the LU factorization of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) elements of the first superdiagonal of U.
!
!  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
!          The (n-2) elements of the second superdiagonal of U.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= n, row i of the matrix was
!          interchanged with row IPIV(i).  IPIV(i) will always be either
!          i or i+1; IPIV(i) = i indicates a row interchange was not
!          required.
!
!  ANORM   (input) DOUBLE PRECISION
!          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!          If NORM = 'I', the infinity-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ONENRM
      INTEGER            I, KASE, KASE1
      DOUBLE PRECISION   AINVNM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGTTRS, DLACON, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      INFO = 0
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
!     Check that D(1:N) is non-zero.
!
      DO 10 I = 1, N
         IF( D( I ).EQ.ZERO ) &
            RETURN
   10 CONTINUE
!
      AINVNM = ZERO
      IF( ONENRM ) THEN
         KASE1 = 1
      ELSE
         KASE1 = 2
      END IF
      KASE = 0
   20 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( KASE.EQ.KASE1 ) THEN
!
!           Multiply by inv(U)*inv(L).
!
            CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV, &
                         WORK, N, INFO )
         ELSE
!
!           Multiply by inv(L')*inv(U').
!
            CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK, &
                         N, INFO )
         END IF
         GO TO 20
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
      RETURN
!
!     End of DGTCON
!
      END
      SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, &
                         IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ), &
                         DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGTRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is tridiagonal, and provides
!  error bounds and backward error estimates for the solution.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of A.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) superdiagonal elements of A.
!
!  DLF     (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) multipliers that define the matrix L from the
!          LU factorization of A as computed by DGTTRF.
!
!  DF      (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the upper triangular matrix U from
!          the LU factorization of A.
!
!  DUF     (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) elements of the first superdiagonal of U.
!
!  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
!          The (n-2) elements of the second superdiagonal of U.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= n, row i of the matrix was
!          interchanged with row IPIV(i).  IPIV(i) will always be either
!          i or i+1; IPIV(i) = i indicates a row interchange was not
!          required.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DGTTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      CHARACTER          TRANSN, TRANST
      INTEGER            COUNT, I, J, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGTTRS, DLACON, DLAGTM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
          LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -15
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANSN = 'N'
         TRANST = 'T'
      ELSE
         TRANSN = 'T'
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = 4
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 110 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A, A**T, or A**H, depending on TRANS.
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE, &
                      WORK( N+1 ), N )
!
!        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
!        error bound.
!
         IF( NOTRAN ) THEN
            IF( N.EQ.1 ) THEN
               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
            ELSE
               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + &
                           ABS( DU( 1 )*X( 2, J ) )
               DO 30 I = 2, N - 1
                  WORK( I ) = ABS( B( I, J ) ) + &
                              ABS( DL( I-1 )*X( I-1, J ) ) + &
                              ABS( D( I )*X( I, J ) ) + &
                              ABS( DU( I )*X( I+1, J ) )
   30          CONTINUE
               WORK( N ) = ABS( B( N, J ) ) + &
                           ABS( DL( N-1 )*X( N-1, J ) ) + &
                           ABS( D( N )*X( N, J ) )
            END IF
         ELSE
            IF( N.EQ.1 ) THEN
               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
            ELSE
               WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) + &
                           ABS( DL( 1 )*X( 2, J ) )
               DO 40 I = 2, N - 1
                  WORK( I ) = ABS( B( I, J ) ) + &
                              ABS( DU( I-1 )*X( I-1, J ) ) + &
                              ABS( D( I )*X( I, J ) ) + &
                              ABS( DL( I )*X( I+1, J ) )
   40          CONTINUE
               WORK( N ) = ABS( B( N, J ) ) + &
                           ABS( DU( N-1 )*X( N-1, J ) ) + &
                           ABS( D( N )*X( N, J ) )
            END IF
         END IF
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         S = ZERO
         DO 50 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   50    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, &
                         WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 60 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   60    CONTINUE
!
         KASE = 0
   70    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)**T).
!
               CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, &
                            WORK( N+1 ), N, INFO )
               DO 80 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
   80          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 90 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
   90          CONTINUE
               CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, &
                            WORK( N+1 ), N, INFO )
            END IF
            GO TO 70
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 100 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  100    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  110 CONTINUE
!
      RETURN
!
!     End of DGTRFS
!
      END
      SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )
!     ..
!
!  Purpose
!  =======
!
!  DGTSV  solves the equation
!
!     A*X = B,
!
!  where A is an n by n tridiagonal matrix, by Gaussian elimination with
!  partial pivoting.
!
!  Note that the equation  A'*X = B  may be solved by interchanging the
!  order of the arguments DU and DL.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, DL must contain the (n-1) sub-diagonal elements of
!          A.
!
!          On exit, DL is overwritten by the (n-2) elements of the
!          second super-diagonal of the upper triangular matrix U from
!          the LU factorization of A, in DL(1), ..., DL(n-2).
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, D must contain the diagonal elements of A.
!
!          On exit, D is overwritten by the n diagonal elements of U.
!
!  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, DU must contain the (n-1) super-diagonal elements
!          of A.
!
!          On exit, DU is overwritten by the (n-1) elements of the first
!          super-diagonal of U.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N by NRHS matrix of right hand side matrix B.
!          On exit, if INFO = 0, the N by NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, U(i,i) is exactly zero, and the solution
!               has not been computed.  The factorization has not been
!               completed unless i = N.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   FACT, TEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSV ', -INFO )
         RETURN
      END IF
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( NRHS.EQ.1 ) THEN
         DO 10 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
!
!              No row interchange required
!
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
!
!              Interchange rows I and I+1
!
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
   10    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      ELSE
         DO 40 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
!
!              No row interchange required
!
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 20 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   20             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
!
!              Interchange rows I and I+1
!
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               DO 30 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   30          CONTINUE
            END IF
   40    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 50 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   50             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               DO 60 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   60          CONTINUE
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      END IF
!
!     Back solve with the matrix U from the factorization.
!
      IF( NRHS.LE.2 ) THEN
         J = 1
   70    CONTINUE
         B( N, J ) = B( N, J ) / D( N )
         IF( N.GT.1 ) &
            B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
         DO 80 I = N - 2, 1, -1
            B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* &
                        B( I+2, J ) ) / D( I )
   80    CONTINUE
         IF( J.LT.NRHS ) THEN
            J = J + 1
            GO TO 70
         END IF
      ELSE
         DO 100 J = 1, NRHS
            B( N, J ) = B( N, J ) / D( N )
            IF( N.GT.1 ) &
               B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / &
                             D( N-1 )
            DO 90 I = N - 2, 1, -1
               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )* &
                           B( I+2, J ) ) / D( I )
   90       CONTINUE
  100    CONTINUE
      END IF
!
      RETURN
!
!     End of DGTSV
!
      END
      SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, &
                         DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          FACT, TRANS
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ), &
                         DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DGTSVX uses the LU factorization to compute the solution to a real
!  system of linear equations A * X = B or A**T * X = B,
!  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
!  matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'N', the LU decomposition is used to factor the matrix A
!     as A = L * U, where L is a product of permutation and unit lower
!     bidiagonal matrices and U is upper triangular with nonzeros in
!     only the main diagonal and first two superdiagonals.
!
!  2. If some U(i,i)=0, so that U is exactly singular, then the routine
!     returns with INFO = i. Otherwise, the factored form of A is used
!     to estimate the condition number of the matrix A.  If the
!     reciprocal of the condition number is less than machine precision,
!     INFO = N+1 is returned as a warning, but the routine still goes on
!     to solve for X and compute error bounds as described below.
!
!  3. The system of equations is solved for X using the factored form
!     of A.
!
!  4. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of A has been
!          supplied on entry.
!          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored
!                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
!                  will not be modified.
!          = 'N':  The matrix will be copied to DLF, DF, and DUF
!                  and factored.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of A.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) superdiagonal elements of A.
!
!  DLF     (input or output) DOUBLE PRECISION array, dimension (N-1)
!          If FACT = 'F', then DLF is an input argument and on entry
!          contains the (n-1) multipliers that define the matrix L from
!          the LU factorization of A as computed by DGTTRF.
!
!          If FACT = 'N', then DLF is an output argument and on exit
!          contains the (n-1) multipliers that define the matrix L from
!          the LU factorization of A.
!
!  DF      (input or output) DOUBLE PRECISION array, dimension (N)
!          If FACT = 'F', then DF is an input argument and on entry
!          contains the n diagonal elements of the upper triangular
!          matrix U from the LU factorization of A.
!
!          If FACT = 'N', then DF is an output argument and on exit
!          contains the n diagonal elements of the upper triangular
!          matrix U from the LU factorization of A.
!
!  DUF     (input or output) DOUBLE PRECISION array, dimension (N-1)
!          If FACT = 'F', then DUF is an input argument and on entry
!          contains the (n-1) elements of the first superdiagonal of U.
!
!          If FACT = 'N', then DUF is an output argument and on exit
!          contains the (n-1) elements of the first superdiagonal of U.
!
!  DU2     (input or output) DOUBLE PRECISION array, dimension (N-2)
!          If FACT = 'F', then DU2 is an input argument and on entry
!          contains the (n-2) elements of the second superdiagonal of
!          U.
!
!          If FACT = 'N', then DU2 is an output argument and on exit
!          contains the (n-2) elements of the second superdiagonal of
!          U.
!
!  IPIV    (input or output) INTEGER array, dimension (N)
!          If FACT = 'F', then IPIV is an input argument and on entry
!          contains the pivot indices from the LU factorization of A as
!          computed by DGTTRF.
!
!          If FACT = 'N', then IPIV is an output argument and on exit
!          contains the pivot indices from the LU factorization of A;
!          row i of the matrix was interchanged with row IPIV(i).
!          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
!          a row interchange was not required.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The N-by-NRHS right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A.  If RCOND is less than the machine precision (in
!          particular, if RCOND = 0), the matrix is singular to working
!          precision.  This condition is indicated by a return code of
!          INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  U(i,i) is exactly zero.  The factorization
!                       has not been completed unless i = N, but the
!                       factor U is exactly singular, so the solution
!                       and error bounds could not be computed.
!                       RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOFACT, NOTRAN
      CHARACTER          NORM
      DOUBLE PRECISION   ANORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGT
      EXTERNAL           LSAME, DLAMCH, DLANGT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSVX', -INFO )
         RETURN
      END IF
!
      IF( NOFACT ) THEN
!
!        Compute the LU factorization of A.
!
         CALL DCOPY( N, D, 1, DF, 1 )
         IF( N.GT.1 ) THEN
            CALL DCOPY( N-1, DL, 1, DLF, 1 )
            CALL DCOPY( N-1, DU, 1, DUF, 1 )
         END IF
         CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      IF( NOTRAN ) THEN
         NORM = '1'
      ELSE
         NORM = 'I'
      END IF
      ANORM = DLANGT( NORM, N, DL, D, DU )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK, &
                   IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution vectors X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX, &
                   INFO )
!
!     Use iterative refinement to improve the computed solutions and
!     compute error bounds and backward error estimates for them.
!
      CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, &
                   B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
      RETURN
!
!     End of DGTSVX
!
      END
      SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   D( * ), DL( * ), DU( * ), DU2( * )
!     ..
!
!  Purpose
!  =======
!
!  DGTTRF computes an LU factorization of a real tridiagonal matrix A
!  using elimination with partial pivoting and row interchanges.
!
!  The factorization has the form
!     A = L * U
!  where L is a product of permutation and unit lower bidiagonal
!  matrices and U is upper triangular with nonzeros in only the main
!  diagonal and first two superdiagonals.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, DL must contain the (n-1) sub-diagonal elements of
!          A.
!
!          On exit, DL is overwritten by the (n-1) multipliers that
!          define the matrix L from the LU factorization of A.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, D must contain the diagonal elements of A.
!
!          On exit, D is overwritten by the n diagonal elements of the
!          upper triangular matrix U from the LU factorization of A.
!
!  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, DU must contain the (n-1) super-diagonal elements
!          of A.
!
!          On exit, DU is overwritten by the (n-1) elements of the first
!          super-diagonal of U.
!
!  DU2     (output) DOUBLE PRECISION array, dimension (N-2)
!          On exit, DU2 is overwritten by the (n-2) elements of the
!          second super-diagonal of U.
!
!  IPIV    (output) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= n, row i of the matrix was
!          interchanged with row IPIV(i).  IPIV(i) will always be either
!          i or i+1; IPIV(i) = i indicates a row interchange was not
!          required.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -k, the k-th argument had an illegal value
!          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   FACT, TEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DGTTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Initialize IPIV(i) = i and DU2(I) = 0
!
      DO 10 I = 1, N
         IPIV( I ) = I
   10 CONTINUE
      DO 20 I = 1, N - 2
         DU2( I ) = ZERO
   20 CONTINUE
!
      DO 30 I = 1, N - 2
         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
!
!           No row interchange required, eliminate DL(I)
!
            IF( D( I ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
!
!           Interchange rows I and I+1, eliminate DL(I)
!
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            DU2( I ) = DU( I+1 )
            DU( I+1 ) = -FACT*DU( I+1 )
            IPIV( I ) = I + 1
         END IF
   30 CONTINUE
      IF( N.GT.1 ) THEN
         I = N - 1
         IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
            IF( D( I ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            IPIV( I ) = I + 1
         END IF
      END IF
!
!     Check for a zero on the diagonal of U.
!
      DO 40 I = 1, N
         IF( D( I ).EQ.ZERO ) THEN
            INFO = I
            GO TO 50
         END IF
   40 CONTINUE
   50 CONTINUE
!
      RETURN
!
!     End of DGTTRF
!
      END
      SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
!     ..
!
!  Purpose
!  =======
!
!  DGTTRS solves one of the systems of equations
!     A*X = B  or  A'*X = B,
!  with a tridiagonal matrix A using the LU factorization computed
!  by DGTTRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER
!          Specifies the form of the system of equations.
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A'* X = B  (Transpose)
!          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) multipliers that define the matrix L from the
!          LU factorization of A.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the upper triangular matrix U from
!          the LU factorization of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) elements of the first super-diagonal of U.
!
!  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
!          The (n-2) elements of the second super-diagonal of U.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= n, row i of the matrix was
!          interchanged with row IPIV(i).  IPIV(i) will always be either
!          i or i+1; IPIV(i) = i indicates a row interchange was not
!          required.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the matrix of right hand side vectors B.
!          On exit, B is overwritten by the solution vectors X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      INTEGER            ITRANS, J, JB, NB
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGTTS2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
      IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ. &
          't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
!     Decode TRANS
!
      IF( NOTRAN ) THEN
         ITRANS = 0
      ELSE
         ITRANS = 1
      END IF
!
!     Determine the number of right-hand sides to solve at a time.
!
      IF( NRHS.EQ.1 ) THEN
         NB = 1
      ELSE
         NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) )
      END IF
!
      IF( NB.GE.NRHS ) THEN
         CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
      ELSE
         DO 10 J = 1, NRHS, NB
            JB = MIN( NRHS-J+1, NB )
            CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ), &
                         LDB )
   10    CONTINUE
      END IF
!
!     End of DGTTRS
!
      END
      SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ITRANS, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
!     ..
!
!  Purpose
!  =======
!
!  DGTTS2 solves one of the systems of equations
!     A*X = B  or  A'*X = B,
!  with a tridiagonal matrix A using the LU factorization computed
!  by DGTTRF.
!
!  Arguments
!  =========
!
!  ITRANS  (input) INTEGER
!          Specifies the form of the system of equations.
!          = 0:  A * X = B  (No transpose)
!          = 1:  A'* X = B  (Transpose)
!          = 2:  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) multipliers that define the matrix L from the
!          LU factorization of A.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the upper triangular matrix U from
!          the LU factorization of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) elements of the first super-diagonal of U.
!
!  DU2     (input) DOUBLE PRECISION array, dimension (N-2)
!          The (n-2) elements of the second super-diagonal of U.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices; for 1 <= i <= n, row i of the matrix was
!          interchanged with row IPIV(i).  IPIV(i) will always be either
!          i or i+1; IPIV(i) = i indicates a row interchange was not
!          required.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the matrix of right hand side vectors B.
!          On exit, B is overwritten by the solution vectors X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IP, J
      DOUBLE PRECISION   TEMP
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( ITRANS.EQ.0 ) THEN
!
!        Solve A*X = B using the LU factorization of A,
!        overwriting each right hand side vector with its solution.
!
         IF( NRHS.LE.1 ) THEN
            J = 1
   10       CONTINUE
!
!           Solve L*x = b.
!
            DO 20 I = 1, N - 1
               IP = IPIV( I )
               TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
               B( I, J ) = B( IP, J )
               B( I+1, J ) = TEMP
   20       CONTINUE
!
!           Solve U*x = b.
!
            B( N, J ) = B( N, J ) / D( N )
            IF( N.GT.1 ) &
               B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / &
                             D( N-1 )
            DO 30 I = N - 2, 1, -1
               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* &
                           B( I+2, J ) ) / D( I )
   30       CONTINUE
            IF( J.LT.NRHS ) THEN
               J = J + 1
               GO TO 10
            END IF
         ELSE
            DO 60 J = 1, NRHS
!
!              Solve L*x = b.
!
               DO 40 I = 1, N - 1
                  IF( IPIV( I ).EQ.I ) THEN
                     B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
                  ELSE
                     TEMP = B( I, J )
                     B( I, J ) = B( I+1, J )
                     B( I+1, J ) = TEMP - DL( I )*B( I, J )
                  END IF
   40          CONTINUE
!
!              Solve U*x = b.
!
               B( N, J ) = B( N, J ) / D( N )
               IF( N.GT.1 ) &
                  B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / &
                                D( N-1 )
               DO 50 I = N - 2, 1, -1
                  B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* &
                              B( I+2, J ) ) / D( I )
   50          CONTINUE
   60       CONTINUE
         END IF
      ELSE
!
!        Solve A' * X = B.
!
         IF( NRHS.LE.1 ) THEN
!
!           Solve U'*x = b.
!
            J = 1
   70       CONTINUE
            B( 1, J ) = B( 1, J ) / D( 1 )
            IF( N.GT.1 ) &
               B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
            DO 80 I = 3, N
               B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* &
                           B( I-2, J ) ) / D( I )
   80       CONTINUE
!
!           Solve L'*x = b.
!
            DO 90 I = N - 1, 1, -1
               IP = IPIV( I )
               TEMP = B( I, J ) - DL( I )*B( I+1, J )
               B( I, J ) = B( IP, J )
               B( IP, J ) = TEMP
   90       CONTINUE
            IF( J.LT.NRHS ) THEN
               J = J + 1
               GO TO 70
            END IF
!
         ELSE
            DO 120 J = 1, NRHS
!
!              Solve U'*x = b.
!
               B( 1, J ) = B( 1, J ) / D( 1 )
               IF( N.GT.1 ) &
                  B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
               DO 100 I = 3, N
                  B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )- &
                              DU2( I-2 )*B( I-2, J ) ) / D( I )
  100          CONTINUE
               DO 110 I = N - 1, 1, -1
                  IF( IPIV( I ).EQ.I ) THEN
                     B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
                  ELSE
                     TEMP = B( I+1, J )
                     B( I+1, J ) = B( I, J ) - DL( I )*TEMP
                     B( I, J ) = TEMP
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      END IF
!
!     End of DGTTS2
!
      END
      SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, &
                         ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, &
                         LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), Q( LDQ, * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DHGEQZ implements a single-/double-shift version of the QZ method for
!  finding the generalized eigenvalues
!
!  w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j)   of the equation
!
!       det( A - w(i) B ) = 0
!
!  In addition, the pair A,B may be reduced to generalized Schur form:
!  B is upper triangular, and A is block upper triangular, where the
!  diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having
!  complex generalized eigenvalues (see the description of the argument
!  JOB.)
!
!  If JOB='S', then the pair (A,B) is simultaneously reduced to Schur
!  form by applying one orthogonal tranformation (usually called Q) on
!  the left and another (usually called Z) on the right.  The 2-by-2
!  upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks
!  of A will be reduced to positive diagonal matrices.  (I.e.,
!  if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and
!  B(j+1,j+1) will be positive.)
!
!  If JOB='E', then at each iteration, the same transformations
!  are computed, but they are only applied to those parts of A and B
!  which are needed to compute ALPHAR, ALPHAI, and BETAR.
!
!  If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal
!  transformations used to reduce (A,B) are accumulated into the arrays
!  Q and Z s.t.:
!
!       Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)*
!       Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)*
!
!  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
!       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
!       pp. 241--256.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          = 'E': compute only ALPHAR, ALPHAI, and BETA.  A and B will
!                 not necessarily be put into generalized Schur form.
!          = 'S': put A and B into generalized Schur form, as well
!                 as computing ALPHAR, ALPHAI, and BETA.
!
!  COMPQ   (input) CHARACTER*1
!          = 'N': do not modify Q.
!          = 'V': multiply the array Q on the right by the transpose of
!                 the orthogonal tranformation that is applied to the
!                 left side of A and B to reduce them to Schur form.
!          = 'I': like COMPQ='V', except that Q will be initialized to
!                 the identity first.
!
!  COMPZ   (input) CHARACTER*1
!          = 'N': do not modify Z.
!          = 'V': multiply the array Z on the right by the orthogonal
!                 tranformation that is applied to the right side of
!                 A and B to reduce them to Schur form.
!          = 'I': like COMPZ='V', except that Z will be initialized to
!                 the identity first.
!
!  N       (input) INTEGER
!          The order of the matrices A, B, Q, and Z.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that A is already upper triangular in rows and
!          columns 1:ILO-1 and IHI+1:N.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the N-by-N upper Hessenberg matrix A.  Elements
!          below the subdiagonal must be zero.
!          If JOB='S', then on exit A and B will have been
!             simultaneously reduced to generalized Schur form.
!          If JOB='E', then on exit A will have been destroyed.
!             The diagonal blocks will be correct, but the off-diagonal
!             portion will be meaningless.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max( 1, N ).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the N-by-N upper triangular matrix B.  Elements
!          below the diagonal must be zero.  2-by-2 blocks in B
!          corresponding to 2-by-2 blocks in A will be reduced to
!          positive diagonal form.  (I.e., if A(j+1,j) is non-zero,
!          then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be
!          positive.)
!          If JOB='S', then on exit A and B will have been
!             simultaneously reduced to Schur form.
!          If JOB='E', then on exit B will have been destroyed.
!             Elements corresponding to diagonal blocks of A will be
!             correct, but the off-diagonal portion will be meaningless.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max( 1, N ).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!          ALPHAR(1:N) will be set to real parts of the diagonal
!          elements of A that would result from reducing A and B to
!          Schur form and then further reducing them both to triangular
!          form using unitary transformations s.t. the diagonal of B
!          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
!          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j).
!          Note that the (real or complex) values
!          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
!          generalized eigenvalues of the matrix pencil A - wB.
!
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!          ALPHAI(1:N) will be set to imaginary parts of the diagonal
!          elements of A that would result from reducing A and B to
!          Schur form and then further reducing them both to triangular
!          form using unitary transformations s.t. the diagonal of B
!          was non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
!          (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0.
!          Note that the (real or complex) values
!          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
!          generalized eigenvalues of the matrix pencil A - wB.
!
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          BETA(1:N) will be set to the (real) diagonal elements of B
!          that would result from reducing A and B to Schur form and
!          then further reducing them both to triangular form using
!          unitary transformations s.t. the diagonal of B was
!          non-negative real.  Thus, if A(j,j) is in a 1-by-1 block
!          (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j).
!          Note that the (real or complex) values
!          (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the
!          generalized eigenvalues of the matrix pencil A - wB.
!          (Note that BETA(1:N) will always be non-negative, and no
!          BETAI is necessary.)
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
!          If COMPQ='N', then Q will not be referenced.
!          If COMPQ='V' or 'I', then the transpose of the orthogonal
!             transformations which are applied to A and B on the left
!             will be applied to the array Q on the right.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  LDQ >= 1.
!          If COMPQ='V' or 'I', then LDQ >= N.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If COMPZ='N', then Z will not be referenced.
!          If COMPZ='V' or 'I', then the orthogonal transformations
!             which are applied to A and B on the right will be applied
!             to the array Z on the right.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1.
!          If COMPZ='V' or 'I', then LDZ >= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,N).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
!                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!                     BETA(i), i=INFO+1,...,N should be correct.
!          = N+1,...,2*N: the shift calculation failed.  (A,B) is not
!                     in Schur form, but ALPHAR(i), ALPHAI(i), and
!                     BETA(i), i=INFO-N+1,...,N should be correct.
!          > 2*N:     various "impossible" errors.
!
!  Further Details
!  ===============
!
!  Iteration counters:
!
!  JITER  -- counts iterations.
!  IITER  -- counts iterations run since ILAST was last
!            changed.  This is therefore reset only when a 1-by-1 or
!            2-by-2 block deflates off the bottom.
!
!  =====================================================================
!
!     .. Parameters ..
!    $                     SAFETY = 1.0E+0 )
      DOUBLE PRECISION   HALF, ZERO, ONE, SAFETY
      PARAMETER          ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, &
                         SAFETY = 1.0D+2 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, &
                         LQUERY
      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, &
                         ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, &
                         JR, MAXIT
      DOUBLE PRECISION   A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, &
                         AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, &
                         AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, &
                         B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, &
                         BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, &
                         CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, &
                         SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T, &
                         TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, &
                         U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, &
                         WR2
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   V( 3 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2, DLAPY3
      EXTERNAL           LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode JOB, COMPQ, COMPZ
!
      IF( LSAME( JOB, 'E' ) ) THEN
         ILSCHR = .FALSE.
         ISCHUR = 1
      ELSE IF( LSAME( JOB, 'S' ) ) THEN
         ILSCHR = .TRUE.
         ISCHUR = 2
      ELSE
         ISCHUR = 0
      END IF
!
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
!
!     Check Argument Values
!
      INFO = 0
      WORK( 1 ) = MAX( 1, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( ISCHUR.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.EQ.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPZ.EQ.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDB.LT.N ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
         INFO = -17
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DHGEQZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         WORK( 1 ) = DBLE( 1 )
         RETURN
      END IF
!
!     Initialize Q and Z
!
      IF( ICOMPQ.EQ.3 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
!
!     Machine Constants
!
      IN = IHI + 1 - ILO
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
      ANORM = DLANHS( 'F', IN, A( ILO, ILO ), LDA, WORK )
      BNORM = DLANHS( 'F', IN, B( ILO, ILO ), LDB, WORK )
      ATOL = MAX( SAFMIN, ULP*ANORM )
      BTOL = MAX( SAFMIN, ULP*BNORM )
      ASCALE = ONE / MAX( SAFMIN, ANORM )
      BSCALE = ONE / MAX( SAFMIN, BNORM )
!
!     Set Eigenvalues IHI+1:N
!
      DO 30 J = IHI + 1, N
         IF( B( J, J ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 10 JR = 1, J
                  A( JR, J ) = -A( JR, J )
                  B( JR, J ) = -B( JR, J )
   10          CONTINUE
            ELSE
               A( J, J ) = -A( J, J )
               B( J, J ) = -B( J, J )
            END IF
            IF( ILZ ) THEN
               DO 20 JR = 1, N
                  Z( JR, J ) = -Z( JR, J )
   20          CONTINUE
            END IF
         END IF
         ALPHAR( J ) = A( J, J )
         ALPHAI( J ) = ZERO
         BETA( J ) = B( J, J )
   30 CONTINUE
!
!     If IHI < ILO, skip QZ steps
!
      IF( IHI.LT.ILO ) &
         GO TO 380
!
!     MAIN QZ ITERATION LOOP
!
!     Initialize dynamic indices
!
!     Eigenvalues ILAST+1:N have been found.
!        Column operations modify rows IFRSTM:whatever.
!        Row operations modify columns whatever:ILASTM.
!
!     If only eigenvalues are being computed, then
!        IFRSTM is the row of the last splitting row above row ILAST;
!        this is always at least ILO.
!     IITER counts iterations since the last eigenvalue was found,
!        to tell when to use an extraordinary shift.
!     MAXIT is the maximum number of QZ sweeps allowed.
!
      ILAST = IHI
      IF( ILSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER = 0
      ESHIFT = ZERO
      MAXIT = 30*( IHI-ILO+1 )
!
      DO 360 JITER = 1, MAXIT
!
!        Split the matrix if possible.
!
!        Two tests:
!           1: A(j,j-1)=0  or  j=ILO
!           2: B(j,j)=0
!
         IF( ILAST.EQ.ILO ) THEN
!
!           Special case: j=ILAST
!
            GO TO 80
         ELSE
            IF( ABS( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
               A( ILAST, ILAST-1 ) = ZERO
               GO TO 80
            END IF
         END IF
!
         IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN
            B( ILAST, ILAST ) = ZERO
            GO TO 70
         END IF
!
!        General case: j<ILAST
!
         DO 60 J = ILAST - 1, ILO, -1
!
!           Test 1: for A(j,j-1)=0 or j=ILO
!
            IF( J.EQ.ILO ) THEN
               ILAZRO = .TRUE.
            ELSE
               IF( ABS( A( J, J-1 ) ).LE.ATOL ) THEN
                  A( J, J-1 ) = ZERO
                  ILAZRO = .TRUE.
               ELSE
                  ILAZRO = .FALSE.
               END IF
            END IF
!
!           Test 2: for B(j,j)=0
!
            IF( ABS( B( J, J ) ).LT.BTOL ) THEN
               B( J, J ) = ZERO
!
!              Test 1a: Check for 2 consecutive small subdiagonals in A
!
               ILAZR2 = .FALSE.
               IF( .NOT.ILAZRO ) THEN
                  TEMP = ABS( A( J, J-1 ) )
                  TEMP2 = ABS( A( J, J ) )
                  TEMPR = MAX( TEMP, TEMP2 )
                  IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
                     TEMP = TEMP / TEMPR
                     TEMP2 = TEMP2 / TEMPR
                  END IF
                  IF( TEMP*( ASCALE*ABS( A( J+1, J ) ) ).LE.TEMP2* &
                      ( ASCALE*ATOL ) )ILAZR2 = .TRUE.
               END IF
!
!              If both tests pass (1 & 2), i.e., the leading diagonal
!              element of B in the block is zero, split a 1x1 block off
!              at the top. (I.e., at the J-th row/column) The leading
!              diagonal element of the remainder can also be zero, so
!              this may have to be done repeatedly.
!
               IF( ILAZRO .OR. ILAZR2 ) THEN
                  DO 40 JCH = J, ILAST - 1
                     TEMP = A( JCH, JCH )
                     CALL DLARTG( TEMP, A( JCH+1, JCH ), C, S, &
                                  A( JCH, JCH ) )
                     A( JCH+1, JCH ) = ZERO
                     CALL DROT( ILASTM-JCH, A( JCH, JCH+1 ), LDA, &
                                A( JCH+1, JCH+1 ), LDA, C, S )
                     CALL DROT( ILASTM-JCH, B( JCH, JCH+1 ), LDB, &
                                B( JCH+1, JCH+1 ), LDB, C, S )
                     IF( ILQ ) &
                        CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, &
                                   C, S )
                     IF( ILAZR2 ) &
                        A( JCH, JCH-1 ) = A( JCH, JCH-1 )*C
                     ILAZR2 = .FALSE.
                     IF( ABS( B( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
                        IF( JCH+1.GE.ILAST ) THEN
                           GO TO 80
                        ELSE
                           IFIRST = JCH + 1
                           GO TO 110
                        END IF
                     END IF
                     B( JCH+1, JCH+1 ) = ZERO
   40             CONTINUE
                  GO TO 70
               ELSE
!
!                 Only test 2 passed -- chase the zero to B(ILAST,ILAST)
!                 Then process as in the case B(ILAST,ILAST)=0
!
                  DO 50 JCH = J, ILAST - 1
                     TEMP = B( JCH, JCH+1 )
                     CALL DLARTG( TEMP, B( JCH+1, JCH+1 ), C, S, &
                                  B( JCH, JCH+1 ) )
                     B( JCH+1, JCH+1 ) = ZERO
                     IF( JCH.LT.ILASTM-1 ) &
                        CALL DROT( ILASTM-JCH-1, B( JCH, JCH+2 ), LDB, &
                                   B( JCH+1, JCH+2 ), LDB, C, S )
                     CALL DROT( ILASTM-JCH+2, A( JCH, JCH-1 ), LDA, &
                                A( JCH+1, JCH-1 ), LDA, C, S )
                     IF( ILQ ) &
                        CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, &
                                   C, S )
                     TEMP = A( JCH+1, JCH )
                     CALL DLARTG( TEMP, A( JCH+1, JCH-1 ), C, S, &
                                  A( JCH+1, JCH ) )
                     A( JCH+1, JCH-1 ) = ZERO
                     CALL DROT( JCH+1-IFRSTM, A( IFRSTM, JCH ), 1, &
                                A( IFRSTM, JCH-1 ), 1, C, S )
                     CALL DROT( JCH-IFRSTM, B( IFRSTM, JCH ), 1, &
                                B( IFRSTM, JCH-1 ), 1, C, S )
                     IF( ILZ ) &
                        CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, &
                                   C, S )
   50             CONTINUE
                  GO TO 70
               END IF
            ELSE IF( ILAZRO ) THEN
!
!              Only test 1 passed -- work on J:ILAST
!
               IFIRST = J
               GO TO 110
            END IF
!
!           Neither test passed -- try next J
!
   60    CONTINUE
!
!        (Drop-through is "impossible")
!
         INFO = N + 1
         GO TO 420
!
!        B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a
!        1x1 block.
!
   70    CONTINUE
         TEMP = A( ILAST, ILAST )
         CALL DLARTG( TEMP, A( ILAST, ILAST-1 ), C, S, &
                      A( ILAST, ILAST ) )
         A( ILAST, ILAST-1 ) = ZERO
         CALL DROT( ILAST-IFRSTM, A( IFRSTM, ILAST ), 1, &
                    A( IFRSTM, ILAST-1 ), 1, C, S )
         CALL DROT( ILAST-IFRSTM, B( IFRSTM, ILAST ), 1, &
                    B( IFRSTM, ILAST-1 ), 1, C, S )
         IF( ILZ ) &
            CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
!
!        A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
!                              and BETA
!
   80    CONTINUE
         IF( B( ILAST, ILAST ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 90 J = IFRSTM, ILAST
                  A( J, ILAST ) = -A( J, ILAST )
                  B( J, ILAST ) = -B( J, ILAST )
   90          CONTINUE
            ELSE
               A( ILAST, ILAST ) = -A( ILAST, ILAST )
               B( ILAST, ILAST ) = -B( ILAST, ILAST )
            END IF
            IF( ILZ ) THEN
               DO 100 J = 1, N
                  Z( J, ILAST ) = -Z( J, ILAST )
  100          CONTINUE
            END IF
         END IF
         ALPHAR( ILAST ) = A( ILAST, ILAST )
         ALPHAI( ILAST ) = ZERO
         BETA( ILAST ) = B( ILAST, ILAST )
!
!        Go to next block -- exit if finished.
!
         ILAST = ILAST - 1
         IF( ILAST.LT.ILO ) &
            GO TO 380
!
!        Reset counters
!
         IITER = 0
         ESHIFT = ZERO
         IF( .NOT.ILSCHR ) THEN
            ILASTM = ILAST
            IF( IFRSTM.GT.ILAST ) &
               IFRSTM = ILO
         END IF
         GO TO 350
!
!        QZ step
!
!        This iteration only involves rows/columns IFIRST:ILAST. We
!        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
!
  110    CONTINUE
         IITER = IITER + 1
         IF( .NOT.ILSCHR ) THEN
            IFRSTM = IFIRST
         END IF
!
!        Compute single shifts.
!
!        At this point, IFIRST < ILAST, and the diagonal elements of
!        B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
!        magnitude)
!
         IF( ( IITER / 10 )*10.EQ.IITER ) THEN
!
!           Exceptional shift.  Chosen for no particularly good reason.
!           (Single shift only.)
!
            IF( ( DBLE( MAXIT )*SAFMIN )*ABS( A( ILAST-1, ILAST ) ).LT. &
                ABS( B( ILAST-1, ILAST-1 ) ) ) THEN
               ESHIFT = ESHIFT + A( ILAST-1, ILAST ) / &
                        B( ILAST-1, ILAST-1 )
            ELSE
               ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
            END IF
            S1 = ONE
            WR = ESHIFT
!
         ELSE
!
!           Shifts based on the generalized eigenvalues of the
!           bottom-right 2x2 block of A and B. The first eigenvalue
!           returned by DLAG2 is the Wilkinson shift (AEP p.512),
!
            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, &
                        B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, &
                        S2, WR, WR2, WI )
!
            TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
            IF( WI.NE.ZERO ) &
               GO TO 200
         END IF
!
!        Fiddle with shift to avoid overflow
!
         TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )
         IF( S1.GT.TEMP ) THEN
            SCALE = TEMP / S1
         ELSE
            SCALE = ONE
         END IF
!
         TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )
         IF( ABS( WR ).GT.TEMP ) &
            SCALE = MIN( SCALE, TEMP / ABS( WR ) )
         S1 = SCALE*S1
         WR = SCALE*WR
!
!        Now check for two consecutive small subdiagonals.
!
         DO 120 J = ILAST - 1, IFIRST + 1, -1
            ISTART = J
            TEMP = ABS( S1*A( J, J-1 ) )
            TEMP2 = ABS( S1*A( J, J )-WR*B( J, J ) )
            TEMPR = MAX( TEMP, TEMP2 )
            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
               TEMP = TEMP / TEMPR
               TEMP2 = TEMP2 / TEMPR
            END IF
            IF( ABS( ( ASCALE*A( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* &
                TEMP2 )GO TO 130
  120    CONTINUE
!
         ISTART = IFIRST
  130    CONTINUE
!
!        Do an implicit single-shift QZ sweep.
!
!        Initial Q
!
         TEMP = S1*A( ISTART, ISTART ) - WR*B( ISTART, ISTART )
         TEMP2 = S1*A( ISTART+1, ISTART )
         CALL DLARTG( TEMP, TEMP2, C, S, TEMPR )
!
!        Sweep
!
         DO 190 J = ISTART, ILAST - 1
            IF( J.GT.ISTART ) THEN
               TEMP = A( J, J-1 )
               CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
               A( J+1, J-1 ) = ZERO
            END IF
!
            DO 140 JC = J, ILASTM
               TEMP = C*A( J, JC ) + S*A( J+1, JC )
               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
               A( J, JC ) = TEMP
               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
               B( J, JC ) = TEMP2
  140       CONTINUE
            IF( ILQ ) THEN
               DO 150 JR = 1, N
                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
                  Q( JR, J ) = TEMP
  150          CONTINUE
            END IF
!
            TEMP = B( J+1, J+1 )
            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
            B( J+1, J ) = ZERO
!
            DO 160 JR = IFRSTM, MIN( J+2, ILAST )
               TEMP = C*A( JR, J+1 ) + S*A( JR, J )
               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
               A( JR, J+1 ) = TEMP
  160       CONTINUE
            DO 170 JR = IFRSTM, J
               TEMP = C*B( JR, J+1 ) + S*B( JR, J )
               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
               B( JR, J+1 ) = TEMP
  170       CONTINUE
            IF( ILZ ) THEN
               DO 180 JR = 1, N
                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
                  Z( JR, J+1 ) = TEMP
  180          CONTINUE
            END IF
  190    CONTINUE
!
         GO TO 350
!
!        Use Francis double-shift
!
!        Note: the Francis double-shift should work with real shifts,
!              but only if the block is at least 3x3.
!              This code may break if this point is reached with
!              a 2x2 block with real eigenvalues.
!
  200    CONTINUE
         IF( IFIRST+1.EQ.ILAST ) THEN
!
!           Special case -- 2x2 block with complex eigenvectors
!
!           Step 1: Standardize, that is, rotate so that
!
!                       ( B11  0  )
!                   B = (         )  with B11 non-negative.
!                       (  0  B22 )
!
            CALL DLASV2( B( ILAST-1, ILAST-1 ), B( ILAST-1, ILAST ), &
                         B( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )
!
            IF( B11.LT.ZERO ) THEN
               CR = -CR
               SR = -SR
               B11 = -B11
               B22 = -B22
            END IF
!
            CALL DROT( ILASTM+1-IFIRST, A( ILAST-1, ILAST-1 ), LDA, &
                       A( ILAST, ILAST-1 ), LDA, CL, SL )
            CALL DROT( ILAST+1-IFRSTM, A( IFRSTM, ILAST-1 ), 1, &
                       A( IFRSTM, ILAST ), 1, CR, SR )
!
            IF( ILAST.LT.ILASTM ) &
               CALL DROT( ILASTM-ILAST, B( ILAST-1, ILAST+1 ), LDB, &
                          B( ILAST, ILAST+1 ), LDA, CL, SL )
            IF( IFRSTM.LT.ILAST-1 ) &
               CALL DROT( IFIRST-IFRSTM, B( IFRSTM, ILAST-1 ), 1, &
                          B( IFRSTM, ILAST ), 1, CR, SR )
!
            IF( ILQ ) &
               CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, &
                          SL )
            IF( ILZ ) &
               CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, &
                          SR )
!
            B( ILAST-1, ILAST-1 ) = B11
            B( ILAST-1, ILAST ) = ZERO
            B( ILAST, ILAST-1 ) = ZERO
            B( ILAST, ILAST ) = B22
!
!           If B22 is negative, negate column ILAST
!
            IF( B22.LT.ZERO ) THEN
               DO 210 J = IFRSTM, ILAST
                  A( J, ILAST ) = -A( J, ILAST )
                  B( J, ILAST ) = -B( J, ILAST )
  210          CONTINUE
!
               IF( ILZ ) THEN
                  DO 220 J = 1, N
                     Z( J, ILAST ) = -Z( J, ILAST )
  220             CONTINUE
               END IF
            END IF
!
!           Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
!
!           Recompute shift
!
            CALL DLAG2( A( ILAST-1, ILAST-1 ), LDA, &
                        B( ILAST-1, ILAST-1 ), LDB, SAFMIN*SAFETY, S1, &
                        TEMP, WR, TEMP2, WI )
!
!           If standardization has perturbed the shift onto real line,
!           do another (real single-shift) QR step.
!
            IF( WI.EQ.ZERO ) &
               GO TO 350
            S1INV = ONE / S1
!
!           Do EISPACK (QZVAL) computation of alpha and beta
!
            A11 = A( ILAST-1, ILAST-1 )
            A21 = A( ILAST, ILAST-1 )
            A12 = A( ILAST-1, ILAST )
            A22 = A( ILAST, ILAST )
!
!           Compute complex Givens rotation on right
!           (Assume some element of C = (sA - wB) > unfl )
!                            __
!           (sA - wB) ( CZ   -SZ )
!                     ( SZ    CZ )
!
            C11R = S1*A11 - WR*B11
            C11I = -WI*B11
            C12 = S1*A12
            C21 = S1*A21
            C22R = S1*A22 - WR*B22
            C22I = -WI*B22
!
            IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ &
                ABS( C22R )+ABS( C22I ) ) THEN
               T = DLAPY3( C12, C11R, C11I )
               CZ = C12 / T
               SZR = -C11R / T
               SZI = -C11I / T
            ELSE
               CZ = DLAPY2( C22R, C22I )
               IF( CZ.LE.SAFMIN ) THEN
                  CZ = ZERO
                  SZR = ONE
                  SZI = ZERO
               ELSE
                  TEMPR = C22R / CZ
                  TEMPI = C22I / CZ
                  T = DLAPY2( CZ, C21 )
                  CZ = CZ / T
                  SZR = -C21*TEMPR / T
                  SZI = C21*TEMPI / T
               END IF
            END IF
!
!           Compute Givens rotation on left
!
!           (  CQ   SQ )
!           (  __      )  A or B
!           ( -SQ   CQ )
!
            AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
            BN = ABS( B11 ) + ABS( B22 )
            WABS = ABS( WR ) + ABS( WI )
            IF( S1*AN.GT.WABS*BN ) THEN
               CQ = CZ*B11
               SQR = SZR*B22
               SQI = -SZI*B22
            ELSE
               A1R = CZ*A11 + SZR*A12
               A1I = SZI*A12
               A2R = CZ*A21 + SZR*A22
               A2I = SZI*A22
               CQ = DLAPY2( A1R, A1I )
               IF( CQ.LE.SAFMIN ) THEN
                  CQ = ZERO
                  SQR = ONE
                  SQI = ZERO
               ELSE
                  TEMPR = A1R / CQ
                  TEMPI = A1I / CQ
                  SQR = TEMPR*A2R + TEMPI*A2I
                  SQI = TEMPI*A2R - TEMPR*A2I
               END IF
            END IF
            T = DLAPY3( CQ, SQR, SQI )
            CQ = CQ / T
            SQR = SQR / T
            SQI = SQI / T
!
!           Compute diagonal elements of QBZ
!
            TEMPR = SQR*SZR - SQI*SZI
            TEMPI = SQR*SZI + SQI*SZR
            B1R = CQ*CZ*B11 + TEMPR*B22
            B1I = TEMPI*B22
            B1A = DLAPY2( B1R, B1I )
            B2R = CQ*CZ*B22 + TEMPR*B11
            B2I = -TEMPI*B11
            B2A = DLAPY2( B2R, B2I )
!
!           Normalize so beta > 0, and Im( alpha1 ) > 0
!
            BETA( ILAST-1 ) = B1A
            BETA( ILAST ) = B2A
            ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
            ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
            ALPHAR( ILAST ) = ( WR*B2A )*S1INV
            ALPHAI( ILAST ) = -( WI*B2A )*S1INV
!
!           Step 3: Go to next block -- exit if finished.
!
            ILAST = IFIRST - 1
            IF( ILAST.LT.ILO ) &
               GO TO 380
!
!           Reset counters
!
            IITER = 0
            ESHIFT = ZERO
            IF( .NOT.ILSCHR ) THEN
               ILASTM = ILAST
               IF( IFRSTM.GT.ILAST ) &
                  IFRSTM = ILO
            END IF
            GO TO 350
         ELSE
!
!           Usual case: 3x3 or larger block, using Francis implicit
!                       double-shift
!
!                                    2
!           Eigenvalue equation is  w  - c w + d = 0,
!
!                                         -1 2        -1
!           so compute 1st column of  (A B  )  - c A B   + d
!           using the formula in QZIT (from EISPACK)
!
!           We assume that the block is at least 3x3
!
            AD11 = ( ASCALE*A( ILAST-1, ILAST-1 ) ) / &
                   ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD21 = ( ASCALE*A( ILAST, ILAST-1 ) ) / &
                   ( BSCALE*B( ILAST-1, ILAST-1 ) )
            AD12 = ( ASCALE*A( ILAST-1, ILAST ) ) / &
                   ( BSCALE*B( ILAST, ILAST ) )
            AD22 = ( ASCALE*A( ILAST, ILAST ) ) / &
                   ( BSCALE*B( ILAST, ILAST ) )
            U12 = B( ILAST-1, ILAST ) / B( ILAST, ILAST )
            AD11L = ( ASCALE*A( IFIRST, IFIRST ) ) / &
                    ( BSCALE*B( IFIRST, IFIRST ) )
            AD21L = ( ASCALE*A( IFIRST+1, IFIRST ) ) / &
                    ( BSCALE*B( IFIRST, IFIRST ) )
            AD12L = ( ASCALE*A( IFIRST, IFIRST+1 ) ) / &
                    ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            AD22L = ( ASCALE*A( IFIRST+1, IFIRST+1 ) ) / &
                    ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            AD32L = ( ASCALE*A( IFIRST+2, IFIRST+1 ) ) / &
                    ( BSCALE*B( IFIRST+1, IFIRST+1 ) )
            U12L = B( IFIRST, IFIRST+1 ) / B( IFIRST+1, IFIRST+1 )
!
            V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + &
                     AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
            V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- &
                     ( AD22-AD11L )+AD21*U12 )*AD21L
            V( 3 ) = AD32L*AD21L
!
            ISTART = IFIRST
!
            CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
            V( 1 ) = ONE
!
!           Sweep
!
            DO 290 J = ISTART, ILAST - 2
!
!              All but last elements: use 3x3 Householder transforms.
!
!              Zero (j-1)st column of A
!
               IF( J.GT.ISTART ) THEN
                  V( 1 ) = A( J, J-1 )
                  V( 2 ) = A( J+1, J-1 )
                  V( 3 ) = A( J+2, J-1 )
!
                  CALL DLARFG( 3, A( J, J-1 ), V( 2 ), 1, TAU )
                  V( 1 ) = ONE
                  A( J+1, J-1 ) = ZERO
                  A( J+2, J-1 ) = ZERO
               END IF
!
               DO 230 JC = J, ILASTM
                  TEMP = TAU*( A( J, JC )+V( 2 )*A( J+1, JC )+V( 3 )* &
                         A( J+2, JC ) )
                  A( J, JC ) = A( J, JC ) - TEMP
                  A( J+1, JC ) = A( J+1, JC ) - TEMP*V( 2 )
                  A( J+2, JC ) = A( J+2, JC ) - TEMP*V( 3 )
                  TEMP2 = TAU*( B( J, JC )+V( 2 )*B( J+1, JC )+V( 3 )* &
                          B( J+2, JC ) )
                  B( J, JC ) = B( J, JC ) - TEMP2
                  B( J+1, JC ) = B( J+1, JC ) - TEMP2*V( 2 )
                  B( J+2, JC ) = B( J+2, JC ) - TEMP2*V( 3 )
  230          CONTINUE
               IF( ILQ ) THEN
                  DO 240 JR = 1, N
                     TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* &
                            Q( JR, J+2 ) )
                     Q( JR, J ) = Q( JR, J ) - TEMP
                     Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
                     Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
  240             CONTINUE
               END IF
!
!              Zero j-th column of B (see DLAGBC for details)
!
!              Swap rows to pivot
!
               ILPIVT = .FALSE.
               TEMP = MAX( ABS( B( J+1, J+1 ) ), ABS( B( J+1, J+2 ) ) )
               TEMP2 = MAX( ABS( B( J+2, J+1 ) ), ABS( B( J+2, J+2 ) ) )
               IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
                  SCALE = ZERO
                  U1 = ONE
                  U2 = ZERO
                  GO TO 250
               ELSE IF( TEMP.GE.TEMP2 ) THEN
                  W11 = B( J+1, J+1 )
                  W21 = B( J+2, J+1 )
                  W12 = B( J+1, J+2 )
                  W22 = B( J+2, J+2 )
                  U1 = B( J+1, J )
                  U2 = B( J+2, J )
               ELSE
                  W21 = B( J+1, J+1 )
                  W11 = B( J+2, J+1 )
                  W22 = B( J+1, J+2 )
                  W12 = B( J+2, J+2 )
                  U2 = B( J+1, J )
                  U1 = B( J+2, J )
               END IF
!
!              Swap columns if nec.
!
               IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
                  ILPIVT = .TRUE.
                  TEMP = W12
                  TEMP2 = W22
                  W12 = W11
                  W22 = W21
                  W11 = TEMP
                  W21 = TEMP2
               END IF
!
!              LU-factor
!
               TEMP = W21 / W11
               U2 = U2 - TEMP*U1
               W22 = W22 - TEMP*W12
               W21 = ZERO
!
!              Compute SCALE
!
               SCALE = ONE
               IF( ABS( W22 ).LT.SAFMIN ) THEN
                  SCALE = ZERO
                  U2 = ONE
                  U1 = -W12 / W11
                  GO TO 250
               END IF
               IF( ABS( W22 ).LT.ABS( U2 ) ) &
                  SCALE = ABS( W22 / U2 )
               IF( ABS( W11 ).LT.ABS( U1 ) ) &
                  SCALE = MIN( SCALE, ABS( W11 / U1 ) )
!
!              Solve
!
               U2 = ( SCALE*U2 ) / W22
               U1 = ( SCALE*U1-W12*U2 ) / W11
!
  250          CONTINUE
               IF( ILPIVT ) THEN
                  TEMP = U2
                  U2 = U1
                  U1 = TEMP
               END IF
!
!              Compute Householder Vector
!
               T = SQRT( SCALE**2+U1**2+U2**2 )
               TAU = ONE + SCALE / T
               VS = -ONE / ( SCALE+T )
               V( 1 ) = ONE
               V( 2 ) = VS*U1
               V( 3 ) = VS*U2
!
!              Apply transformations from the right.
!
               DO 260 JR = IFRSTM, MIN( J+3, ILAST )
                  TEMP = TAU*( A( JR, J )+V( 2 )*A( JR, J+1 )+V( 3 )* &
                         A( JR, J+2 ) )
                  A( JR, J ) = A( JR, J ) - TEMP
                  A( JR, J+1 ) = A( JR, J+1 ) - TEMP*V( 2 )
                  A( JR, J+2 ) = A( JR, J+2 ) - TEMP*V( 3 )
  260          CONTINUE
               DO 270 JR = IFRSTM, J + 2
                  TEMP = TAU*( B( JR, J )+V( 2 )*B( JR, J+1 )+V( 3 )* &
                         B( JR, J+2 ) )
                  B( JR, J ) = B( JR, J ) - TEMP
                  B( JR, J+1 ) = B( JR, J+1 ) - TEMP*V( 2 )
                  B( JR, J+2 ) = B( JR, J+2 ) - TEMP*V( 3 )
  270          CONTINUE
               IF( ILZ ) THEN
                  DO 280 JR = 1, N
                     TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* &
                            Z( JR, J+2 ) )
                     Z( JR, J ) = Z( JR, J ) - TEMP
                     Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
                     Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
  280             CONTINUE
               END IF
               B( J+1, J ) = ZERO
               B( J+2, J ) = ZERO
  290       CONTINUE
!
!           Last elements: Use Givens rotations
!
!           Rotations from the left
!
            J = ILAST - 1
            TEMP = A( J, J-1 )
            CALL DLARTG( TEMP, A( J+1, J-1 ), C, S, A( J, J-1 ) )
            A( J+1, J-1 ) = ZERO
!
            DO 300 JC = J, ILASTM
               TEMP = C*A( J, JC ) + S*A( J+1, JC )
               A( J+1, JC ) = -S*A( J, JC ) + C*A( J+1, JC )
               A( J, JC ) = TEMP
               TEMP2 = C*B( J, JC ) + S*B( J+1, JC )
               B( J+1, JC ) = -S*B( J, JC ) + C*B( J+1, JC )
               B( J, JC ) = TEMP2
  300       CONTINUE
            IF( ILQ ) THEN
               DO 310 JR = 1, N
                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
                  Q( JR, J ) = TEMP
  310          CONTINUE
            END IF
!
!           Rotations from the right.
!
            TEMP = B( J+1, J+1 )
            CALL DLARTG( TEMP, B( J+1, J ), C, S, B( J+1, J+1 ) )
            B( J+1, J ) = ZERO
!
            DO 320 JR = IFRSTM, ILAST
               TEMP = C*A( JR, J+1 ) + S*A( JR, J )
               A( JR, J ) = -S*A( JR, J+1 ) + C*A( JR, J )
               A( JR, J+1 ) = TEMP
  320       CONTINUE
            DO 330 JR = IFRSTM, ILAST - 1
               TEMP = C*B( JR, J+1 ) + S*B( JR, J )
               B( JR, J ) = -S*B( JR, J+1 ) + C*B( JR, J )
               B( JR, J+1 ) = TEMP
  330       CONTINUE
            IF( ILZ ) THEN
               DO 340 JR = 1, N
                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
                  Z( JR, J+1 ) = TEMP
  340          CONTINUE
            END IF
!
!           End of Double-Shift code
!
         END IF
!
         GO TO 350
!
!        End of iteration loop
!
  350    CONTINUE
  360 CONTINUE
!
!     Drop-through = non-convergence
!
  370 CONTINUE
      INFO = ILAST
      GO TO 420
!
!     Successful completion of all QZ steps
!
  380 CONTINUE
!
!     Set Eigenvalues 1:ILO-1
!
      DO 410 J = 1, ILO - 1
         IF( B( J, J ).LT.ZERO ) THEN
            IF( ILSCHR ) THEN
               DO 390 JR = 1, J
                  A( JR, J ) = -A( JR, J )
                  B( JR, J ) = -B( JR, J )
  390          CONTINUE
            ELSE
               A( J, J ) = -A( J, J )
               B( J, J ) = -B( J, J )
            END IF
            IF( ILZ ) THEN
               DO 400 JR = 1, N
                  Z( JR, J ) = -Z( JR, J )
  400          CONTINUE
            END IF
         END IF
         ALPHAR( J ) = A( J, J )
         ALPHAI( J ) = ZERO
         BETA( J ) = B( J, J )
  410 CONTINUE
!
!     Normal Termination
!
      INFO = 0
!
!     Exit (other than argument error) -- return optimal workspace size
!
  420 CONTINUE
      WORK( 1 ) = DBLE( N )
      RETURN
!
!     End of DHGEQZ
!
      END
      SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, &
                         VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, &
                         IFAILR, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          EIGSRC, INITV, SIDE
      INTEGER            INFO, LDH, LDVL, LDVR, M, MM, N
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IFAILL( * ), IFAILR( * )
      DOUBLE PRECISION   H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), &
                         WI( * ), WORK( * ), WR( * )
!     ..
!
!  Purpose
!  =======
!
!  DHSEIN uses inverse iteration to find specified right and/or left
!  eigenvectors of a real upper Hessenberg matrix H.
!
!  The right eigenvector x and the left eigenvector y of the matrix H
!  corresponding to an eigenvalue w are defined by:
!
!               H * x = w * x,     y**h * H = w * y**h
!
!  where y**h denotes the conjugate transpose of the vector y.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'R': compute right eigenvectors only;
!          = 'L': compute left eigenvectors only;
!          = 'B': compute both right and left eigenvectors.
!
!  EIGSRC  (input) CHARACTER*1
!          Specifies the source of eigenvalues supplied in (WR,WI):
!          = 'Q': the eigenvalues were found using DHSEQR; thus, if
!                 H has zero subdiagonal elements, and so is
!                 block-triangular, then the j-th eigenvalue can be
!                 assumed to be an eigenvalue of the block containing
!                 the j-th row/column.  This property allows DHSEIN to
!                 perform inverse iteration on just one diagonal block.
!          = 'N': no assumptions are made on the correspondence
!                 between eigenvalues and diagonal blocks.  In this
!                 case, DHSEIN must always perform inverse iteration
!                 using the whole matrix H.
!
!  INITV   (input) CHARACTER*1
!          = 'N': no initial vectors are supplied;
!          = 'U': user-supplied initial vectors are stored in the arrays
!                 VL and/or VR.
!
!  SELECT  (input/output) LOGICAL array, dimension (N)
!          Specifies the eigenvectors to be computed. To select the
!          real eigenvector corresponding to a real eigenvalue WR(j),
!          SELECT(j) must be set to .TRUE.. To select the complex
!          eigenvector corresponding to a complex eigenvalue
!          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
!          either SELECT(j) or SELECT(j+1) or both must be set to
!          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
!          .FALSE..
!
!  N       (input) INTEGER
!          The order of the matrix H.  N >= 0.
!
!  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
!          The upper Hessenberg matrix H.
!
!  LDH     (input) INTEGER
!          The leading dimension of the array H.  LDH >= max(1,N).
!
!  WR      (input/output) DOUBLE PRECISION array, dimension (N)
!  WI      (input) DOUBLE PRECISION array, dimension (N)
!          On entry, the real and imaginary parts of the eigenvalues of
!          H; a complex conjugate pair of eigenvalues must be stored in
!          consecutive elements of WR and WI.
!          On exit, WR may have been altered since close eigenvalues
!          are perturbed slightly in searching for independent
!          eigenvectors.
!
!  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
!          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
!          contain starting vectors for the inverse iteration for the
!          left eigenvectors; the starting vector for each eigenvector
!          must be in the same column(s) in which the eigenvector will
!          be stored.
!          On exit, if SIDE = 'L' or 'B', the left eigenvectors
!          specified by SELECT will be stored consecutively in the
!          columns of VL, in the same order as their eigenvalues. A
!          complex eigenvector corresponding to a complex eigenvalue is
!          stored in two consecutive columns, the first holding the real
!          part and the second the imaginary part.
!          If SIDE = 'R', VL is not referenced.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL.
!          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
!
!  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
!          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
!          contain starting vectors for the inverse iteration for the
!          right eigenvectors; the starting vector for each eigenvector
!          must be in the same column(s) in which the eigenvector will
!          be stored.
!          On exit, if SIDE = 'R' or 'B', the right eigenvectors
!          specified by SELECT will be stored consecutively in the
!          columns of VR, in the same order as their eigenvalues. A
!          complex eigenvector corresponding to a complex eigenvalue is
!          stored in two consecutive columns, the first holding the real
!          part and the second the imaginary part.
!          If SIDE = 'L', VR is not referenced.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.
!          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
!
!  MM      (input) INTEGER
!          The number of columns in the arrays VL and/or VR. MM >= M.
!
!  M       (output) INTEGER
!          The number of columns in the arrays VL and/or VR required to
!          store the eigenvectors; each selected real eigenvector
!          occupies one column and each selected complex eigenvector
!          occupies two columns.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
!
!  IFAILL  (output) INTEGER array, dimension (MM)
!          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
!          eigenvector in the i-th column of VL (corresponding to the
!          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
!          eigenvector converged satisfactorily. If the i-th and (i+1)th
!          columns of VL hold a complex eigenvector, then IFAILL(i) and
!          IFAILL(i+1) are set to the same value.
!          If SIDE = 'R', IFAILL is not referenced.
!
!  IFAILR  (output) INTEGER array, dimension (MM)
!          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
!          eigenvector in the i-th column of VR (corresponding to the
!          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
!          eigenvector converged satisfactorily. If the i-th and (i+1)th
!          columns of VR hold a complex eigenvector, then IFAILR(i) and
!          IFAILR(i+1) are set to the same value.
!          If SIDE = 'L', IFAILR is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, i is the number of eigenvectors which
!                failed to converge; see IFAILL and IFAILR for further
!                details.
!
!  Further Details
!  ===============
!
!  Each eigenvector is normalized so that the element of largest
!  magnitude has magnitude 1; here the magnitude of a complex number
!  (x,y) is taken to be |x|+|y|.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
      INTEGER            I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
      DOUBLE PRECISION   BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI, &
                         WKR
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANHS
      EXTERNAL           LSAME, DLAMCH, DLANHS
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAEIN, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters.
!
      BOTHV = LSAME( SIDE, 'B' )
      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
!
      FROMQR = LSAME( EIGSRC, 'Q' )
!
      NOINIT = LSAME( INITV, 'N' )
!
!     Set M to the number of columns required to store the selected
!     eigenvectors, and standardize the array SELECT.
!
      M = 0
      PAIR = .FALSE.
      DO 10 K = 1, N
         IF( PAIR ) THEN
            PAIR = .FALSE.
            SELECT( K ) = .FALSE.
         ELSE
            IF( WI( K ).EQ.ZERO ) THEN
               IF( SELECT( K ) ) &
                  M = M + 1
            ELSE
               PAIR = .TRUE.
               IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
                  SELECT( K ) = .TRUE.
                  M = M + 2
               END IF
            END IF
         END IF
   10 CONTINUE
!
      INFO = 0
      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -1
      ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
         INFO = -13
      ELSE IF( MM.LT.M ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DHSEIN', -INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Set machine-dependent constants.
!
      UNFL = DLAMCH( 'Safe minimum' )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( N / ULP )
      BIGNUM = ( ONE-ULP ) / SMLNUM
!
      LDWORK = N + 1
!
      KL = 1
      KLN = 0
      IF( FROMQR ) THEN
         KR = 0
      ELSE
         KR = N
      END IF
      KSR = 1
!
      DO 120 K = 1, N
         IF( SELECT( K ) ) THEN
!
!           Compute eigenvector(s) corresponding to W(K).
!
            IF( FROMQR ) THEN
!
!              If affiliation of eigenvalues is known, check whether
!              the matrix splits.
!
!              Determine KL and KR such that 1 <= KL <= K <= KR <= N
!              and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
!              KR = N).
!
!              Then inverse iteration can be performed with the
!              submatrix H(KL:N,KL:N) for a left eigenvector, and with
!              the submatrix H(1:KR,1:KR) for a right eigenvector.
!
               DO 20 I = K, KL + 1, -1
                  IF( H( I, I-1 ).EQ.ZERO ) &
                     GO TO 30
   20          CONTINUE
   30          CONTINUE
               KL = I
               IF( K.GT.KR ) THEN
                  DO 40 I = K, N - 1
                     IF( H( I+1, I ).EQ.ZERO ) &
                        GO TO 50
   40             CONTINUE
   50             CONTINUE
                  KR = I
               END IF
            END IF
!
            IF( KL.NE.KLN ) THEN
               KLN = KL
!
!              Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
!              has not ben computed before.
!
               HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
               IF( HNORM.GT.ZERO ) THEN
                  EPS3 = HNORM*ULP
               ELSE
                  EPS3 = SMLNUM
               END IF
            END IF
!
!           Perturb eigenvalue if it is close to any previous
!           selected eigenvalues affiliated to the submatrix
!           H(KL:KR,KL:KR). Close roots are modified by EPS3.
!
            WKR = WR( K )
            WKI = WI( K )
   60       CONTINUE
            DO 70 I = K - 1, KL, -1
               IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+ &
                   ABS( WI( I )-WKI ).LT.EPS3 ) THEN
                  WKR = WKR + EPS3
                  GO TO 60
               END IF
   70       CONTINUE
            WR( K ) = WKR
!
            PAIR = WKI.NE.ZERO
            IF( PAIR ) THEN
               KSI = KSR + 1
            ELSE
               KSI = KSR
            END IF
            IF( LEFTV ) THEN
!
!              Compute left eigenvector.
!
               CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH, &
                            WKR, WKI, VL( KL, KSR ), VL( KL, KSI ), &
                            WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM, &
                            BIGNUM, IINFO )
               IF( IINFO.GT.0 ) THEN
                  IF( PAIR ) THEN
                     INFO = INFO + 2
                  ELSE
                     INFO = INFO + 1
                  END IF
                  IFAILL( KSR ) = K
                  IFAILL( KSI ) = K
               ELSE
                  IFAILL( KSR ) = 0
                  IFAILL( KSI ) = 0
               END IF
               DO 80 I = 1, KL - 1
                  VL( I, KSR ) = ZERO
   80          CONTINUE
               IF( PAIR ) THEN
                  DO 90 I = 1, KL - 1
                     VL( I, KSI ) = ZERO
   90             CONTINUE
               END IF
            END IF
            IF( RIGHTV ) THEN
!
!              Compute right eigenvector.
!
               CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI, &
                            VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK, &
                            WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM, &
                            IINFO )
               IF( IINFO.GT.0 ) THEN
                  IF( PAIR ) THEN
                     INFO = INFO + 2
                  ELSE
                     INFO = INFO + 1
                  END IF
                  IFAILR( KSR ) = K
                  IFAILR( KSI ) = K
               ELSE
                  IFAILR( KSR ) = 0
                  IFAILR( KSI ) = 0
               END IF
               DO 100 I = KR + 1, N
                  VR( I, KSR ) = ZERO
  100          CONTINUE
               IF( PAIR ) THEN
                  DO 110 I = KR + 1, N
                     VR( I, KSI ) = ZERO
  110             CONTINUE
               END IF
            END IF
!
            IF( PAIR ) THEN
               KSR = KSR + 2
            ELSE
               KSR = KSR + 1
            END IF
         END IF
  120 CONTINUE
!
      RETURN
!
!     End of DHSEIN
!
      END
      SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, &
                         LDZ, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H
!  and, optionally, the matrices T and Z from the Schur decomposition
!  H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
!  form), and Z is the orthogonal matrix of Schur vectors.
!
!  Optionally Z may be postmultiplied into an input orthogonal matrix Q,
!  so that this routine can give the Schur factorization of a matrix A
!  which has been reduced to the Hessenberg form H by the orthogonal
!  matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          = 'E':  compute eigenvalues only;
!          = 'S':  compute eigenvalues and the Schur form T.
!
!  COMPZ   (input) CHARACTER*1
!          = 'N':  no Schur vectors are computed;
!          = 'I':  Z is initialized to the unit matrix and the matrix Z
!                  of Schur vectors of H is returned;
!          = 'V':  Z must contain an orthogonal matrix Q on entry, and
!                  the product Q*Z is returned.
!
!  N       (input) INTEGER
!          The order of the matrix H.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that H is already upper triangular in rows
!          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
!          set by a previous call to DGEBAL, and then passed to SGEHRD
!          when the matrix output by DGEBAL is reduced to Hessenberg
!          form. Otherwise ILO and IHI should be set to 1 and N
!          respectively.
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
!          On entry, the upper Hessenberg matrix H.
!          On exit, if JOB = 'S', H contains the upper quasi-triangular
!          matrix T from the Schur decomposition (the Schur form);
!          2-by-2 diagonal blocks (corresponding to complex conjugate
!          pairs of eigenvalues) are returned in standard form, with
!          H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E',
!          the contents of H are unspecified on exit.
!
!  LDH     (input) INTEGER
!          The leading dimension of the array H. LDH >= max(1,N).
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          The real and imaginary parts, respectively, of the computed
!          eigenvalues. If two eigenvalues are computed as a complex
!          conjugate pair, they are stored in consecutive elements of
!          WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
!          WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
!          same order as on the diagonal of the Schur form returned in
!          H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
!          diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and
!          WI(i+1) = -WI(i).
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          If COMPZ = 'N': Z is not referenced.
!          If COMPZ = 'I': on entry, Z need not be set, and on exit, Z
!          contains the orthogonal matrix Z of the Schur vectors of H.
!          If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q,
!          which is assumed to be equal to the unit matrix except for
!          the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z.
!          Normally Q is the orthogonal matrix generated by DORGHR after
!          the call to DGEHRD which formed the Hessenberg matrix H.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.
!          LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,N).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, DHSEQR failed to compute all of the
!                eigenvalues in a total of 30*(IHI-ILO+1) iterations;
!                elements 1:ilo-1 and i+1:n of WR and WI contain those
!                eigenvalues which have been successfully computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
      DOUBLE PRECISION   CONST
      PARAMETER          ( CONST = 1.5D+0 )
      INTEGER            NSMAX, LDS
      PARAMETER          ( NSMAX = 15, LDS = NSMAX )
!     ..
!     .. Local Scalars ..
      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
      INTEGER            I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L, &
                         MAXB, NH, NR, NS, NV
      DOUBLE PRECISION   ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, ILAENV
      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2
      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DLACPY, DLAHQR, DLARFG, DLARFX, &
                         DLASET, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      WANTT = LSAME( JOB, 'S' )
      INITZ = LSAME( COMPZ, 'I' )
      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
!
      INFO = 0
      WORK( 1 ) = MAX( 1, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -5
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DHSEQR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Initialize Z, if necessary
!
      IF( INITZ ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
!
!     Store the eigenvalues isolated by DGEBAL.
!
      DO 10 I = 1, ILO - 1
         WR( I ) = H( I, I )
         WI( I ) = ZERO
   10 CONTINUE
      DO 20 I = IHI + 1, N
         WR( I ) = H( I, I )
         WI( I ) = ZERO
   20 CONTINUE
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
      IF( ILO.EQ.IHI ) THEN
         WR( ILO ) = H( ILO, ILO )
         WI( ILO ) = ZERO
         RETURN
      END IF
!
!     Set rows and columns ILO to IHI to zero below the first
!     subdiagonal.
!
      DO 40 J = ILO, IHI - 2
         DO 30 I = J + 2, N
            H( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
      NH = IHI - ILO + 1
!
!     Determine the order of the multi-shift QR algorithm to be used.
!
      NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
      MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
      IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
!
!        Use the standard double-shift algorithm
!
         CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO, &
                      IHI, Z, LDZ, INFO )
         RETURN
      END IF
      MAXB = MAX( 3, MAXB )
      NS = MIN( NS, MAXB, NSMAX )
!
!     Now 2 < NS <= MAXB < NH.
!
!     Set machine-dependent constants for the stopping criterion.
!     If norm(H) <= sqrt(OVFL), overflow should not occur.
!
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( NH / ULP )
!
!     I1 and I2 are the indices of the first row and last column of H
!     to which transformations must be applied. If eigenvalues only are
!     being computed, I1 and I2 are set inside the main loop.
!
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
!
!     ITN is the total number of multiple-shift QR iterations allowed.
!
      ITN = 30*NH
!
!     The main loop begins here. I is the loop index and decreases from
!     IHI to ILO in steps of at most MAXB. Each iteration of the loop
!     works with the active submatrix in rows and columns L to I.
!     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
!     H(L,L-1) is negligible so that the matrix splits.
!
      I = IHI
   50 CONTINUE
      L = ILO
      IF( I.LT.ILO ) &
         GO TO 170
!
!     Perform multiple-shift QR iterations on rows and columns ILO to I
!     until a submatrix of order at most MAXB splits off at the bottom
!     because a subdiagonal element has become negligible.
!
      DO 150 ITS = 0, ITN
!
!        Look for a single small subdiagonal element.
!
         DO 60 K = I, L + 1, -1
            TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
            IF( TST1.EQ.ZERO ) &
               TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
            IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) &
               GO TO 70
   60    CONTINUE
   70    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
!
!           H(L,L-1) is negligible.
!
            H( L, L-1 ) = ZERO
         END IF
!
!        Exit from loop if a submatrix of order <= MAXB has split off.
!
         IF( L.GE.I-MAXB+1 ) &
            GO TO 160
!
!        Now the active submatrix is in rows and columns L to I. If
!        eigenvalues only are being computed, only the active submatrix
!        need be transformed.
!
         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
!
         IF( ITS.EQ.20 .OR. ITS.EQ.30 ) THEN
!
!           Exceptional shifts.
!
            DO 80 II = I - NS + 1, I
               WR( II ) = CONST*( ABS( H( II, II-1 ) )+ &
                          ABS( H( II, II ) ) )
               WI( II ) = ZERO
   80       CONTINUE
         ELSE
!
!           Use eigenvalues of trailing submatrix of order NS as shifts.
!
            CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S, &
                         LDS )
            CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS, &
                         WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ, &
                         IERR )
            IF( IERR.GT.0 ) THEN
!
!              If DLAHQR failed to compute all NS eigenvalues, use the
!              unconverged diagonal elements as the remaining shifts.
!
               DO 90 II = 1, IERR
                  WR( I-NS+II ) = S( II, II )
                  WI( I-NS+II ) = ZERO
   90          CONTINUE
            END IF
         END IF
!
!        Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
!        where G is the Hessenberg submatrix H(L:I,L:I) and w is
!        the vector of shifts (stored in WR and WI). The result is
!        stored in the local array V.
!
         V( 1 ) = ONE
         DO 100 II = 2, NS + 1
            V( II ) = ZERO
  100    CONTINUE
         NV = 1
         DO 120 J = I - NS + 1, I
            IF( WI( J ).GE.ZERO ) THEN
               IF( WI( J ).EQ.ZERO ) THEN
!
!                 real shift
!
                  CALL DCOPY( NV+1, V, 1, VV, 1 )
                  CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), &
                              LDH, VV, 1, -WR( J ), V, 1 )
                  NV = NV + 1
               ELSE IF( WI( J ).GT.ZERO ) THEN
!
!                 complex conjugate pair of shifts
!
                  CALL DCOPY( NV+1, V, 1, VV, 1 )
                  CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), &
                              LDH, V, 1, -TWO*WR( J ), VV, 1 )
                  ITEMP = IDAMAX( NV+1, VV, 1 )
                  TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM )
                  CALL DSCAL( NV+1, TEMP, VV, 1 )
                  ABSW = DLAPY2( WR( J ), WI( J ) )
                  TEMP = ( TEMP*ABSW )*ABSW
                  CALL DGEMV( 'No transpose', NV+2, NV+1, ONE, &
                              H( L, L ), LDH, VV, 1, TEMP, V, 1 )
                  NV = NV + 2
               END IF
!
!              Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
!              reset it to the unit vector.
!
               ITEMP = IDAMAX( NV, V, 1 )
               TEMP = ABS( V( ITEMP ) )
               IF( TEMP.EQ.ZERO ) THEN
                  V( 1 ) = ONE
                  DO 110 II = 2, NV
                     V( II ) = ZERO
  110             CONTINUE
               ELSE
                  TEMP = MAX( TEMP, SMLNUM )
                  CALL DSCAL( NV, ONE / TEMP, V, 1 )
               END IF
            END IF
  120    CONTINUE
!
!        Multiple-shift QR step
!
         DO 140 K = L, I - 1
!
!           The first iteration of this loop determines a reflection G
!           from the vector V and applies it from left and right to H,
!           thus creating a nonzero bulge below the subdiagonal.
!
!           Each subsequent iteration determines a reflection G to
!           restore the Hessenberg form in the (K-1)th column, and thus
!           chases the bulge one step toward the bottom of the active
!           submatrix. NR is the order of G.
!
            NR = MIN( NS+1, I-K+1 )
            IF( K.GT.L ) &
               CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
            IF( K.GT.L ) THEN
               H( K, K-1 ) = V( 1 )
               DO 130 II = K + 1, I
                  H( II, K-1 ) = ZERO
  130          CONTINUE
            END IF
            V( 1 ) = ONE
!
!           Apply G from the left to transform the rows of the matrix in
!           columns K to I2.
!
            CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH, &
                         WORK )
!
!           Apply G from the right to transform the columns of the
!           matrix in rows I1 to min(K+NR,I).
!
            CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU, &
                         H( I1, K ), LDH, WORK )
!
            IF( WANTZ ) THEN
!
!              Accumulate transformations in the matrix Z
!
               CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ, &
                            WORK )
            END IF
  140    CONTINUE
!
  150 CONTINUE
!
!     Failure to converge in remaining number of iterations
!
      INFO = I
      RETURN
!
  160 CONTINUE
!
!     A submatrix of order <= MAXB in rows and columns L to I has split
!     off. Use the double-shift QR algorithm to handle it.
!
      CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z, &
                   LDZ, INFO )
      IF( INFO.GT.0 ) &
         RETURN
!
!     Decrement number of remaining iterations, and return to start of
!     the main loop with a new value of I.
!
      ITN = ITN - ITS
      I = L - 1
      GO TO 50
!
  170 CONTINUE
      WORK( 1 ) = MAX( 1, N )
      RETURN
!
!     End of DHSEQR
!
      END
      SUBROUTINE DLABAD( SMALL, LARGE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   LARGE, SMALL
!     ..
!
!  Purpose
!  =======
!
!  DLABAD takes as input the values computed by DLAMCH for underflow and
!  overflow, and returns the square root of each of these values if the
!  log of LARGE is sufficiently large.  This subroutine is intended to
!  identify machines with a large exponent range, such as the Crays, and
!  redefine the underflow and overflow limits to be the square roots of
!  the values computed by DLAMCH.  This subroutine is needed because
!  DLAMCH does not compensate for poor arithmetic in the upper half of
!  the exponent range, as is found on a Cray.
!
!  Arguments
!  =========
!
!  SMALL   (input/output) DOUBLE PRECISION
!          On entry, the underflow threshold as computed by DLAMCH.
!          On exit, if LOG10(LARGE) is sufficiently large, the square
!          root of SMALL, otherwise unchanged.
!
!  LARGE   (input/output) DOUBLE PRECISION
!          On entry, the overflow threshold as computed by DLAMCH.
!          On exit, if LOG10(LARGE) is sufficiently large, the square
!          root of LARGE, otherwise unchanged.
!
!  =====================================================================
!
!     .. Intrinsic Functions ..
      INTRINSIC          LOG10, SQRT
!     ..
!     .. Executable Statements ..
!
!     If it looks like we're on a Cray, take the square root of
!     SMALL and LARGE to avoid overflow and underflow problems.
!
      IF( LOG10( LARGE ).GT.2000.D0 ) THEN
         SMALL = SQRT( SMALL )
         LARGE = SQRT( LARGE )
      END IF
!
      RETURN
!
!     End of DLABAD
!
      END
      SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, &
                         LDY )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            LDA, LDX, LDY, M, N, NB
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ), &
                         TAUQ( * ), X( LDX, * ), Y( LDY, * )
!     ..
!
!  Purpose
!  =======
!
!  DLABRD reduces the first NB rows and columns of a real general
!  m by n matrix A to upper or lower bidiagonal form by an orthogonal
!  transformation Q' * A * P, and returns the matrices X and Y which
!  are needed to apply the transformation to the unreduced part of A.
!
!  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
!  bidiagonal form.
!
!  This is an auxiliary routine called by DGEBRD
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows in the matrix A.
!
!  N       (input) INTEGER
!          The number of columns in the matrix A.
!
!  NB      (input) INTEGER
!          The number of leading rows and columns of A to be reduced.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n general matrix to be reduced.
!          On exit, the first NB rows and columns of the matrix are
!          overwritten; the rest of the array is unchanged.
!          If m >= n, elements on and below the diagonal in the first NB
!            columns, with the array TAUQ, represent the orthogonal
!            matrix Q as a product of elementary reflectors; and
!            elements above the diagonal in the first NB rows, with the
!            array TAUP, represent the orthogonal matrix P as a product
!            of elementary reflectors.
!          If m < n, elements below the diagonal in the first NB
!            columns, with the array TAUQ, represent the orthogonal
!            matrix Q as a product of elementary reflectors, and
!            elements on and above the diagonal in the first NB rows,
!            with the array TAUP, represent the orthogonal matrix P as
!            a product of elementary reflectors.
!          See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  D       (output) DOUBLE PRECISION array, dimension (NB)
!          The diagonal elements of the first NB rows and columns of
!          the reduced matrix.  D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (NB)
!          The off-diagonal elements of the first NB rows and columns of
!          the reduced matrix.
!
!  TAUQ    (output) DOUBLE PRECISION array dimension (NB)
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix Q. See Further Details.
!
!  TAUP    (output) DOUBLE PRECISION array, dimension (NB)
!          The scalar factors of the elementary reflectors which
!          represent the orthogonal matrix P. See Further Details.
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NB)
!          The m-by-nb matrix X required to update the unreduced part
!          of A.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X. LDX >= M.
!
!  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
!          The n-by-nb matrix Y required to update the unreduced part
!          of A.
!
!  LDY     (output) INTEGER
!          The leading dimension of the array Y. LDY >= N.
!
!  Further Details
!  ===============
!
!  The matrices Q and P are represented as products of elementary
!  reflectors:
!
!     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
!
!  Each H(i) and G(i) has the form:
!
!     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
!
!  where tauq and taup are real scalars, and v and u are real vectors.
!
!  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
!  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
!  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
!  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
!  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
!
!  The elements of the vectors v and u together form the m-by-nb matrix
!  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
!  the transformation to the unreduced part of the matrix, using a block
!  update of the form:  A := A - V*Y' - X*U'.
!
!  The contents of A on exit are illustrated by the following examples
!  with nb = 2:
!
!  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!
!    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
!    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
!    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
!    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
!    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
!    (  v1  v2  a   a   a  )
!
!  where a denotes an element of the original matrix which is unchanged,
!  vi denotes an element of the vector defining H(i), and ui an element
!  of the vector defining G(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DLARFG, DSCAL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( M.LE.0 .OR. N.LE.0 ) &
         RETURN
!
      IF( M.GE.N ) THEN
!
!        Reduce to upper bidiagonal form
!
         DO 10 I = 1, NB
!
!           Update A(i:m,i)
!
            CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), &
                        LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
            CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), &
                        LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
!
!           Generate reflection Q(i) to annihilate A(i+1:m,i)
!
            CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, &
                         TAUQ( I ) )
            D( I ) = A( I, I )
            IF( I.LT.N ) THEN
               A( I, I ) = ONE
!
!              Compute Y(i+1:n,i)
!
               CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), &
                           LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, &
                           A( I, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), &
                           LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, &
                           A( I, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), &
                           LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
!
!              Update A(i,i+1:n)
!
               CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), &
                           LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
               CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), &
                           LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
!
!              Generate reflection P(i) to annihilate A(i,i+2:n)
!
               CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), &
                            LDA, TAUP( I ) )
               E( I ) = A( I, I+1 )
               A( I, I+1 ) = ONE
!
!              Compute X(i+1:m,i)
!
               CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), &
                           LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, &
                           A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), &
                           LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), &
                           LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), &
                           LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
            END IF
   10    CONTINUE
      ELSE
!
!        Reduce to lower bidiagonal form
!
         DO 20 I = 1, NB
!
!           Update A(i,i:n)
!
            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), &
                        LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
            CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, &
                        X( I, 1 ), LDX, ONE, A( I, I ), LDA )
!
!           Generate reflection P(i) to annihilate A(i,i+1:n)
!
            CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, &
                         TAUP( I ) )
            D( I ) = A( I, I )
            IF( I.LT.M ) THEN
               A( I, I ) = ONE
!
!              Compute X(i+1:m,i)
!
               CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), &
                           LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, &
                           A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), &
                           LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), &
                           LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), &
                           LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
!
!              Update A(i+1:m,i)
!
               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), &
                           LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
               CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), &
                           LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
!
!              Generate reflection Q(i) to annihilate A(i+2:m,i)
!
               CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, &
                            TAUQ( I ) )
               E( I ) = A( I+1, I )
               A( I+1, I ) = ONE
!
!              Compute Y(i+1:n,i)
!
               CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), &
                           LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, &
                           A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), &
                           LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, &
                           A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
               CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, &
                           Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DLABRD
!
      END
      SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            KASE, N
      DOUBLE PRECISION   EST
!     ..
!     .. Array Arguments ..
      INTEGER            ISGN( * )
      DOUBLE PRECISION   V( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLACON estimates the 1-norm of a square, real matrix A.
!  Reverse communication is used for evaluating matrix-vector products.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The order of the matrix.  N >= 1.
!
!  V      (workspace) DOUBLE PRECISION array, dimension (N)
!         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!         (W is not returned).
!
!  X      (input/output) DOUBLE PRECISION array, dimension (N)
!         On an intermediate return, X should be overwritten by
!               A * X,   if KASE=1,
!               A' * X,  if KASE=2,
!         and DLACON must be re-called with all the other parameters
!         unchanged.
!
!  ISGN   (workspace) INTEGER array, dimension (N)
!
!  EST    (output) DOUBLE PRECISION
!         An estimate (a lower bound) for norm(A).
!
!  KASE   (input/output) INTEGER
!         On the initial call to DLACON, KASE should be 0.
!         On an intermediate return, KASE will be 1 or 2, indicating
!         whether X should be overwritten by A * X  or A' * X.
!         On the final return from DLACON, KASE will again be 0.
!
!  Further Details
!  ======= =======
!
!  Contributed by Nick Higham, University of Manchester.
!  Originally named SONEST, dated March 16, 1988.
!
!  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
!  a real or complex matrix, with applications to condition estimation",
!  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ITER, J, JLAST, JUMP
      DOUBLE PRECISION   ALTSGN, ESTOLD, TEMP
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM
      EXTERNAL           IDAMAX, DASUM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, NINT, SIGN
!     ..
!     .. Save statement ..
      SAVE
!     ..
!     .. Executable Statements ..
!
      IF( KASE.EQ.0 ) THEN
         DO 10 I = 1, N
            X( I ) = ONE / DBLE( N )
   10    CONTINUE
         KASE = 1
         JUMP = 1
         RETURN
      END IF
!
      GO TO ( 20, 40, 70, 110, 140 )JUMP
!
!     ................ ENTRY   (JUMP = 1)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
!
   20 CONTINUE
      IF( N.EQ.1 ) THEN
         V( 1 ) = X( 1 )
         EST = ABS( V( 1 ) )
!        ... QUIT
         GO TO 150
      END IF
      EST = DASUM( N, X, 1 )
!
      DO 30 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
   30 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
!
!     ................ ENTRY   (JUMP = 2)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
!
   40 CONTINUE
      J = IDAMAX( N, X, 1 )
      ITER = 2
!
!     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
!
   50 CONTINUE
      DO 60 I = 1, N
         X( I ) = ZERO
   60 CONTINUE
      X( J ) = ONE
      KASE = 1
      JUMP = 3
      RETURN
!
!     ................ ENTRY   (JUMP = 3)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
   70 CONTINUE
      CALL DCOPY( N, X, 1, V, 1 )
      ESTOLD = EST
      EST = DASUM( N, V, 1 )
      DO 80 I = 1, N
         IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) &
            GO TO 90
   80 CONTINUE
!     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
      GO TO 120
!
   90 CONTINUE
!     TEST FOR CYCLING.
      IF( EST.LE.ESTOLD ) &
         GO TO 120
!
      DO 100 I = 1, N
         X( I ) = SIGN( ONE, X( I ) )
         ISGN( I ) = NINT( X( I ) )
  100 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
!
!     ................ ENTRY   (JUMP = 4)
!     X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X.
!
  110 CONTINUE
      JLAST = J
      J = IDAMAX( N, X, 1 )
      IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
         ITER = ITER + 1
         GO TO 50
      END IF
!
!     ITERATION COMPLETE.  FINAL STAGE.
!
  120 CONTINUE
      ALTSGN = ONE
      DO 130 I = 1, N
         X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
         ALTSGN = -ALTSGN
  130 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
!
!     ................ ENTRY   (JUMP = 5)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
  140 CONTINUE
      TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
      IF( TEMP.GT.EST ) THEN
         CALL DCOPY( N, X, 1, V, 1 )
         EST = TEMP
      END IF
!
  150 CONTINUE
      KASE = 0
      RETURN
!
!     End of DLACON
!
      END
      SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDB, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DLACPY copies all or part of a two-dimensional matrix A to another
!  matrix B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies the part of the matrix A to be copied to B.
!          = 'U':      Upper triangular part
!          = 'L':      Lower triangular part
!          Otherwise:  All of the matrix A
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The m by n matrix A.  If UPLO = 'U', only the upper triangle
!          or trapezoid is accessed; if UPLO = 'L', only the lower
!          triangle or trapezoid is accessed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
!          On exit, B = A in the locations specified by UPLO.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,M).
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO 20 J = 1, N
            DO 10 I = 1, MIN( J, M )
               B( I, J ) = A( I, J )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
         DO 40 J = 1, N
            DO 30 I = J, M
               B( I, J ) = A( I, J )
   30       CONTINUE
   40    CONTINUE
      ELSE
         DO 60 J = 1, N
            DO 50 I = 1, M
               B( I, J ) = A( I, J )
   50       CONTINUE
   60    CONTINUE
      END IF
      RETURN
!
!     End of DLACPY
!
      END
      SUBROUTINE DLADIV( A, B, C, D, P, Q )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, D, P, Q
!     ..
!
!  Purpose
!  =======
!
!  DLADIV performs complex division in  real arithmetic
!
!                        a + i*b
!             p + i*q = ---------
!                        c + i*d
!
!  The algorithm is due to Robert L. Smith and can be found
!  in D. Knuth, The art of Computer Programming, Vol.2, p.195
!
!  Arguments
!  =========
!
!  A       (input) DOUBLE PRECISION
!  B       (input) DOUBLE PRECISION
!  C       (input) DOUBLE PRECISION
!  D       (input) DOUBLE PRECISION
!          The scalars a, b, c, and d in the above expression.
!
!  P       (output) DOUBLE PRECISION
!  Q       (output) DOUBLE PRECISION
!          The scalars p and q in the above expression.
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION   E, F
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      IF( ABS( D ).LT.ABS( C ) ) THEN
         E = D / C
         F = C + D*E
         P = ( A+B*E ) / F
         Q = ( B-A*E ) / F
      ELSE
         E = C / D
         F = D + C*E
         P = ( B+A*E ) / F
         Q = ( -A+B*E ) / F
      END IF
!
      RETURN
!
!     End of DLADIV
!
      END
      SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, RT1, RT2
!     ..
!
!  Purpose
!  =======
!
!  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
!     [  A   B  ]
!     [  B   C  ].
!  On return, RT1 is the eigenvalue of larger absolute value, and RT2
!  is the eigenvalue of smaller absolute value.
!
!  Arguments
!  =========
!
!  A       (input) DOUBLE PRECISION
!          The (1,1) element of the 2-by-2 matrix.
!
!  B       (input) DOUBLE PRECISION
!          The (1,2) and (2,1) elements of the 2-by-2 matrix.
!
!  C       (input) DOUBLE PRECISION
!          The (2,2) element of the 2-by-2 matrix.
!
!  RT1     (output) DOUBLE PRECISION
!          The eigenvalue of larger absolute value.
!
!  RT2     (output) DOUBLE PRECISION
!          The eigenvalue of smaller absolute value.
!
!  Further Details
!  ===============
!
!  RT1 is accurate to a few ulps barring over/underflow.
!
!  RT2 may be inaccurate if there is massive cancellation in the
!  determinant A*C-B*B; higher precision or correctly rounded or
!  correctly truncated arithmetic would be needed to compute RT2
!  accurately in all cases.
!
!  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!  Underflow is harmless if the input data is 0 or exceeds
!     underflow_threshold / macheps.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   AB, ACMN, ACMX, ADF, DF, RT, SM, TB
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
!     Compute the eigenvalues
!
      SM = A + C
      DF = A - C
      ADF = ABS( DF )
      TB = B + B
      AB = ABS( TB )
      IF( ABS( A ).GT.ABS( C ) ) THEN
         ACMX = A
         ACMN = C
      ELSE
         ACMX = C
         ACMN = A
      END IF
      IF( ADF.GT.AB ) THEN
         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
      ELSE IF( ADF.LT.AB ) THEN
         RT = AB*SQRT( ONE+( ADF / AB )**2 )
      ELSE
!
!        Includes case AB=ADF=0
!
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
!
!        Includes case RT1 = RT2 = 0
!
         RT1 = HALF*RT
         RT2 = -HALF*RT
      END IF
      RETURN
!
!     End of DLAE2
!
      END
      SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, &
                         RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, &
                         NAB, WORK, IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
      DOUBLE PRECISION   ABSTOL, PIVMIN, RELTOL
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
      DOUBLE PRECISION   AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAEBZ contains the iteration loops which compute and use the
!  function N(w), which is the count of eigenvalues of a symmetric
!  tridiagonal matrix T less than or equal to its argument  w.  It
!  performs a choice of two types of loops:
!
!  IJOB=1, followed by
!  IJOB=2: It takes as input a list of intervals and returns a list of
!          sufficiently small intervals whose union contains the same
!          eigenvalues as the union of the original intervals.
!          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
!          The output interval (AB(j,1),AB(j,2)] will contain
!          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
!
!  IJOB=3: It performs a binary search in each input interval
!          (AB(j,1),AB(j,2)] for a point  w(j)  such that
!          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of
!          the search.  If such a w(j) is found, then on output
!          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output
!          (AB(j,1),AB(j,2)] will be a small interval containing the
!          point where N(w) jumps through NVAL(j), unless that point
!          lies outside the initial interval.
!
!  Note that the intervals are in all cases half-open intervals,
!  i.e., of the form  (a,b] , which includes  b  but not  a .
!
!  To avoid underflow, the matrix should be scaled so that its largest
!  element is no greater than  overflow**(1/2) * underflow**(1/4)
!  in absolute value.  To assure the most accurate computation
!  of small eigenvalues, the matrix should be scaled to be
!  not much smaller than that, either.
!
!  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!  Matrix", Report CS41, Computer Science Dept., Stanford
!  University, July 21, 1966
!
!  Note: the arguments are, in general, *not* checked for unreasonable
!  values.
!
!  Arguments
!  =========
!
!  IJOB    (input) INTEGER
!          Specifies what is to be done:
!          = 1:  Compute NAB for the initial intervals.
!          = 2:  Perform bisection iteration to find eigenvalues of T.
!          = 3:  Perform bisection iteration to invert N(w), i.e.,
!                to find a point which has a specified number of
!                eigenvalues of T to its left.
!          Other values will cause DLAEBZ to return with INFO=-1.
!
!  NITMAX  (input) INTEGER
!          The maximum number of "levels" of bisection to be
!          performed, i.e., an interval of width W will not be made
!          smaller than 2^(-NITMAX) * W.  If not all intervals
!          have converged after NITMAX iterations, then INFO is set
!          to the number of non-converged intervals.
!
!  N       (input) INTEGER
!          The dimension n of the tridiagonal matrix T.  It must be at
!          least 1.
!
!  MMAX    (input) INTEGER
!          The maximum number of intervals.  If more than MMAX intervals
!          are generated, then DLAEBZ will quit with INFO=MMAX+1.
!
!  MINP    (input) INTEGER
!          The initial number of intervals.  It may not be greater than
!          MMAX.
!
!  NBMIN   (input) INTEGER
!          The smallest number of intervals that should be processed
!          using a vector loop.  If zero, then only the scalar loop
!          will be used.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The minimum (absolute) width of an interval.  When an
!          interval is narrower than ABSTOL, or than RELTOL times the
!          larger (in magnitude) endpoint, then it is considered to be
!          sufficiently small, i.e., converged.  This must be at least
!          zero.
!
!  RELTOL  (input) DOUBLE PRECISION
!          The minimum relative width of an interval.  When an interval
!          is narrower than ABSTOL, or than RELTOL times the larger (in
!          magnitude) endpoint, then it is considered to be
!          sufficiently small, i.e., converged.  Note: this should
!          always be at least radix*machine epsilon.
!
!  PIVMIN  (input) DOUBLE PRECISION
!          The minimum absolute value of a "pivot" in the Sturm
!          sequence loop.  This *must* be at least  max |e(j)**2| *
!          safe_min  and at least safe_min, where safe_min is at least
!          the smallest number that can divide one without overflow.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T.
!
!  E       (input) DOUBLE PRECISION array, dimension (N)
!          The offdiagonal elements of the tridiagonal matrix T in
!          positions 1 through N-1.  E(N) is arbitrary.
!
!  E2      (input) DOUBLE PRECISION array, dimension (N)
!          The squares of the offdiagonal elements of the tridiagonal
!          matrix T.  E2(N) is ignored.
!
!  NVAL    (input/output) INTEGER array, dimension (MINP)
!          If IJOB=1 or 2, not referenced.
!          If IJOB=3, the desired values of N(w).  The elements of NVAL
!          will be reordered to correspond with the intervals in AB.
!          Thus, NVAL(j) on output will not, in general be the same as
!          NVAL(j) on input, but it will correspond with the interval
!          (AB(j,1),AB(j,2)] on output.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (MMAX,2)
!          The endpoints of the intervals.  AB(j,1) is  a(j), the left
!          endpoint of the j-th interval, and AB(j,2) is b(j), the
!          right endpoint of the j-th interval.  The input intervals
!          will, in general, be modified, split, and reordered by the
!          calculation.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (MMAX)
!          If IJOB=1, ignored.
!          If IJOB=2, workspace.
!          If IJOB=3, then on input C(j) should be initialized to the
!          first search point in the binary search.
!
!  MOUT    (output) INTEGER
!          If IJOB=1, the number of eigenvalues in the intervals.
!          If IJOB=2 or 3, the number of intervals output.
!          If IJOB=3, MOUT will equal MINP.
!
!  NAB     (input/output) INTEGER array, dimension (MMAX,2)
!          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
!          If IJOB=2, then on input, NAB(i,j) should be set.  It must
!             satisfy the condition:
!             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
!             which means that in interval i only eigenvalues
!             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,
!             NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
!             IJOB=1.
!             On output, NAB(i,j) will contain
!             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
!             the input interval that the output interval
!             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
!             the input values of NAB(k,1) and NAB(k,2).
!          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
!             unless N(w) > NVAL(i) for all search points  w , in which
!             case NAB(i,1) will not be modified, i.e., the output
!             value will be the same as the input value (modulo
!             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
!             for all search points  w , in which case NAB(i,2) will
!             not be modified.  Normally, NAB should be set to some
!             distinctive value(s) before DLAEBZ is called.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (MMAX)
!          Workspace.
!
!  IWORK   (workspace) INTEGER array, dimension (MMAX)
!          Workspace.
!
!  INFO    (output) INTEGER
!          = 0:       All intervals converged.
!          = 1--MMAX: The last INFO intervals did not converge.
!          = MMAX+1:  More than MMAX intervals were generated.
!
!  Further Details
!  ===============
!
!      This routine is intended to be called only by other LAPACK
!  routines, thus the interface is less user-friendly.  It is intended
!  for two purposes:
!
!  (a) finding eigenvalues.  In this case, DLAEBZ should have one or
!      more initial intervals set up in AB, and DLAEBZ should be called
!      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
!      Intervals with no eigenvalues would usually be thrown out at
!      this point.  Also, if not all the eigenvalues in an interval i
!      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
!      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
!      eigenvalue.  DLAEBZ is then called with IJOB=2 and MMAX
!      no smaller than the value of MOUT returned by the call with
!      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
!      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
!      tolerance specified by ABSTOL and RELTOL.
!
!  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
!      In this case, start with a Gershgorin interval  (a,b).  Set up
!      AB to contain 2 search intervals, both initially (a,b).  One
!      NVAL element should contain  f-1  and the other should contain  l
!      , while C should contain a and b, resp.  NAB(i,1) should be -1
!      and NAB(i,2) should be N+1, to flag an error if the desired
!      interval does not lie in (a,b).  DLAEBZ is then called with
!      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
!      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
!      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
!      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
!      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
!      w(l-r)=...=w(l+k) are handled similarly.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO, HALF
      PARAMETER          ( ZERO = 0.0D0, TWO = 2.0D0, &
                         HALF = 1.0D0 / TWO )
!     ..
!     .. Local Scalars ..
      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, &
                         KLNEW
      DOUBLE PRECISION   TMP1, TMP2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Check for Errors
!
      INFO = 0
      IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
         INFO = -1
         RETURN
      END IF
!
!     Initialize NAB
!
      IF( IJOB.EQ.1 ) THEN
!
!        Compute the number of eigenvalues in the initial intervals.
!
         MOUT = 0
!DIR$ NOVECTOR
         DO 30 JI = 1, MINP
            DO 20 JP = 1, 2
               TMP1 = D( 1 ) - AB( JI, JP )
               IF( ABS( TMP1 ).LT.PIVMIN ) &
                  TMP1 = -PIVMIN
               NAB( JI, JP ) = 0
               IF( TMP1.LE.ZERO ) &
                  NAB( JI, JP ) = 1
!
               DO 10 J = 2, N
                  TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
                  IF( ABS( TMP1 ).LT.PIVMIN ) &
                     TMP1 = -PIVMIN
                  IF( TMP1.LE.ZERO ) &
                     NAB( JI, JP ) = NAB( JI, JP ) + 1
   10          CONTINUE
   20       CONTINUE
            MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
   30    CONTINUE
         RETURN
      END IF
!
!     Initialize for loop
!
!     KF and KL have the following meaning:
!        Intervals 1,...,KF-1 have converged.
!        Intervals KF,...,KL  still need to be refined.
!
      KF = 1
      KL = MINP
!
!     If IJOB=2, initialize C.
!     If IJOB=3, use the user-supplied starting point.
!
      IF( IJOB.EQ.2 ) THEN
         DO 40 JI = 1, MINP
            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
   40    CONTINUE
      END IF
!
!     Iteration loop
!
      DO 130 JIT = 1, NITMAX
!
!        Loop over intervals
!
         IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
!
!           Begin of Parallel Version of the loop
!
            DO 60 JI = KF, KL
!
!              Compute N(c), the number of eigenvalues less than c
!
               WORK( JI ) = D( 1 ) - C( JI )
               IWORK( JI ) = 0
               IF( WORK( JI ).LE.PIVMIN ) THEN
                  IWORK( JI ) = 1
                  WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
               END IF
!
               DO 50 J = 2, N
                  WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
                  IF( WORK( JI ).LE.PIVMIN ) THEN
                     IWORK( JI ) = IWORK( JI ) + 1
                     WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
                  END IF
   50          CONTINUE
   60       CONTINUE
!
            IF( IJOB.LE.2 ) THEN
!
!              IJOB=2: Choose all intervals containing eigenvalues.
!
               KLNEW = KL
               DO 70 JI = KF, KL
!
!                 Insure that N(w) is monotone
!
                  IWORK( JI ) = MIN( NAB( JI, 2 ), &
                                MAX( NAB( JI, 1 ), IWORK( JI ) ) )
!
!                 Update the Queue -- add intervals if both halves
!                 contain eigenvalues.
!
                  IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
!
!                    No eigenvalue in the upper interval:
!                    just use the lower interval.
!
                     AB( JI, 2 ) = C( JI )
!
                  ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
!
!                    No eigenvalue in the lower interval:
!                    just use the upper interval.
!
                     AB( JI, 1 ) = C( JI )
                  ELSE
                     KLNEW = KLNEW + 1
                     IF( KLNEW.LE.MMAX ) THEN
!
!                       Eigenvalue in both intervals -- add upper to
!                       queue.
!
                        AB( KLNEW, 2 ) = AB( JI, 2 )
                        NAB( KLNEW, 2 ) = NAB( JI, 2 )
                        AB( KLNEW, 1 ) = C( JI )
                        NAB( KLNEW, 1 ) = IWORK( JI )
                        AB( JI, 2 ) = C( JI )
                        NAB( JI, 2 ) = IWORK( JI )
                     ELSE
                        INFO = MMAX + 1
                     END IF
                  END IF
   70          CONTINUE
               IF( INFO.NE.0 ) &
                  RETURN
               KL = KLNEW
            ELSE
!
!              IJOB=3: Binary search.  Keep only the interval containing
!                      w   s.t. N(w) = NVAL
!
               DO 80 JI = KF, KL
                  IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
                     AB( JI, 1 ) = C( JI )
                     NAB( JI, 1 ) = IWORK( JI )
                  END IF
                  IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
                     AB( JI, 2 ) = C( JI )
                     NAB( JI, 2 ) = IWORK( JI )
                  END IF
   80          CONTINUE
            END IF
!
         ELSE
!
!           End of Parallel Version of the loop
!
!           Begin of Serial Version of the loop
!
            KLNEW = KL
            DO 100 JI = KF, KL
!
!              Compute N(w), the number of eigenvalues less than w
!
               TMP1 = C( JI )
               TMP2 = D( 1 ) - TMP1
               ITMP1 = 0
               IF( TMP2.LE.PIVMIN ) THEN
                  ITMP1 = 1
                  TMP2 = MIN( TMP2, -PIVMIN )
               END IF
!
!              A series of compiler directives to defeat vectorization
!              for the next loop
!
!$PL$ CMCHAR=' '
!DIR$          NEXTSCALAR
!$DIR          SCALAR
!DIR$          NEXT SCALAR
!VD$L          NOVECTOR
!DEC$          NOVECTOR
!VD$           NOVECTOR
!VDIR          NOVECTOR
!VOCL          LOOP,SCALAR
!IBM           PREFER SCALAR
!$PL$ CMCHAR='*'
!
               DO 90 J = 2, N
                  TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
                  IF( TMP2.LE.PIVMIN ) THEN
                     ITMP1 = ITMP1 + 1
                     TMP2 = MIN( TMP2, -PIVMIN )
                  END IF
   90          CONTINUE
!
               IF( IJOB.LE.2 ) THEN
!
!                 IJOB=2: Choose all intervals containing eigenvalues.
!
!                 Insure that N(w) is monotone
!
                  ITMP1 = MIN( NAB( JI, 2 ), &
                          MAX( NAB( JI, 1 ), ITMP1 ) )
!
!                 Update the Queue -- add intervals if both halves
!                 contain eigenvalues.
!
                  IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
!
!                    No eigenvalue in the upper interval:
!                    just use the lower interval.
!
                     AB( JI, 2 ) = TMP1
!
                  ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
!
!                    No eigenvalue in the lower interval:
!                    just use the upper interval.
!
                     AB( JI, 1 ) = TMP1
                  ELSE IF( KLNEW.LT.MMAX ) THEN
!
!                    Eigenvalue in both intervals -- add upper to queue.
!
                     KLNEW = KLNEW + 1
                     AB( KLNEW, 2 ) = AB( JI, 2 )
                     NAB( KLNEW, 2 ) = NAB( JI, 2 )
                     AB( KLNEW, 1 ) = TMP1
                     NAB( KLNEW, 1 ) = ITMP1
                     AB( JI, 2 ) = TMP1
                     NAB( JI, 2 ) = ITMP1
                  ELSE
                     INFO = MMAX + 1
                     RETURN
                  END IF
               ELSE
!
!                 IJOB=3: Binary search.  Keep only the interval
!                         containing  w  s.t. N(w) = NVAL
!
                  IF( ITMP1.LE.NVAL( JI ) ) THEN
                     AB( JI, 1 ) = TMP1
                     NAB( JI, 1 ) = ITMP1
                  END IF
                  IF( ITMP1.GE.NVAL( JI ) ) THEN
                     AB( JI, 2 ) = TMP1
                     NAB( JI, 2 ) = ITMP1
                  END IF
               END IF
  100       CONTINUE
            KL = KLNEW
!
!           End of Serial Version of the loop
!
         END IF
!
!        Check for convergence
!
         KFNEW = KF
         DO 110 JI = KF, KL
            TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
            TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
            IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. &
                NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
!
!              Converged -- Swap with position KFNEW,
!                           then increment KFNEW
!
               IF( JI.GT.KFNEW ) THEN
                  TMP1 = AB( JI, 1 )
                  TMP2 = AB( JI, 2 )
                  ITMP1 = NAB( JI, 1 )
                  ITMP2 = NAB( JI, 2 )
                  AB( JI, 1 ) = AB( KFNEW, 1 )
                  AB( JI, 2 ) = AB( KFNEW, 2 )
                  NAB( JI, 1 ) = NAB( KFNEW, 1 )
                  NAB( JI, 2 ) = NAB( KFNEW, 2 )
                  AB( KFNEW, 1 ) = TMP1
                  AB( KFNEW, 2 ) = TMP2
                  NAB( KFNEW, 1 ) = ITMP1
                  NAB( KFNEW, 2 ) = ITMP2
                  IF( IJOB.EQ.3 ) THEN
                     ITMP1 = NVAL( JI )
                     NVAL( JI ) = NVAL( KFNEW )
                     NVAL( KFNEW ) = ITMP1
                  END IF
               END IF
               KFNEW = KFNEW + 1
            END IF
  110    CONTINUE
         KF = KFNEW
!
!        Choose Midpoints
!
         DO 120 JI = KF, KL
            C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
  120    CONTINUE
!
!        If no more intervals to refine, quit.
!
         IF( KF.GT.KL ) &
            GO TO 140
  130 CONTINUE
!
!     Converged
!
  140 CONTINUE
      INFO = MAX( KL+1-KF, 0 )
      MOUT = KL
!
      RETURN
!
!     End of DLAEBZ
!
      END
      SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED0 computes all eigenvalues and corresponding eigenvectors of a
!  symmetric tridiagonal matrix using the divide and conquer method.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          = 0:  Compute eigenvalues only.
!          = 1:  Compute eigenvectors of original dense symmetric matrix
!                also.  On entry, Q contains the orthogonal matrix used
!                to reduce the original matrix to tridiagonal form.
!          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
!                matrix.
!
!  QSIZ   (input) INTEGER
!         The dimension of the orthogonal matrix used to reduce
!         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry, the main diagonal of the tridiagonal matrix.
!         On exit, its eigenvalues.
!
!  E      (input) DOUBLE PRECISION array, dimension (N-1)
!         The off-diagonal elements of the tridiagonal matrix.
!         On exit, E has been destroyed.
!
!  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
!         On entry, Q must contain an N-by-N orthogonal matrix.
!         If ICOMPQ = 0    Q is not referenced.
!         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
!                          orthogonal matrix used to reduce the full
!                          matrix to tridiagonal form corresponding to
!                          the subset of the full matrix which is being
!                          decomposed at this time.
!         If ICOMPQ = 2    On entry, Q will be the identity matrix.
!                          On exit, Q contains the eigenvectors of the
!                          tridiagonal matrix.
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  If eigenvectors are
!         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
!
!  QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
!         Referenced only when ICOMPQ = 1.  Used to store parts of
!         the eigenvector matrix when the updating matrix multiplies
!         take place.
!
!  LDQS   (input) INTEGER
!         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
!         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
!
!  WORK   (workspace) DOUBLE PRECISION array,
!         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
!                     1 + 3*N + 2*N*lg N + 2*N**2
!                     ( lg( N ) = smallest integer k
!                                 such that 2^k >= N )
!         If ICOMPQ = 2, the dimension of WORK must be at least
!                     4*N + N**2.
!
!  IWORK  (workspace) INTEGER array,
!         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
!                        6 + 6*N + 5*N*lg N.
!                        ( lg( N ) = smallest integer k
!                                    such that 2^k >= N )
!         If ICOMPQ = 2, the dimension of IWORK must be at least
!                        3 + 5*N.
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  The algorithm failed to compute an eigenvalue while
!                working on the submatrix lying in rows and columns
!                INFO/(N+1) through mod(INFO,N+1).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, &
                         IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, &
                         J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, &
                         SPM2, SUBMAT, SUBPBS, TLVLS
      DOUBLE PRECISION   TEMP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, &
                         XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
         INFO = -1
      ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED0', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
!
!     Determine the size and placement of the submatrices, and save in
!     the leading elements of IWORK.
!
      IWORK( 1 ) = N
      SUBPBS = 1
      TLVLS = 0
   10 CONTINUE
      IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
         DO 20 J = SUBPBS, 1, -1
            IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
            IWORK( 2*J-1 ) = IWORK( J ) / 2
   20    CONTINUE
         TLVLS = TLVLS + 1
         SUBPBS = 2*SUBPBS
         GO TO 10
      END IF
      DO 30 J = 2, SUBPBS
         IWORK( J ) = IWORK( J ) + IWORK( J-1 )
   30 CONTINUE
!
!     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
!     using rank-1 modifications (cuts).
!
      SPM1 = SUBPBS - 1
      DO 40 I = 1, SPM1
         SUBMAT = IWORK( I ) + 1
         SMM1 = SUBMAT - 1
         D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
         D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
   40 CONTINUE
!
      INDXQ = 4*N + 3
      IF( ICOMPQ.NE.2 ) THEN
!
!        Set up workspaces for eigenvalues only/accumulate new vectors
!        routine
!
         TEMP = LOG( DBLE( N ) ) / LOG( TWO )
         LGN = INT( TEMP )
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IPRMPT = INDXQ + N + 1
         IPERM = IPRMPT + N*LGN
         IQPTR = IPERM + N*LGN
         IGIVPT = IQPTR + N + 2
         IGIVCL = IGIVPT + N*LGN
!
         IGIVNM = 1
         IQ = IGIVNM + 2*N*LGN
         IWREM = IQ + N**2 + 1
!
!        Initialize pointers
!
         DO 50 I = 0, SUBPBS
            IWORK( IPRMPT+I ) = 1
            IWORK( IGIVPT+I ) = 1
   50    CONTINUE
         IWORK( IQPTR ) = 1
      END IF
!
!     Solve each submatrix eigenproblem at the bottom of the divide and
!     conquer tree.
!
      CURR = 0
      DO 70 I = 0, SPM1
         IF( I.EQ.0 ) THEN
            SUBMAT = 1
            MATSIZ = IWORK( 1 )
         ELSE
            SUBMAT = IWORK( I ) + 1
            MATSIZ = IWORK( I+1 ) - IWORK( I )
         END IF
         IF( ICOMPQ.EQ.2 ) THEN
            CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), &
                         Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
            IF( INFO.NE.0 ) &
               GO TO 130
         ELSE
            CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), &
                         WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, &
                         INFO )
            IF( INFO.NE.0 ) &
               GO TO 130
            IF( ICOMPQ.EQ.1 ) THEN
               CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, &
                           Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ &
                           CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), &
                           LDQS )
            END IF
            IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
            CURR = CURR + 1
         END IF
         K = 1
         DO 60 J = SUBMAT, IWORK( I+1 )
            IWORK( INDXQ+J ) = K
            K = K + 1
   60    CONTINUE
   70 CONTINUE
!
!     Successively merge eigensystems of adjacent submatrices
!     into eigensystem for the corresponding larger matrix.
!
!     while ( SUBPBS > 1 )
!
      CURLVL = 1
   80 CONTINUE
      IF( SUBPBS.GT.1 ) THEN
         SPM2 = SUBPBS - 2
         DO 90 I = 0, SPM2, 2
            IF( I.EQ.0 ) THEN
               SUBMAT = 1
               MATSIZ = IWORK( 2 )
               MSD2 = IWORK( 1 )
               CURPRB = 0
            ELSE
               SUBMAT = IWORK( I ) + 1
               MATSIZ = IWORK( I+2 ) - IWORK( I )
               MSD2 = MATSIZ / 2
               CURPRB = CURPRB + 1
            END IF
!
!     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
!     into an eigensystem of size MATSIZ.
!     DLAED1 is used only for the full eigensystem of a tridiagonal
!     matrix.
!     DLAED7 handles the cases in which eigenvalues only or eigenvalues
!     and eigenvectors of a full symmetric matrix (which was reduced to
!     tridiagonal form) are desired.
!
            IF( ICOMPQ.EQ.2 ) THEN
               CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), &
                            LDQ, IWORK( INDXQ+SUBMAT ), &
                            E( SUBMAT+MSD2-1 ), MSD2, WORK, &
                            IWORK( SUBPBS+1 ), INFO )
            ELSE
               CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, &
                            D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, &
                            IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), &
                            MSD2, WORK( IQ ), IWORK( IQPTR ), &
                            IWORK( IPRMPT ), IWORK( IPERM ), &
                            IWORK( IGIVPT ), IWORK( IGIVCL ), &
                            WORK( IGIVNM ), WORK( IWREM ), &
                            IWORK( SUBPBS+1 ), INFO )
            END IF
            IF( INFO.NE.0 ) &
               GO TO 130
            IWORK( I / 2+1 ) = IWORK( I+2 )
   90    CONTINUE
         SUBPBS = SUBPBS / 2
         CURLVL = CURLVL + 1
         GO TO 80
      END IF
!
!     end while
!
!     Re-merge the eigenvalues/vectors which were deflated at the final
!     merge step.
!
      IF( ICOMPQ.EQ.1 ) THEN
         DO 100 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
            CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
  100    CONTINUE
         CALL DCOPY( N, WORK, 1, D, 1 )
      ELSE IF( ICOMPQ.EQ.2 ) THEN
         DO 110 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
            CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
  110    CONTINUE
         CALL DCOPY( N, WORK, 1, D, 1 )
         CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
      ELSE
         DO 120 I = 1, N
            J = IWORK( INDXQ+I )
            WORK( I ) = D( J )
  120    CONTINUE
         CALL DCOPY( N, WORK, 1, D, 1 )
      END IF
      GO TO 140
!
  130 CONTINUE
      INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
!
  140 CONTINUE
      RETURN
!
!     End of DLAED0
!
      END
      SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            CUTPNT, INFO, LDQ, N
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      INTEGER            INDXQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), Q( LDQ, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED1 computes the updated eigensystem of a diagonal
!  matrix after modification by a rank-one symmetric matrix.  This
!  routine is used only for the eigenproblem which requires all
!  eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles
!  the case in which eigenvalues only or eigenvalues and eigenvectors
!  of a full symmetric matrix (which was reduced to tridiagonal form)
!  are desired.
!
!    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
!
!     where Z = Q'u, u is a vector of length N with ones in the
!     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!
!     The eigenvectors of the original matrix are stored in Q, and the
!     eigenvalues are in D.  The algorithm consists of three stages:
!
!        The first stage consists of deflating the size of the problem
!        when there are multiple eigenvalues or if there is a zero in
!        the Z vector.  For each such occurence the dimension of the
!        secular equation problem is reduced by one.  This stage is
!        performed by the routine DLAED2.
!
!        The second stage consists of calculating the updated
!        eigenvalues. This is done by finding the roots of the secular
!        equation via the routine DLAED4 (as called by DLAED3).
!        This routine also calculates the eigenvectors of the current
!        problem.
!
!        The final stage consists of computing the updated eigenvectors
!        directly using the updated eigenvalues.  The eigenvectors for
!        the current problem are multiplied with the eigenvectors from
!        the overall problem.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry, the eigenvalues of the rank-1-perturbed matrix.
!         On exit, the eigenvalues of the repaired matrix.
!
!  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!         On entry, the eigenvectors of the rank-1-perturbed matrix.
!         On exit, the eigenvectors of the repaired tridiagonal matrix.
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  INDXQ  (input/output) INTEGER array, dimension (N)
!         On entry, the permutation which separately sorts the two
!         subproblems in D into ascending order.
!         On exit, the permutation which will reintegrate the
!         subproblems back into sorted order,
!         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
!
!  RHO    (input) DOUBLE PRECISION
!         The subdiagonal entry used to create the rank-1 modification.
!
!  CUTPNT (input) INTEGER
!         The location of the last eigenvalue in the leading sub-matrix.
!         min(1,N) <= CUTPNT <= N/2.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
!
!  IWORK  (workspace) INTEGER array, dimension (4*N)
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an eigenvalue did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!  Modified by Francoise Tisseur, University of Tennessee.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, &
                         IW, IZ, K, N1, N2, ZPP1
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED1', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     The following values are integer pointers which indicate
!     the portion of the workspace
!     used by a particular array in DLAED2 and DLAED3.
!
      IZ = 1
      IDLMDA = IZ + N
      IW = IDLMDA + N
      IQ2 = IW + N
!
      INDX = 1
      INDXC = INDX + N
      COLTYP = INDXC + N
      INDXP = COLTYP + N
!
!
!     Form the z-vector which consists of the last row of Q_1 and the
!     first row of Q_2.
!
      CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
      ZPP1 = CUTPNT + 1
      CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
!
!     Deflate eigenvalues.
!
      CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), &
                   WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), &
                   IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), &
                   IWORK( COLTYP ), INFO )
!
      IF( INFO.NE.0 ) &
         GO TO 20
!
!     Solve Secular Equation.
!
      IF( K.NE.0 ) THEN
         IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + &
              ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
         CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), &
                      WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), &
                      WORK( IW ), WORK( IS ), INFO )
         IF( INFO.NE.0 ) &
            GO TO 20
!
!     Prepare the INDXQ sorting permutation.
!
         N1 = K
         N2 = N - K
         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
      ELSE
         DO 10 I = 1, N
            INDXQ( I ) = I
   10    CONTINUE
      END IF
!
   20 CONTINUE
      RETURN
!
!     End of DLAED1
!
      END
      SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, &
                         Q2, INDX, INDXC, INDXP, COLTYP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDQ, N, N1
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      INTEGER            COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), &
                         INDXQ( * )
      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), &
                         W( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED2 merges the two sets of eigenvalues together into a single
!  sorted set.  Then it tries to deflate the size of the problem.
!  There are two ways in which deflation can occur:  when two or more
!  eigenvalues are close together or if there is a tiny entry in the
!  Z vector.  For each such occurrence the order of the related secular
!  equation problem is reduced by one.
!
!  Arguments
!  =========
!
!  K      (output) INTEGER
!         The number of non-deflated eigenvalues, and the order of the
!         related secular equation. 0 <= K <=N.
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  N1     (input) INTEGER
!         The location of the last eigenvalue in the leading sub-matrix.
!         min(1,N) <= N1 <= N/2.
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry, D contains the eigenvalues of the two submatrices to
!         be combined.
!         On exit, D contains the trailing (N-K) updated eigenvalues
!         (those which were deflated) sorted into increasing order.
!
!  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
!         On entry, Q contains the eigenvectors of two submatrices in
!         the two square blocks with corners at (1,1), (N1,N1)
!         and (N1+1, N1+1), (N,N).
!         On exit, Q contains the trailing (N-K) updated eigenvectors
!         (those which were deflated) in its last N-K columns.
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  INDXQ  (input/output) INTEGER array, dimension (N)
!         The permutation which separately sorts the two sub-problems
!         in D into ascending order.  Note that elements in the second
!         half of this permutation must first have N1 added to their
!         values. Destroyed on exit.
!
!  RHO    (input/output) DOUBLE PRECISION
!         On entry, the off-diagonal element associated with the rank-1
!         cut which originally split the two submatrices which are now
!         being recombined.
!         On exit, RHO has been modified to the value required by
!         DLAED3.
!
!  Z      (input) DOUBLE PRECISION array, dimension (N)
!         On entry, Z contains the updating vector (the last
!         row of the first sub-eigenvector matrix and the first row of
!         the second sub-eigenvector matrix).
!         On exit, the contents of Z have been destroyed by the updating
!         process.
!
!  DLAMDA (output) DOUBLE PRECISION array, dimension (N)
!         A copy of the first K eigenvalues which will be used by
!         DLAED3 to form the secular equation.
!
!  W      (output) DOUBLE PRECISION array, dimension (N)
!         The first k values of the final deflation-altered z-vector
!         which will be passed to DLAED3.
!
!  Q2     (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
!         A copy of the first K eigenvectors which will be used by
!         DLAED3 in a matrix multiply (DGEMM) to solve for the new
!         eigenvectors.
!
!  INDX   (workspace) INTEGER array, dimension (N)
!         The permutation used to sort the contents of DLAMDA into
!         ascending order.
!
!  INDXC  (output) INTEGER array, dimension (N)
!         The permutation used to arrange the columns of the deflated
!         Q matrix into three groups:  the first group contains non-zero
!         elements only at and above N1, the second contains
!         non-zero elements only below N1, and the third is dense.
!
!  INDXP  (workspace) INTEGER array, dimension (N)
!         The permutation used to place deflated values of D at the end
!         of the array.  INDXP(1:K) points to the nondeflated D-values
!         and INDXP(K+1:N) points to the deflated eigenvalues.
!
!  COLTYP (workspace/output) INTEGER array, dimension (N)
!         During execution, a label which will indicate which of the
!         following types a column in the Q2 matrix is:
!         1 : non-zero in the upper half only;
!         2 : dense;
!         3 : non-zero in the lower half only;
!         4 : deflated.
!         On exit, COLTYP(i) is the number of columns of type i,
!         for i=1 to 4 only.
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!  Modified by Francoise Tisseur, University of Tennessee.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, &
                         TWO = 2.0D0, EIGHT = 8.0D0 )
!     ..
!     .. Local Arrays ..
      INTEGER            CTOT( 4 ), PSM( 4 )
!     ..
!     .. Local Scalars ..
      INTEGER            CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, &
                         N2, NJ, PJ
      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      N2 = N - N1
      N1P1 = N1 + 1
!
      IF( RHO.LT.ZERO ) THEN
         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
      END IF
!
!     Normalize z so that norm(z) = 1.  Since z is the concatenation of
!     two normalized vectors, norm2(z) = sqrt(2).
!
      T = ONE / SQRT( TWO )
      CALL DSCAL( N, T, Z, 1 )
!
!     RHO = ABS( norm(z)**2 * RHO )
!
      RHO = ABS( TWO*RHO )
!
!     Sort the eigenvalues into increasing order
!
      DO 10 I = N1P1, N
         INDXQ( I ) = INDXQ( I ) + N1
   10 CONTINUE
!
!     re-integrate the deflated parts from the last pass
!
      DO 20 I = 1, N
         DLAMDA( I ) = D( INDXQ( I ) )
   20 CONTINUE
      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
      DO 30 I = 1, N
         INDX( I ) = INDXQ( INDXC( I ) )
   30 CONTINUE
!
!     Calculate the allowable deflation tolerance
!
      IMAX = IDAMAX( N, Z, 1 )
      JMAX = IDAMAX( N, D, 1 )
      EPS = DLAMCH( 'Epsilon' )
      TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
!
!     If the rank-1 modifier is small enough, no more needs to be done
!     except to reorganize Q so that its columns correspond with the
!     elements in D.
!
      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
         K = 0
         IQ2 = 1
         DO 40 J = 1, N
            I = INDX( J )
            CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
            DLAMDA( J ) = D( I )
            IQ2 = IQ2 + N
   40    CONTINUE
         CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
         CALL DCOPY( N, DLAMDA, 1, D, 1 )
         GO TO 190
      END IF
!
!     If there are multiple eigenvalues then the problem deflates.  Here
!     the number of equal eigenvalues are found.  As each equal
!     eigenvalue is found, an elementary reflector is computed to rotate
!     the corresponding eigensubspace so that the corresponding
!     components of Z are zero in this new basis.
!
      DO 50 I = 1, N1
         COLTYP( I ) = 1
   50 CONTINUE
      DO 60 I = N1P1, N
         COLTYP( I ) = 3
   60 CONTINUE
!
!
      K = 0
      K2 = N + 1
      DO 70 J = 1, N
         NJ = INDX( J )
         IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
!
!           Deflate due to small z component.
!
            K2 = K2 - 1
            COLTYP( NJ ) = 4
            INDXP( K2 ) = NJ
            IF( J.EQ.N ) &
               GO TO 100
         ELSE
            PJ = NJ
            GO TO 80
         END IF
   70 CONTINUE
   80 CONTINUE
      J = J + 1
      NJ = INDX( J )
      IF( J.GT.N ) &
         GO TO 100
      IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
!
!        Deflate due to small z component.
!
         K2 = K2 - 1
         COLTYP( NJ ) = 4
         INDXP( K2 ) = NJ
      ELSE
!
!        Check if eigenvalues are close enough to allow deflation.
!
         S = Z( PJ )
         C = Z( NJ )
!
!        Find sqrt(a**2+b**2) without overflow or
!        destructive underflow.
!
         TAU = DLAPY2( C, S )
         T = D( NJ ) - D( PJ )
         C = C / TAU
         S = -S / TAU
         IF( ABS( T*C*S ).LE.TOL ) THEN
!
!           Deflation is possible.
!
            Z( NJ ) = TAU
            Z( PJ ) = ZERO
            IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) &
               COLTYP( NJ ) = 2
            COLTYP( PJ ) = 4
            CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
            T = D( PJ )*C**2 + D( NJ )*S**2
            D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
            D( PJ ) = T
            K2 = K2 - 1
            I = 1
   90       CONTINUE
            IF( K2+I.LE.N ) THEN
               IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
                  INDXP( K2+I-1 ) = INDXP( K2+I )
                  INDXP( K2+I ) = PJ
                  I = I + 1
                  GO TO 90
               ELSE
                  INDXP( K2+I-1 ) = PJ
               END IF
            ELSE
               INDXP( K2+I-1 ) = PJ
            END IF
            PJ = NJ
         ELSE
            K = K + 1
            DLAMDA( K ) = D( PJ )
            W( K ) = Z( PJ )
            INDXP( K ) = PJ
            PJ = NJ
         END IF
      END IF
      GO TO 80
  100 CONTINUE
!
!     Record the last eigenvalue.
!
      K = K + 1
      DLAMDA( K ) = D( PJ )
      W( K ) = Z( PJ )
      INDXP( K ) = PJ
!
!     Count up the total number of the various types of columns, then
!     form a permutation which positions the four column types into
!     four uniform groups (although one or more of these groups may be
!     empty).
!
      DO 110 J = 1, 4
         CTOT( J ) = 0
  110 CONTINUE
      DO 120 J = 1, N
         CT = COLTYP( J )
         CTOT( CT ) = CTOT( CT ) + 1
  120 CONTINUE
!
!     PSM(*) = Position in SubMatrix (of types 1 through 4)
!
      PSM( 1 ) = 1
      PSM( 2 ) = 1 + CTOT( 1 )
      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
      K = N - CTOT( 4 )
!
!     Fill out the INDXC array so that the permutation which it induces
!     will place all type-1 columns first, all type-2 columns next,
!     then all type-3's, and finally all type-4's.
!
      DO 130 J = 1, N
         JS = INDXP( J )
         CT = COLTYP( JS )
         INDX( PSM( CT ) ) = JS
         INDXC( PSM( CT ) ) = J
         PSM( CT ) = PSM( CT ) + 1
  130 CONTINUE
!
!     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
!     and Q2 respectively.  The eigenvalues/vectors which were not
!     deflated go into the first K slots of DLAMDA and Q2 respectively,
!     while those which were deflated go into the last N - K slots.
!
      I = 1
      IQ1 = 1
      IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
      DO 140 J = 1, CTOT( 1 )
         JS = INDX( I )
         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
         Z( I ) = D( JS )
         I = I + 1
         IQ1 = IQ1 + N1
  140 CONTINUE
!
      DO 150 J = 1, CTOT( 2 )
         JS = INDX( I )
         CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
         Z( I ) = D( JS )
         I = I + 1
         IQ1 = IQ1 + N1
         IQ2 = IQ2 + N2
  150 CONTINUE
!
      DO 160 J = 1, CTOT( 3 )
         JS = INDX( I )
         CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
         Z( I ) = D( JS )
         I = I + 1
         IQ2 = IQ2 + N2
  160 CONTINUE
!
      IQ1 = IQ2
      DO 170 J = 1, CTOT( 4 )
         JS = INDX( I )
         CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
         IQ2 = IQ2 + N
         Z( I ) = D( JS )
         I = I + 1
  170 CONTINUE
!
!     The deflated eigenvalues and their corresponding vectors go back
!     into the last N - K slots of D and Q respectively.
!
      CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
      CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
!
!     Copy CTOT into COLTYP for referencing in DLAED3.
!
      DO 180 J = 1, 4
         COLTYP( J ) = CTOT( J )
  180 CONTINUE
!
  190 CONTINUE
      RETURN
!
!     End of DLAED2
!
      END
      SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, &
                         CTOT, W, S, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDQ, N, N1
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      INTEGER            CTOT( * ), INDX( * )
      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), &
                         S( * ), W( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED3 finds the roots of the secular equation, as defined by the
!  values in D, W, and RHO, between 1 and K.  It makes the
!  appropriate calls to DLAED4 and then updates the eigenvectors by
!  multiplying the matrix of eigenvectors of the pair of eigensystems
!  being combined by the matrix of eigenvectors of the K-by-K system
!  which is solved here.
!
!  This code makes very mild assumptions about floating point
!  arithmetic. It will work on machines with a guard digit in
!  add/subtract, or on those binary machines without guard digits
!  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!  It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  K       (input) INTEGER
!          The number of terms in the rational function to be solved by
!          DLAED4.  K >= 0.
!
!  N       (input) INTEGER
!          The number of rows and columns in the Q matrix.
!          N >= K (deflation may result in N>K).
!
!  N1      (input) INTEGER
!          The location of the last eigenvalue in the leading submatrix.
!          min(1,N) <= N1 <= N/2.
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          D(I) contains the updated eigenvalues for
!          1 <= I <= K.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
!          Initially the first K columns are used as workspace.
!          On output the columns 1 to K contain
!          the updated eigenvectors.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  RHO     (input) DOUBLE PRECISION
!          The value of the parameter in the rank one update equation.
!          RHO >= 0 required.
!
!  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K)
!          The first K elements of this array contain the old roots
!          of the deflated updating problem.  These are the poles
!          of the secular equation. May be changed on output by
!          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
!          Cray-2, or Cray C-90, as described above.
!
!  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N)
!          The first K columns of this matrix contain the non-deflated
!          eigenvectors for the split problem.
!
!  INDX    (input) INTEGER array, dimension (N)
!          The permutation used to arrange the columns of the deflated
!          Q matrix into three groups (see DLAED2).
!          The rows of the eigenvectors found by DLAED4 must be likewise
!          permuted before the matrix multiply can take place.
!
!  CTOT    (input) INTEGER array, dimension (4)
!          A count of the total number of the various types of columns
!          in Q, as described in INDX.  The fourth column type is any
!          column which has been deflated.
!
!  W       (input/output) DOUBLE PRECISION array, dimension (K)
!          The first K elements of this array contain the components
!          of the deflation-adjusted updating vector. Destroyed on
!          output.
!
!  S       (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
!          Will contain the eigenvectors of the repaired matrix which
!          will be multiplied by the previously accumulated eigenvectors
!          to update the system.
!
!  LDS     (input) INTEGER
!          The leading dimension of S.  LDS >= max(1,K).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an eigenvalue did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!  Modified by Francoise Tisseur, University of Tennessee.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, II, IQ2, J, N12, N2, N23
      DOUBLE PRECISION   TEMP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3, DNRM2
      EXTERNAL           DLAMC3, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( K.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.K ) THEN
         INFO = -2
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED3', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.0 ) &
         RETURN
!
!     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
!     be computed with high relative accuracy (barring over/underflow).
!     This is a problem on machines without a guard digit in
!     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
!     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
!     which on any of these machines zeros out the bottommost
!     bit of DLAMDA(I) if it is 1; this makes the subsequent
!     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
!     occurs. On binary machines with a guard digit (almost all
!     machines) it does not change DLAMDA(I) at all. On hexadecimal
!     and decimal machines with a guard digit, it slightly
!     changes the bottommost bits of DLAMDA(I). It does not account
!     for hexadecimal or decimal machines without guard digits
!     (we know of none). We use a subroutine call to compute
!     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
!     this code.
!
      DO 10 I = 1, K
         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
   10 CONTINUE
!
      DO 20 J = 1, K
         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
!
!        If the zero finder fails, the computation is terminated.
!
         IF( INFO.NE.0 ) &
            GO TO 120
   20 CONTINUE
!
      IF( K.EQ.1 ) &
         GO TO 110
      IF( K.EQ.2 ) THEN
         DO 30 J = 1, K
            W( 1 ) = Q( 1, J )
            W( 2 ) = Q( 2, J )
            II = INDX( 1 )
            Q( 1, J ) = W( II )
            II = INDX( 2 )
            Q( 2, J ) = W( II )
   30    CONTINUE
         GO TO 110
      END IF
!
!     Compute updated W.
!
      CALL DCOPY( K, W, 1, S, 1 )
!
!     Initialize W(I) = Q(I,I)
!
      CALL DCOPY( K, Q, LDQ+1, W, 1 )
      DO 60 J = 1, K
         DO 40 I = 1, J - 1
            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
   40    CONTINUE
         DO 50 I = J + 1, K
            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
   50    CONTINUE
   60 CONTINUE
      DO 70 I = 1, K
         W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
   70 CONTINUE
!
!     Compute eigenvectors of the modified rank-1 modification.
!
      DO 100 J = 1, K
         DO 80 I = 1, K
            S( I ) = W( I ) / Q( I, J )
   80    CONTINUE
         TEMP = DNRM2( K, S, 1 )
         DO 90 I = 1, K
            II = INDX( I )
            Q( I, J ) = S( II ) / TEMP
   90    CONTINUE
  100 CONTINUE
!
!     Compute the updated eigenvectors.
!
  110 CONTINUE
!
      N2 = N - N1
      N12 = CTOT( 1 ) + CTOT( 2 )
      N23 = CTOT( 2 ) + CTOT( 3 )
!
      CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
      IQ2 = N1*N12 + 1
      IF( N23.NE.0 ) THEN
         CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, &
                     ZERO, Q( N1+1, 1 ), LDQ )
      ELSE
         CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
      END IF
!
      CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
      IF( N12.NE.0 ) THEN
         CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, &
                     LDQ )
      ELSE
         CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
      END IF
!
!
  120 CONTINUE
      RETURN
!
!     End of DLAED3
!
      END
      SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     December 23, 1999
!
!     .. Scalar Arguments ..
      INTEGER            I, INFO, N
      DOUBLE PRECISION   DLAM, RHO
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DELTA( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  This subroutine computes the I-th updated eigenvalue of a symmetric
!  rank-one modification to a diagonal matrix whose elements are
!  given in the array d, and that
!
!             D(i) < D(j)  for  i < j
!
!  and that RHO > 0.  This is arranged by the calling routine, and is
!  no loss in generality.  The rank-one modified system is thus
!
!             diag( D )  +  RHO *  Z * Z_transpose.
!
!  where we assume the Euclidean norm of Z is 1.
!
!  The method consists of approximating the rational functions in the
!  secular equation by simpler interpolating rational functions.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The length of all arrays.
!
!  I      (input) INTEGER
!         The index of the eigenvalue to be computed.  1 <= I <= N.
!
!  D      (input) DOUBLE PRECISION array, dimension (N)
!         The original eigenvalues.  It is assumed that they are in
!         order, D(I) < D(J)  for I < J.
!
!  Z      (input) DOUBLE PRECISION array, dimension (N)
!         The components of the updating vector.
!
!  DELTA  (output) DOUBLE PRECISION array, dimension (N)
!         If N .ne. 1, DELTA contains (D(j) - lambda_I) in its  j-th
!         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA
!         contains the information necessary to construct the
!         eigenvectors.
!
!  RHO    (input) DOUBLE PRECISION
!         The scalar in the symmetric updating formula.
!
!  DLAM   (output) DOUBLE PRECISION
!         The computed lambda_I, the I-th updated eigenvalue.
!
!  INFO   (output) INTEGER
!         = 0:  successful exit
!         > 0:  if INFO = 1, the updating process failed.
!
!  Internal Parameters
!  ===================
!
!  Logical variable ORGATI (origin-at-i?) is used for distinguishing
!  whether D(i) or D(i+1) is treated as the origin.
!
!            ORGATI = .true.    origin at i
!            ORGATI = .false.   origin at i+1
!
!   Logical variable SWTCH3 (switch-for-3-poles?) is for noting
!   if we are working with THREE poles!
!
!   MAXIT is the maximum number of iterations allowed for each
!   eigenvalue.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ren-Cang Li, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, &
                         TEN = 10.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ORGATI, SWTCH, SWTCH3
      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
      DOUBLE PRECISION   A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, &
                         EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, &
                         RHOINV, TAU, TEMP, TEMP1, W
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   ZZ( 3 )
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAED5, DLAED6
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Since this routine is called in an inner loop, we do no argument
!     checking.
!
!     Quick return for N=1 and 2.
!
      INFO = 0
      IF( N.EQ.1 ) THEN
!
!         Presumably, I=1 upon entry
!
         DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
         DELTA( 1 ) = ONE
         RETURN
      END IF
      IF( N.EQ.2 ) THEN
         CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
         RETURN
      END IF
!
!     Compute machine epsilon
!
      EPS = DLAMCH( 'Epsilon' )
      RHOINV = ONE / RHO
!
!     The case I = N
!
      IF( I.EQ.N ) THEN
!
!        Initialize some basic variables
!
         II = N - 1
         NITER = 1
!
!        Calculate initial guess
!
         MIDPT = RHO / TWO
!
!        If ||Z||_2 is not one, then TEMP should be set to
!        RHO * ||Z||_2^2 / TWO
!
         DO 10 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
   10    CONTINUE
!
         PSI = ZERO
         DO 20 J = 1, N - 2
            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
   20    CONTINUE
!
         C = RHOINV + PSI
         W = C + Z( II )*Z( II ) / DELTA( II ) + &
             Z( N )*Z( N ) / DELTA( N )
!
         IF( W.LE.ZERO ) THEN
            TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + &
                   Z( N )*Z( N ) / RHO
            IF( C.LE.TEMP ) THEN
               TAU = RHO
            ELSE
               DEL = D( N ) - D( N-1 )
               A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
               B = Z( N )*Z( N )*DEL
               IF( A.LT.ZERO ) THEN
                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
               ELSE
                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
               END IF
            END IF
!
!           It can be proved that
!               D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
!
            DLTLB = MIDPT
            DLTUB = RHO
         ELSE
            DEL = D( N ) - D( N-1 )
            A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
            B = Z( N )*Z( N )*DEL
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
            ELSE
               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
            END IF
!
!           It can be proved that
!               D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
!
            DLTLB = ZERO
            DLTUB = MIDPT
         END IF
!
         DO 30 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - TAU
   30    CONTINUE
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 40 J = 1, II
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   40    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         TEMP = Z( N ) / DELTA( N )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                  ABS( TAU )*( DPSI+DPHI )
!
         W = RHOINV + PHI + PSI
!
!        Test for convergence
!
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            DLAM = D( I ) + TAU
            GO TO 250
         END IF
!
         IF( W.LE.ZERO ) THEN
            DLTLB = MAX( DLTLB, TAU )
         ELSE
            DLTUB = MIN( DLTUB, TAU )
         END IF
!
!        Calculate the new step
!
         NITER = NITER + 1
         C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
         A = ( DELTA( N-1 )+DELTA( N ) )*W - &
             DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
         B = DELTA( N-1 )*DELTA( N )*W
         IF( C.LT.ZERO ) &
            C = ABS( C )
         IF( C.EQ.ZERO ) THEN
!          ETA = B/A
!           ETA = RHO - TAU
            ETA = DLTUB - TAU
         ELSE IF( A.GE.ZERO ) THEN
            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
         ELSE
            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
         END IF
!
!        Note, eta should be positive if w is negative, and
!        eta should be negative otherwise. However,
!        if for some reason caused by roundoff, eta*w > 0,
!        we simply use one Newton step instead. This way
!        will guarantee eta*w < 0.
!
         IF( W*ETA.GT.ZERO ) &
            ETA = -W / ( DPSI+DPHI )
         TEMP = TAU + ETA
         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
            IF( W.LT.ZERO ) THEN
               ETA = ( DLTUB-TAU ) / TWO
            ELSE
               ETA = ( DLTLB-TAU ) / TWO
            END IF
         END IF
         DO 50 J = 1, N
            DELTA( J ) = DELTA( J ) - ETA
   50    CONTINUE
!
         TAU = TAU + ETA
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 60 J = 1, II
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   60    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         TEMP = Z( N ) / DELTA( N )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                  ABS( TAU )*( DPSI+DPHI )
!
         W = RHOINV + PHI + PSI
!
!        Main loop to update the values of the array   DELTA
!
         ITER = NITER + 1
!
         DO 90 NITER = ITER, MAXIT
!
!           Test for convergence
!
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               DLAM = D( I ) + TAU
               GO TO 250
            END IF
!
            IF( W.LE.ZERO ) THEN
               DLTLB = MAX( DLTLB, TAU )
            ELSE
               DLTUB = MIN( DLTUB, TAU )
            END IF
!
!           Calculate the new step
!
            C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
            A = ( DELTA( N-1 )+DELTA( N ) )*W - &
                DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
            B = DELTA( N-1 )*DELTA( N )*W
            IF( A.GE.ZERO ) THEN
               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
!
!           Note, eta should be positive if w is negative, and
!           eta should be negative otherwise. However,
!           if for some reason caused by roundoff, eta*w > 0,
!           we simply use one Newton step instead. This way
!           will guarantee eta*w < 0.
!
            IF( W*ETA.GT.ZERO ) &
               ETA = -W / ( DPSI+DPHI )
            TEMP = TAU + ETA
            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
               IF( W.LT.ZERO ) THEN
                  ETA = ( DLTUB-TAU ) / TWO
               ELSE
                  ETA = ( DLTLB-TAU ) / TWO
               END IF
            END IF
            DO 70 J = 1, N
               DELTA( J ) = DELTA( J ) - ETA
   70       CONTINUE
!
            TAU = TAU + ETA
!
!           Evaluate PSI and the derivative DPSI
!
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 80 J = 1, II
               TEMP = Z( J ) / DELTA( J )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
   80       CONTINUE
            ERRETM = ABS( ERRETM )
!
!           Evaluate PHI and the derivative DPHI
!
            TEMP = Z( N ) / DELTA( N )
            PHI = Z( N )*TEMP
            DPHI = TEMP*TEMP
            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                     ABS( TAU )*( DPSI+DPHI )
!
            W = RHOINV + PHI + PSI
   90    CONTINUE
!
!        Return with INFO = 1, NITER = MAXIT and not converged
!
         INFO = 1
         DLAM = D( I ) + TAU
         GO TO 250
!
!        End for the case I = N
!
      ELSE
!
!        The case for I < N
!
         NITER = 1
         IP1 = I + 1
!
!        Calculate initial guess
!
         DEL = D( IP1 ) - D( I )
         MIDPT = DEL / TWO
         DO 100 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
  100    CONTINUE
!
         PSI = ZERO
         DO 110 J = 1, I - 1
            PSI = PSI + Z( J )*Z( J ) / DELTA( J )
  110    CONTINUE
!
         PHI = ZERO
         DO 120 J = N, I + 2, -1
            PHI = PHI + Z( J )*Z( J ) / DELTA( J )
  120    CONTINUE
         C = RHOINV + PSI + PHI
         W = C + Z( I )*Z( I ) / DELTA( I ) + &
             Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
!
         IF( W.GT.ZERO ) THEN
!
!           d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
!
!           We choose d(i) as origin.
!
            ORGATI = .TRUE.
            A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
            B = Z( I )*Z( I )*DEL
            IF( A.GT.ZERO ) THEN
               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            ELSE
               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            END IF
            DLTLB = ZERO
            DLTUB = MIDPT
         ELSE
!
!           (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
!
!           We choose d(i+1) as origin.
!
            ORGATI = .FALSE.
            A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
            B = Z( IP1 )*Z( IP1 )*DEL
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
            ELSE
               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
            END IF
            DLTLB = -MIDPT
            DLTUB = ZERO
         END IF
!
         IF( ORGATI ) THEN
            DO 130 J = 1, N
               DELTA( J ) = ( D( J )-D( I ) ) - TAU
  130       CONTINUE
         ELSE
            DO 140 J = 1, N
               DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
  140       CONTINUE
         END IF
         IF( ORGATI ) THEN
            II = I
         ELSE
            II = I + 1
         END IF
         IIM1 = II - 1
         IIP1 = II + 1
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 150 J = 1, IIM1
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  150    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         DPHI = ZERO
         PHI = ZERO
         DO 160 J = N, IIP1, -1
            TEMP = Z( J ) / DELTA( J )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  160    CONTINUE
!
         W = RHOINV + PHI + PSI
!
!        W is the value of the secular function with
!        its ii-th element removed.
!
         SWTCH3 = .FALSE.
         IF( ORGATI ) THEN
            IF( W.LT.ZERO ) &
               SWTCH3 = .TRUE.
         ELSE
            IF( W.GT.ZERO ) &
               SWTCH3 = .TRUE.
         END IF
         IF( II.EQ.1 .OR. II.EQ.N ) &
            SWTCH3 = .FALSE.
!
         TEMP = Z( II ) / DELTA( II )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = W + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                  THREE*ABS( TEMP ) + ABS( TAU )*DW
!
!        Test for convergence
!
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            IF( ORGATI ) THEN
               DLAM = D( I ) + TAU
            ELSE
               DLAM = D( IP1 ) + TAU
            END IF
            GO TO 250
         END IF
!
         IF( W.LE.ZERO ) THEN
            DLTLB = MAX( DLTLB, TAU )
         ELSE
            DLTUB = MIN( DLTUB, TAU )
         END IF
!
!        Calculate the new step
!
         NITER = NITER + 1
         IF( .NOT.SWTCH3 ) THEN
            IF( ORGATI ) THEN
               C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* &
                   ( Z( I ) / DELTA( I ) )**2
            ELSE
               C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* &
                   ( Z( IP1 ) / DELTA( IP1 ) )**2
            END IF
            A = ( DELTA( I )+DELTA( IP1 ) )*W - &
                DELTA( I )*DELTA( IP1 )*DW
            B = DELTA( I )*DELTA( IP1 )*W
            IF( C.EQ.ZERO ) THEN
               IF( A.EQ.ZERO ) THEN
                  IF( ORGATI ) THEN
                     A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* &
                         ( DPSI+DPHI )
                  ELSE
                     A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* &
                         ( DPSI+DPHI )
                  END IF
               END IF
               ETA = B / A
            ELSE IF( A.LE.ZERO ) THEN
               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
         ELSE
!
!           Interpolation using THREE most relevant poles
!
            TEMP = RHOINV + PSI + PHI
            IF( ORGATI ) THEN
               TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
               TEMP1 = TEMP1*TEMP1
               C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - &
                   ( D( IIM1 )-D( IIP1 ) )*TEMP1
               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
               ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* &
                         ( ( DPSI-TEMP1 )+DPHI )
            ELSE
               TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
               TEMP1 = TEMP1*TEMP1
               C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - &
                   ( D( IIP1 )-D( IIM1 ) )*TEMP1
               ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* &
                         ( DPSI+( DPHI-TEMP1 ) )
               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
            END IF
            ZZ( 2 ) = Z( II )*Z( II )
            CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, &
                         INFO )
            IF( INFO.NE.0 ) &
               GO TO 250
         END IF
!
!        Note, eta should be positive if w is negative, and
!        eta should be negative otherwise. However,
!        if for some reason caused by roundoff, eta*w > 0,
!        we simply use one Newton step instead. This way
!        will guarantee eta*w < 0.
!
         IF( W*ETA.GE.ZERO ) &
            ETA = -W / DW
         TEMP = TAU + ETA
         IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
            IF( W.LT.ZERO ) THEN
               ETA = ( DLTUB-TAU ) / TWO
            ELSE
               ETA = ( DLTLB-TAU ) / TWO
            END IF
         END IF
!
         PREW = W
!
  170    CONTINUE
         DO 180 J = 1, N
            DELTA( J ) = DELTA( J ) - ETA
  180    CONTINUE
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 190 J = 1, IIM1
            TEMP = Z( J ) / DELTA( J )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  190    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         DPHI = ZERO
         PHI = ZERO
         DO 200 J = N, IIP1, -1
            TEMP = Z( J ) / DELTA( J )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  200    CONTINUE
!
         TEMP = Z( II ) / DELTA( II )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = RHOINV + PHI + PSI + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                  THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
!
         SWTCH = .FALSE.
         IF( ORGATI ) THEN
            IF( -W.GT.ABS( PREW ) / TEN ) &
               SWTCH = .TRUE.
         ELSE
            IF( W.GT.ABS( PREW ) / TEN ) &
               SWTCH = .TRUE.
         END IF
!
         TAU = TAU + ETA
!
!        Main loop to update the values of the array   DELTA
!
         ITER = NITER + 1
!
         DO 240 NITER = ITER, MAXIT
!
!           Test for convergence
!
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               IF( ORGATI ) THEN
                  DLAM = D( I ) + TAU
               ELSE
                  DLAM = D( IP1 ) + TAU
               END IF
               GO TO 250
            END IF
!
            IF( W.LE.ZERO ) THEN
               DLTLB = MAX( DLTLB, TAU )
            ELSE
               DLTUB = MIN( DLTUB, TAU )
            END IF
!
!           Calculate the new step
!
            IF( .NOT.SWTCH3 ) THEN
               IF( .NOT.SWTCH ) THEN
                  IF( ORGATI ) THEN
                     C = W - DELTA( IP1 )*DW - &
                         ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
                  ELSE
                     C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* &
                         ( Z( IP1 ) / DELTA( IP1 ) )**2
                  END IF
               ELSE
                  TEMP = Z( II ) / DELTA( II )
                  IF( ORGATI ) THEN
                     DPSI = DPSI + TEMP*TEMP
                  ELSE
                     DPHI = DPHI + TEMP*TEMP
                  END IF
                  C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
               END IF
               A = ( DELTA( I )+DELTA( IP1 ) )*W - &
                   DELTA( I )*DELTA( IP1 )*DW
               B = DELTA( I )*DELTA( IP1 )*W
               IF( C.EQ.ZERO ) THEN
                  IF( A.EQ.ZERO ) THEN
                     IF( .NOT.SWTCH ) THEN
                        IF( ORGATI ) THEN
                           A = Z( I )*Z( I ) + DELTA( IP1 )* &
                               DELTA( IP1 )*( DPSI+DPHI )
                        ELSE
                           A = Z( IP1 )*Z( IP1 ) + &
                               DELTA( I )*DELTA( I )*( DPSI+DPHI )
                        END IF
                     ELSE
                        A = DELTA( I )*DELTA( I )*DPSI + &
                            DELTA( IP1 )*DELTA( IP1 )*DPHI
                     END IF
                  END IF
                  ETA = B / A
               ELSE IF( A.LE.ZERO ) THEN
                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
               ELSE
                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
               END IF
            ELSE
!
!              Interpolation using THREE most relevant poles
!
               TEMP = RHOINV + PSI + PHI
               IF( SWTCH ) THEN
                  C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
                  ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
                  ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
               ELSE
                  IF( ORGATI ) THEN
                     TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
                     TEMP1 = TEMP1*TEMP1
                     C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - &
                         ( D( IIM1 )-D( IIP1 ) )*TEMP1
                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
                     ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* &
                               ( ( DPSI-TEMP1 )+DPHI )
                  ELSE
                     TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
                     TEMP1 = TEMP1*TEMP1
                     C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - &
                         ( D( IIP1 )-D( IIM1 ) )*TEMP1
                     ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* &
                               ( DPSI+( DPHI-TEMP1 ) )
                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
                  END IF
               END IF
               CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, &
                            INFO )
               IF( INFO.NE.0 ) &
                  GO TO 250
            END IF
!
!           Note, eta should be positive if w is negative, and
!           eta should be negative otherwise. However,
!           if for some reason caused by roundoff, eta*w > 0,
!           we simply use one Newton step instead. This way
!           will guarantee eta*w < 0.
!
            IF( W*ETA.GE.ZERO ) &
               ETA = -W / DW
            TEMP = TAU + ETA
            IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
               IF( W.LT.ZERO ) THEN
                  ETA = ( DLTUB-TAU ) / TWO
               ELSE
                  ETA = ( DLTLB-TAU ) / TWO
               END IF
            END IF
!
            DO 210 J = 1, N
               DELTA( J ) = DELTA( J ) - ETA
  210       CONTINUE
!
            TAU = TAU + ETA
            PREW = W
!
!           Evaluate PSI and the derivative DPSI
!
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 220 J = 1, IIM1
               TEMP = Z( J ) / DELTA( J )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
  220       CONTINUE
            ERRETM = ABS( ERRETM )
!
!           Evaluate PHI and the derivative DPHI
!
            DPHI = ZERO
            PHI = ZERO
            DO 230 J = N, IIP1, -1
               TEMP = Z( J ) / DELTA( J )
               PHI = PHI + Z( J )*TEMP
               DPHI = DPHI + TEMP*TEMP
               ERRETM = ERRETM + PHI
  230       CONTINUE
!
            TEMP = Z( II ) / DELTA( II )
            DW = DPSI + DPHI + TEMP*TEMP
            TEMP = Z( II )*TEMP
            W = RHOINV + PHI + PSI + TEMP
            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                     THREE*ABS( TEMP ) + ABS( TAU )*DW
            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) &
               SWTCH = .NOT.SWTCH
!
  240    CONTINUE
!
!        Return with INFO = 1, NITER = MAXIT and not converged
!
         INFO = 1
         IF( ORGATI ) THEN
            DLAM = D( I ) + TAU
         ELSE
            DLAM = D( IP1 ) + TAU
         END IF
!
      END IF
!
  250 CONTINUE
!
      RETURN
!
!     End of DLAED4
!
      END
      SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            I
      DOUBLE PRECISION   DLAM, RHO
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), Z( 2 )
!     ..
!
!  Purpose
!  =======
!
!  This subroutine computes the I-th eigenvalue of a symmetric rank-one
!  modification of a 2-by-2 diagonal matrix
!
!             diag( D )  +  RHO *  Z * transpose(Z) .
!
!  The diagonal elements in the array D are assumed to satisfy
!
!             D(i) < D(j)  for  i < j .
!
!  We also assume RHO > 0 and that the Euclidean norm of the vector
!  Z is one.
!
!  Arguments
!  =========
!
!  I      (input) INTEGER
!         The index of the eigenvalue to be computed.  I = 1 or I = 2.
!
!  D      (input) DOUBLE PRECISION array, dimension (2)
!         The original eigenvalues.  We assume D(1) < D(2).
!
!  Z      (input) DOUBLE PRECISION array, dimension (2)
!         The components of the updating vector.
!
!  DELTA  (output) DOUBLE PRECISION array, dimension (2)
!         The vector DELTA contains the information necessary
!         to construct the eigenvectors.
!
!  RHO    (input) DOUBLE PRECISION
!         The scalar in the symmetric updating formula.
!
!  DLAM   (output) DOUBLE PRECISION
!         The computed lambda_I, the I-th updated eigenvalue.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ren-Cang Li, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         FOUR = 4.0D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   B, C, DEL, TAU, TEMP, W
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
      DEL = D( 2 ) - D( 1 )
      IF( I.EQ.1 ) THEN
         W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
         IF( W.GT.ZERO ) THEN
            B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
            C = RHO*Z( 1 )*Z( 1 )*DEL
!
!           B > ZERO, always
!
            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
            DLAM = D( 1 ) + TAU
            DELTA( 1 ) = -Z( 1 ) / TAU
            DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
         ELSE
            B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
            C = RHO*Z( 2 )*Z( 2 )*DEL
            IF( B.GT.ZERO ) THEN
               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
            ELSE
               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
            END IF
            DLAM = D( 2 ) + TAU
            DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
            DELTA( 2 ) = -Z( 2 ) / TAU
         END IF
         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
         DELTA( 1 ) = DELTA( 1 ) / TEMP
         DELTA( 2 ) = DELTA( 2 ) / TEMP
      ELSE
!
!     Now I=2
!
         B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
         C = RHO*Z( 2 )*Z( 2 )*DEL
         IF( B.GT.ZERO ) THEN
            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
         ELSE
            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
         END IF
         DLAM = D( 2 ) + TAU
         DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
         DELTA( 2 ) = -Z( 2 ) / TAU
         TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
         DELTA( 1 ) = DELTA( 1 ) / TEMP
         DELTA( 2 ) = DELTA( 2 ) / TEMP
      END IF
      RETURN
!
!     End OF DLAED5
!
      END
      SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            ORGATI
      INTEGER            INFO, KNITER
      DOUBLE PRECISION   FINIT, RHO, TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( 3 ), Z( 3 )
!     ..
!
!  Purpose
!  =======
!
!  DLAED6 computes the positive or negative root (closest to the origin)
!  of
!                   z(1)        z(2)        z(3)
!  f(x) =   rho + --------- + ---------- + ---------
!                  d(1)-x      d(2)-x      d(3)-x
!
!  It is assumed that
!
!        if ORGATI = .true. the root is between d(2) and d(3);
!        otherwise it is between d(1) and d(2)
!
!  This routine will be called by DLAED4 when necessary. In most cases,
!  the root sought is the smallest in magnitude, though it might not be
!  in some extremely rare situations.
!
!  Arguments
!  =========
!
!  KNITER       (input) INTEGER
!               Refer to DLAED4 for its significance.
!
!  ORGATI       (input) LOGICAL
!               If ORGATI is true, the needed root is between d(2) and
!               d(3); otherwise it is between d(1) and d(2).  See
!               DLAED4 for further details.
!
!  RHO          (input) DOUBLE PRECISION
!               Refer to the equation f(x) above.
!
!  D            (input) DOUBLE PRECISION array, dimension (3)
!               D satisfies d(1) < d(2) < d(3).
!
!  Z            (input) DOUBLE PRECISION array, dimension (3)
!               Each of the elements in z must be positive.
!
!  FINIT        (input) DOUBLE PRECISION
!               The value of f at 0. It is more accurate than the one
!               evaluated inside this routine (if someone wants to do
!               so).
!
!  TAU          (output) DOUBLE PRECISION
!               The root of the equation f(x).
!
!  INFO         (output) INTEGER
!               = 0: successful exit
!               > 0: if INFO = 1, failure to converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ren-Cang Li, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 20 )
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DSCALE( 3 ), ZSCALE( 3 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FIRST, SCALE
      INTEGER            I, ITER, NITER
      DOUBLE PRECISION   A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, &
                         FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, &
                         SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4
!     ..
!     .. Save statement ..
      SAVE               FIRST, SMALL1, SMINV1, SMALL2, SMINV2, EPS
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
      NITER = 1
      TAU = ZERO
      IF( KNITER.EQ.2 ) THEN
         IF( ORGATI ) THEN
            TEMP = ( D( 3 )-D( 2 ) ) / TWO
            C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
            A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
            B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
         ELSE
            TEMP = ( D( 1 )-D( 2 ) ) / TWO
            C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
            A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
            B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
         END IF
         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
         A = A / TEMP
         B = B / TEMP
         C = C / TEMP
         IF( C.EQ.ZERO ) THEN
            TAU = B / A
         ELSE IF( A.LE.ZERO ) THEN
            TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
         ELSE
            TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
         END IF
         TEMP = RHO + Z( 1 ) / ( D( 1 )-TAU ) + &
                Z( 2 ) / ( D( 2 )-TAU ) + Z( 3 ) / ( D( 3 )-TAU )
         IF( ABS( FINIT ).LE.ABS( TEMP ) ) &
            TAU = ZERO
      END IF
!
!     On first call to routine, get machine parameters for
!     possible scaling to avoid overflow
!
      IF( FIRST ) THEN
         EPS = DLAMCH( 'Epsilon' )
         BASE = DLAMCH( 'Base' )
         SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / &
                  THREE ) )
         SMINV1 = ONE / SMALL1
         SMALL2 = SMALL1*SMALL1
         SMINV2 = SMINV1*SMINV1
         FIRST = .FALSE.
      END IF
!
!     Determine if scaling of inputs necessary to avoid overflow
!     when computing 1/TEMP**3
!
      IF( ORGATI ) THEN
         TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
      ELSE
         TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
      END IF
      SCALE = .FALSE.
      IF( TEMP.LE.SMALL1 ) THEN
         SCALE = .TRUE.
         IF( TEMP.LE.SMALL2 ) THEN
!
!        Scale up by power of radix nearest 1/SAFMIN**(2/3)
!
            SCLFAC = SMINV2
            SCLINV = SMALL2
         ELSE
!
!        Scale up by power of radix nearest 1/SAFMIN**(1/3)
!
            SCLFAC = SMINV1
            SCLINV = SMALL1
         END IF
!
!        Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
!
         DO 10 I = 1, 3
            DSCALE( I ) = D( I )*SCLFAC
            ZSCALE( I ) = Z( I )*SCLFAC
   10    CONTINUE
         TAU = TAU*SCLFAC
      ELSE
!
!        Copy D and Z to DSCALE and ZSCALE
!
         DO 20 I = 1, 3
            DSCALE( I ) = D( I )
            ZSCALE( I ) = Z( I )
   20    CONTINUE
      END IF
!
      FC = ZERO
      DF = ZERO
      DDF = ZERO
      DO 30 I = 1, 3
         TEMP = ONE / ( DSCALE( I )-TAU )
         TEMP1 = ZSCALE( I )*TEMP
         TEMP2 = TEMP1*TEMP
         TEMP3 = TEMP2*TEMP
         FC = FC + TEMP1 / DSCALE( I )
         DF = DF + TEMP2
         DDF = DDF + TEMP3
   30 CONTINUE
      F = FINIT + TAU*FC
!
      IF( ABS( F ).LE.ZERO ) &
         GO TO 60
!
!        Iteration begins
!
!     It is not hard to see that
!
!           1) Iterations will go up monotonically
!              if FINIT < 0;
!
!           2) Iterations will go down monotonically
!              if FINIT > 0.
!
      ITER = NITER + 1
!
      DO 50 NITER = ITER, MAXIT
!
         IF( ORGATI ) THEN
            TEMP1 = DSCALE( 2 ) - TAU
            TEMP2 = DSCALE( 3 ) - TAU
         ELSE
            TEMP1 = DSCALE( 1 ) - TAU
            TEMP2 = DSCALE( 2 ) - TAU
         END IF
         A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
         B = TEMP1*TEMP2*F
         C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
         TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
         A = A / TEMP
         B = B / TEMP
         C = C / TEMP
         IF( C.EQ.ZERO ) THEN
            ETA = B / A
         ELSE IF( A.LE.ZERO ) THEN
            ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
         ELSE
            ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
         END IF
         IF( F*ETA.GE.ZERO ) THEN
            ETA = -F / DF
         END IF
!
         TEMP = ETA + TAU
         IF( ORGATI ) THEN
            IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 3 ) ) &
               ETA = ( DSCALE( 3 )-TAU ) / TWO
            IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 2 ) ) &
               ETA = ( DSCALE( 2 )-TAU ) / TWO
         ELSE
            IF( ETA.GT.ZERO .AND. TEMP.GE.DSCALE( 2 ) ) &
               ETA = ( DSCALE( 2 )-TAU ) / TWO
            IF( ETA.LT.ZERO .AND. TEMP.LE.DSCALE( 1 ) ) &
               ETA = ( DSCALE( 1 )-TAU ) / TWO
         END IF
         TAU = TAU + ETA
!
         FC = ZERO
         ERRETM = ZERO
         DF = ZERO
         DDF = ZERO
         DO 40 I = 1, 3
            TEMP = ONE / ( DSCALE( I )-TAU )
            TEMP1 = ZSCALE( I )*TEMP
            TEMP2 = TEMP1*TEMP
            TEMP3 = TEMP2*TEMP
            TEMP4 = TEMP1 / DSCALE( I )
            FC = FC + TEMP4
            ERRETM = ERRETM + ABS( TEMP4 )
            DF = DF + TEMP2
            DDF = DDF + TEMP3
   40    CONTINUE
         F = FINIT + TAU*FC
         ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + &
                  ABS( TAU )*DF
         IF( ABS( F ).LE.EPS*ERRETM ) &
            GO TO 60
   50 CONTINUE
      INFO = 1
   60 CONTINUE
!
!     Undo scaling
!
      IF( SCALE ) &
         TAU = TAU*SCLINV
      RETURN
!
!     End of DLAED6
!
      END
      SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, &
                         LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, &
                         PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, &
                         QSIZ, TLVLS
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), &
                         IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
      DOUBLE PRECISION   D( * ), GIVNUM( 2, * ), Q( LDQ, * ), &
                         QSTORE( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED7 computes the updated eigensystem of a diagonal
!  matrix after modification by a rank-one symmetric matrix. This
!  routine is used only for the eigenproblem which requires all
!  eigenvalues and optionally eigenvectors of a dense symmetric matrix
!  that has been reduced to tridiagonal form.  DLAED1 handles
!  the case in which all eigenvalues and eigenvectors of a symmetric
!  tridiagonal matrix are desired.
!
!    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
!
!     where Z = Q'u, u is a vector of length N with ones in the
!     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!
!     The eigenvectors of the original matrix are stored in Q, and the
!     eigenvalues are in D.  The algorithm consists of three stages:
!
!        The first stage consists of deflating the size of the problem
!        when there are multiple eigenvalues or if there is a zero in
!        the Z vector.  For each such occurence the dimension of the
!        secular equation problem is reduced by one.  This stage is
!        performed by the routine DLAED8.
!
!        The second stage consists of calculating the updated
!        eigenvalues. This is done by finding the roots of the secular
!        equation via the routine DLAED4 (as called by DLAED9).
!        This routine also calculates the eigenvectors of the current
!        problem.
!
!        The final stage consists of computing the updated eigenvectors
!        directly using the updated eigenvalues.  The eigenvectors for
!        the current problem are multiplied with the eigenvectors from
!        the overall problem.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          = 0:  Compute eigenvalues only.
!          = 1:  Compute eigenvectors of original dense symmetric matrix
!                also.  On entry, Q contains the orthogonal matrix used
!                to reduce the original matrix to tridiagonal form.
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  QSIZ   (input) INTEGER
!         The dimension of the orthogonal matrix used to reduce
!         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!
!  TLVLS  (input) INTEGER
!         The total number of merging levels in the overall divide and
!         conquer tree.
!
!  CURLVL (input) INTEGER
!         The current level in the overall merge routine,
!         0 <= CURLVL <= TLVLS.
!
!  CURPBM (input) INTEGER
!         The current problem in the current level in the overall
!         merge routine (counting from upper left to lower right).
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry, the eigenvalues of the rank-1-perturbed matrix.
!         On exit, the eigenvalues of the repaired matrix.
!
!  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
!         On entry, the eigenvectors of the rank-1-perturbed matrix.
!         On exit, the eigenvectors of the repaired tridiagonal matrix.
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  INDXQ  (output) INTEGER array, dimension (N)
!         The permutation which will reintegrate the subproblem just
!         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
!         will be in ascending order.
!
!  RHO    (input) DOUBLE PRECISION
!         The subdiagonal element used to create the rank-1
!         modification.
!
!  CUTPNT (input) INTEGER
!         Contains the location of the last eigenvalue in the leading
!         sub-matrix.  min(1,N) <= CUTPNT <= N.
!
!  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
!         Stores eigenvectors of submatrices encountered during
!         divide and conquer, packed together. QPTR points to
!         beginning of the submatrices.
!
!  QPTR   (input/output) INTEGER array, dimension (N+2)
!         List of indices pointing to beginning of submatrices stored
!         in QSTORE. The submatrices are numbered starting at the
!         bottom left of the divide and conquer tree, from left to
!         right and bottom to top.
!
!  PRMPTR (input) INTEGER array, dimension (N lg N)
!         Contains a list of pointers which indicate where in PERM a
!         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!         indicates the size of the permutation and also the size of
!         the full, non-deflated problem.
!
!  PERM   (input) INTEGER array, dimension (N lg N)
!         Contains the permutations (from deflation and sorting) to be
!         applied to each eigenblock.
!
!  GIVPTR (input) INTEGER array, dimension (N lg N)
!         Contains a list of pointers which indicate where in GIVCOL a
!         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!         indicates the number of Givens rotations.
!
!  GIVCOL (input) INTEGER array, dimension (2, N lg N)
!         Each pair of numbers indicates a pair of columns to take place
!         in a Givens rotation.
!
!  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
!         Each number indicates the S value to be used in the
!         corresponding Givens rotation.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
!
!  IWORK  (workspace) INTEGER array, dimension (4*N)
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an eigenvalue did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, &
                         IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
         INFO = -4
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED7', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     The following values are for bookkeeping purposes only.  They are
!     integer pointers which indicate the portion of the workspace
!     used by a particular array in DLAED8 and DLAED9.
!
      IF( ICOMPQ.EQ.1 ) THEN
         LDQ2 = QSIZ
      ELSE
         LDQ2 = N
      END IF
!
      IZ = 1
      IDLMDA = IZ + N
      IW = IDLMDA + N
      IQ2 = IW + N
      IS = IQ2 + N*LDQ2
!
      INDX = 1
      INDXC = INDX + N
      COLTYP = INDXC + N
      INDXP = COLTYP + N
!
!     Form the z-vector which consists of the last row of Q_1 and the
!     first row of Q_2.
!
      PTR = 1 + 2**TLVLS
      DO 10 I = 1, CURLVL - 1
         PTR = PTR + 2**( TLVLS-I )
   10 CONTINUE
      CURR = PTR + CURPBM
      CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, &
                   GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), &
                   WORK( IZ+N ), INFO )
!
!     When solving the final problem, we no longer need the stored data,
!     so we will overwrite the data from this level onto the previously
!     used storage space.
!
      IF( CURLVL.EQ.TLVLS ) THEN
         QPTR( CURR ) = 1
         PRMPTR( CURR ) = 1
         GIVPTR( CURR ) = 1
      END IF
!
!     Sort and Deflate eigenvalues.
!
      CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, &
                   WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, &
                   WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), &
                   GIVCOL( 1, GIVPTR( CURR ) ), &
                   GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), &
                   IWORK( INDX ), INFO )
      PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
      GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
!
!     Solve Secular Equation.
!
      IF( K.NE.0 ) THEN
         CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), &
                      WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
         IF( INFO.NE.0 ) &
            GO TO 30
         IF( ICOMPQ.EQ.1 ) THEN
            CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, &
                        QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
         END IF
         QPTR( CURR+1 ) = QPTR( CURR ) + K**2
!
!     Prepare the INDXQ sorting permutation.
!
         N1 = K
         N2 = N - K
         CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
      ELSE
         QPTR( CURR+1 ) = QPTR( CURR )
         DO 20 I = 1, N
            INDXQ( I ) = I
   20    CONTINUE
      END IF
!
   30 CONTINUE
      RETURN
!
!     End of DLAED7
!
      END
      SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, &
                         CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, &
                         GIVCOL, GIVNUM, INDXP, INDX, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, &
                         QSIZ
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( 2, * ), INDX( * ), INDXP( * ), &
                         INDXQ( * ), PERM( * )
      DOUBLE PRECISION   D( * ), DLAMDA( * ), GIVNUM( 2, * ), &
                         Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED8 merges the two sets of eigenvalues together into a single
!  sorted set.  Then it tries to deflate the size of the problem.
!  There are two ways in which deflation can occur:  when two or more
!  eigenvalues are close together or if there is a tiny element in the
!  Z vector.  For each such occurrence the order of the related secular
!  equation problem is reduced by one.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          = 0:  Compute eigenvalues only.
!          = 1:  Compute eigenvectors of original dense symmetric matrix
!                also.  On entry, Q contains the orthogonal matrix used
!                to reduce the original matrix to tridiagonal form.
!
!  K      (output) INTEGER
!         The number of non-deflated eigenvalues, and the order of the
!         related secular equation.
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  QSIZ   (input) INTEGER
!         The dimension of the orthogonal matrix used to reduce
!         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry, the eigenvalues of the two submatrices to be
!         combined.  On exit, the trailing (N-K) updated eigenvalues
!         (those which were deflated) sorted into increasing order.
!
!  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!         If ICOMPQ = 0, Q is not referenced.  Otherwise,
!         on entry, Q contains the eigenvectors of the partially solved
!         system which has been previously updated in matrix
!         multiplies with other partially solved eigensystems.
!         On exit, Q contains the trailing (N-K) updated eigenvectors
!         (those which were deflated) in its last N-K columns.
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  INDXQ  (input) INTEGER array, dimension (N)
!         The permutation which separately sorts the two sub-problems
!         in D into ascending order.  Note that elements in the second
!         half of this permutation must first have CUTPNT added to
!         their values in order to be accurate.
!
!  RHO    (input/output) DOUBLE PRECISION
!         On entry, the off-diagonal element associated with the rank-1
!         cut which originally split the two submatrices which are now
!         being recombined.
!         On exit, RHO has been modified to the value required by
!         DLAED3.
!
!  CUTPNT (input) INTEGER
!         The location of the last eigenvalue in the leading
!         sub-matrix.  min(1,N) <= CUTPNT <= N.
!
!  Z      (input) DOUBLE PRECISION array, dimension (N)
!         On entry, Z contains the updating vector (the last row of
!         the first sub-eigenvector matrix and the first row of the
!         second sub-eigenvector matrix).
!         On exit, the contents of Z are destroyed by the updating
!         process.
!
!  DLAMDA (output) DOUBLE PRECISION array, dimension (N)
!         A copy of the first K eigenvalues which will be used by
!         DLAED3 to form the secular equation.
!
!  Q2     (output) DOUBLE PRECISION array, dimension (LDQ2,N)
!         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
!         a copy of the first K eigenvectors which will be used by
!         DLAED7 in a matrix multiply (DGEMM) to update the new
!         eigenvectors.
!
!  LDQ2   (input) INTEGER
!         The leading dimension of the array Q2.  LDQ2 >= max(1,N).
!
!  W      (output) DOUBLE PRECISION array, dimension (N)
!         The first k values of the final deflation-altered z-vector and
!         will be passed to DLAED3.
!
!  PERM   (output) INTEGER array, dimension (N)
!         The permutations (from deflation and sorting) to be applied
!         to each eigenblock.
!
!  GIVPTR (output) INTEGER
!         The number of Givens rotations which took place in this
!         subproblem.
!
!  GIVCOL (output) INTEGER array, dimension (2, N)
!         Each pair of numbers indicates a pair of columns to take place
!         in a Givens rotation.
!
!  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
!         Each number indicates the S value to be used in the
!         corresponding Givens rotation.
!
!  INDXP  (workspace) INTEGER array, dimension (N)
!         The permutation used to place deflated values of D at the end
!         of the array.  INDXP(1:K) points to the nondeflated D-values
!         and INDXP(K+1:N) points to the deflated eigenvalues.
!
!  INDX   (workspace) INTEGER array, dimension (N)
!         The permutation used to sort the contents of D into ascending
!         order.
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   MONE, ZERO, ONE, TWO, EIGHT
      PARAMETER          ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, &
                         TWO = 2.0D0, EIGHT = 8.0D0 )
!     ..
!     .. Local Scalars ..
!
      INTEGER            I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
      DOUBLE PRECISION   C, EPS, S, T, TAU, TOL
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           IDAMAX, DLAMCH, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
         INFO = -4
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
         INFO = -10
      ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED8', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      N1 = CUTPNT
      N2 = N - N1
      N1P1 = N1 + 1
!
      IF( RHO.LT.ZERO ) THEN
         CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
      END IF
!
!     Normalize z so that norm(z) = 1
!
      T = ONE / SQRT( TWO )
      DO 10 J = 1, N
         INDX( J ) = J
   10 CONTINUE
      CALL DSCAL( N, T, Z, 1 )
      RHO = ABS( TWO*RHO )
!
!     Sort the eigenvalues into increasing order
!
      DO 20 I = CUTPNT + 1, N
         INDXQ( I ) = INDXQ( I ) + CUTPNT
   20 CONTINUE
      DO 30 I = 1, N
         DLAMDA( I ) = D( INDXQ( I ) )
         W( I ) = Z( INDXQ( I ) )
   30 CONTINUE
      I = 1
      J = CUTPNT + 1
      CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
      DO 40 I = 1, N
         D( I ) = DLAMDA( INDX( I ) )
         Z( I ) = W( INDX( I ) )
   40 CONTINUE
!
!     Calculate the allowable deflation tolerence
!
      IMAX = IDAMAX( N, Z, 1 )
      JMAX = IDAMAX( N, D, 1 )
      EPS = DLAMCH( 'Epsilon' )
      TOL = EIGHT*EPS*ABS( D( JMAX ) )
!
!     If the rank-1 modifier is small enough, no more needs to be done
!     except to reorganize Q so that its columns correspond with the
!     elements in D.
!
      IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
         K = 0
         IF( ICOMPQ.EQ.0 ) THEN
            DO 50 J = 1, N
               PERM( J ) = INDXQ( INDX( J ) )
   50       CONTINUE
         ELSE
            DO 60 J = 1, N
               PERM( J ) = INDXQ( INDX( J ) )
               CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
   60       CONTINUE
            CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), &
                         LDQ )
         END IF
         RETURN
      END IF
!
!     If there are multiple eigenvalues then the problem deflates.  Here
!     the number of equal eigenvalues are found.  As each equal
!     eigenvalue is found, an elementary reflector is computed to rotate
!     the corresponding eigensubspace so that the corresponding
!     components of Z are zero in this new basis.
!
      K = 0
      GIVPTR = 0
      K2 = N + 1
      DO 70 J = 1, N
         IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
!
!           Deflate due to small z component.
!
            K2 = K2 - 1
            INDXP( K2 ) = J
            IF( J.EQ.N ) &
               GO TO 110
         ELSE
            JLAM = J
            GO TO 80
         END IF
   70 CONTINUE
   80 CONTINUE
      J = J + 1
      IF( J.GT.N ) &
         GO TO 100
      IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
!
!        Deflate due to small z component.
!
         K2 = K2 - 1
         INDXP( K2 ) = J
      ELSE
!
!        Check if eigenvalues are close enough to allow deflation.
!
         S = Z( JLAM )
         C = Z( J )
!
!        Find sqrt(a**2+b**2) without overflow or
!        destructive underflow.
!
         TAU = DLAPY2( C, S )
         T = D( J ) - D( JLAM )
         C = C / TAU
         S = -S / TAU
         IF( ABS( T*C*S ).LE.TOL ) THEN
!
!           Deflation is possible.
!
            Z( J ) = TAU
            Z( JLAM ) = ZERO
!
!           Record the appropriate Givens rotation
!
            GIVPTR = GIVPTR + 1
            GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
            GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
            GIVNUM( 1, GIVPTR ) = C
            GIVNUM( 2, GIVPTR ) = S
            IF( ICOMPQ.EQ.1 ) THEN
               CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, &
                          Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
            END IF
            T = D( JLAM )*C*C + D( J )*S*S
            D( J ) = D( JLAM )*S*S + D( J )*C*C
            D( JLAM ) = T
            K2 = K2 - 1
            I = 1
   90       CONTINUE
            IF( K2+I.LE.N ) THEN
               IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
                  INDXP( K2+I-1 ) = INDXP( K2+I )
                  INDXP( K2+I ) = JLAM
                  I = I + 1
                  GO TO 90
               ELSE
                  INDXP( K2+I-1 ) = JLAM
               END IF
            ELSE
               INDXP( K2+I-1 ) = JLAM
            END IF
            JLAM = J
         ELSE
            K = K + 1
            W( K ) = Z( JLAM )
            DLAMDA( K ) = D( JLAM )
            INDXP( K ) = JLAM
            JLAM = J
         END IF
      END IF
      GO TO 80
  100 CONTINUE
!
!     Record the last eigenvalue.
!
      K = K + 1
      W( K ) = Z( JLAM )
      DLAMDA( K ) = D( JLAM )
      INDXP( K ) = JLAM
!
  110 CONTINUE
!
!     Sort the eigenvalues and corresponding eigenvectors into DLAMDA
!     and Q2 respectively.  The eigenvalues/vectors which were not
!     deflated go into the first K slots of DLAMDA and Q2 respectively,
!     while those which were deflated go into the last N - K slots.
!
      IF( ICOMPQ.EQ.0 ) THEN
         DO 120 J = 1, N
            JP = INDXP( J )
            DLAMDA( J ) = D( JP )
            PERM( J ) = INDXQ( INDX( JP ) )
  120    CONTINUE
      ELSE
         DO 130 J = 1, N
            JP = INDXP( J )
            DLAMDA( J ) = D( JP )
            PERM( J ) = INDXQ( INDX( JP ) )
            CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
  130    CONTINUE
      END IF
!
!     The deflated eigenvalues and their corresponding vectors go back
!     into the last N - K slots of D and Q respectively.
!
      IF( K.LT.N ) THEN
         IF( ICOMPQ.EQ.0 ) THEN
            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
         ELSE
            CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
            CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, &
                         Q( 1, K+1 ), LDQ )
         END IF
      END IF
!
      RETURN
!
!     End of DLAED8
!
      END
      SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, &
                         S, LDS, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, KSTART, KSTOP, LDQ, LDS, N
      DOUBLE PRECISION   RHO
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), &
                         W( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAED9 finds the roots of the secular equation, as defined by the
!  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the
!  appropriate calls to DLAED4 and then stores the new matrix of
!  eigenvectors for use in calculating the next level of Z vectors.
!
!  Arguments
!  =========
!
!  K       (input) INTEGER
!          The number of terms in the rational function to be solved by
!          DLAED4.  K >= 0.
!
!  KSTART  (input) INTEGER
!  KSTOP   (input) INTEGER
!          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
!          are to be computed.  1 <= KSTART <= KSTOP <= K.
!
!  N       (input) INTEGER
!          The number of rows and columns in the Q matrix.
!          N >= K (delation may result in N > K).
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          D(I) contains the updated eigenvalues
!          for KSTART <= I <= KSTOP.
!
!  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  LDQ >= max( 1, N ).
!
!  RHO     (input) DOUBLE PRECISION
!          The value of the parameter in the rank one update equation.
!          RHO >= 0 required.
!
!  DLAMDA  (input) DOUBLE PRECISION array, dimension (K)
!          The first K elements of this array contain the old roots
!          of the deflated updating problem.  These are the poles
!          of the secular equation.
!
!  W       (input) DOUBLE PRECISION array, dimension (K)
!          The first K elements of this array contain the components
!          of the deflation-adjusted updating vector.
!
!  S       (output) DOUBLE PRECISION array, dimension (LDS, K)
!          Will contain the eigenvectors of the repaired matrix which
!          will be stored for subsequent Z vector calculation and
!          multiplied by the previously accumulated eigenvectors
!          to update the system.
!
!  LDS     (input) INTEGER
!          The leading dimension of S.  LDS >= max( 1, K ).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an eigenvalue did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   TEMP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3, DNRM2
      EXTERNAL           DLAMC3, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAED4, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( K.LT.0 ) THEN
         INFO = -1
      ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
         INFO = -2
      ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) &
                THEN
         INFO = -3
      ELSE IF( N.LT.K ) THEN
         INFO = -4
      ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAED9', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.0 ) &
         RETURN
!
!     Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
!     be computed with high relative accuracy (barring over/underflow).
!     This is a problem on machines without a guard digit in
!     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
!     The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
!     which on any of these machines zeros out the bottommost
!     bit of DLAMDA(I) if it is 1; this makes the subsequent
!     subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
!     occurs. On binary machines with a guard digit (almost all
!     machines) it does not change DLAMDA(I) at all. On hexadecimal
!     and decimal machines with a guard digit, it slightly
!     changes the bottommost bits of DLAMDA(I). It does not account
!     for hexadecimal or decimal machines without guard digits
!     (we know of none). We use a subroutine call to compute
!     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
!     this code.
!
      DO 10 I = 1, N
         DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
   10 CONTINUE
!
      DO 20 J = KSTART, KSTOP
         CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
!
!        If the zero finder fails, the computation is terminated.
!
         IF( INFO.NE.0 ) &
            GO TO 120
   20 CONTINUE
!
      IF( K.EQ.1 .OR. K.EQ.2 ) THEN
         DO 40 I = 1, K
            DO 30 J = 1, K
               S( J, I ) = Q( J, I )
   30       CONTINUE
   40    CONTINUE
         GO TO 120
      END IF
!
!     Compute updated W.
!
      CALL DCOPY( K, W, 1, S, 1 )
!
!     Initialize W(I) = Q(I,I)
!
      CALL DCOPY( K, Q, LDQ+1, W, 1 )
      DO 70 J = 1, K
         DO 50 I = 1, J - 1
            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
   50    CONTINUE
         DO 60 I = J + 1, K
            W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
   60    CONTINUE
   70 CONTINUE
      DO 80 I = 1, K
         W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
   80 CONTINUE
!
!     Compute eigenvectors of the modified rank-1 modification.
!
      DO 110 J = 1, K
         DO 90 I = 1, K
            Q( I, J ) = W( I ) / Q( I, J )
   90    CONTINUE
         TEMP = DNRM2( K, Q( 1, J ), 1 )
         DO 100 I = 1, K
            S( I, J ) = Q( I, J ) / TEMP
  100    CONTINUE
  110 CONTINUE
!
  120 CONTINUE
      RETURN
!
!     End of DLAED9
!
      END
      SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, &
                         GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            CURLVL, CURPBM, INFO, N, TLVLS
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), &
                         PRMPTR( * ), QPTR( * )
      DOUBLE PRECISION   GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAEDA computes the Z vector corresponding to the merge step in the
!  CURLVLth step of the merge process with TLVLS steps for the CURPBMth
!  problem.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  TLVLS  (input) INTEGER
!         The total number of merging levels in the overall divide and
!         conquer tree.
!
!  CURLVL (input) INTEGER
!         The current level in the overall merge routine,
!         0 <= curlvl <= tlvls.
!
!  CURPBM (input) INTEGER
!         The current problem in the current level in the overall
!         merge routine (counting from upper left to lower right).
!
!  PRMPTR (input) INTEGER array, dimension (N lg N)
!         Contains a list of pointers which indicate where in PERM a
!         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!         indicates the size of the permutation and incidentally the
!         size of the full, non-deflated problem.
!
!  PERM   (input) INTEGER array, dimension (N lg N)
!         Contains the permutations (from deflation and sorting) to be
!         applied to each eigenblock.
!
!  GIVPTR (input) INTEGER array, dimension (N lg N)
!         Contains a list of pointers which indicate where in GIVCOL a
!         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!         indicates the number of Givens rotations.
!
!  GIVCOL (input) INTEGER array, dimension (2, N lg N)
!         Each pair of numbers indicates a pair of columns to take place
!         in a Givens rotation.
!
!  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
!         Each number indicates the S value to be used in the
!         corresponding Givens rotation.
!
!  Q      (input) DOUBLE PRECISION array, dimension (N**2)
!         Contains the square eigenblocks from previous levels, the
!         starting positions for blocks are given by QPTR.
!
!  QPTR   (input) INTEGER array, dimension (N+2)
!         Contains a list of pointers which indicate where in Q an
!         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates
!         the size of the block.
!
!  Z      (output) DOUBLE PRECISION array, dimension (N)
!         On output this vector contains the updating vector (the last
!         row of the first sub-eigenvector matrix and the first row of
!         the second sub-eigenvector matrix).
!
!  ZTEMP  (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, &
                         PTR, ZPTR1
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DROT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( N.LT.0 ) THEN
         INFO = -1
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAEDA', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine location of first number in second half.
!
      MID = N / 2 + 1
!
!     Gather last/first rows of appropriate eigenblocks into center of Z
!
      PTR = 1
!
!     Determine location of lowest level subproblem in the full storage
!     scheme
!
      CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
!
!     Determine size of these matrices.  We add HALF to the value of
!     the SQRT in case the machine underestimates one of these square
!     roots.
!
      BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
      BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
      DO 10 K = 1, MID - BSIZ1 - 1
         Z( K ) = ZERO
   10 CONTINUE
      CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, &
                  Z( MID-BSIZ1 ), 1 )
      CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
      DO 20 K = MID + BSIZ2, N
         Z( K ) = ZERO
   20 CONTINUE
!
!     Loop thru remaining levels 1 -> CURLVL applying the Givens
!     rotations and permutation and then multiplying the center matrices
!     against the current Z.
!
      PTR = 2**TLVLS + 1
      DO 70 K = 1, CURLVL - 1
         CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
         ZPTR1 = MID - PSIZ1
!
!       Apply Givens at CURR and CURR+1
!
         DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
            CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, &
                       Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), &
                       GIVNUM( 2, I ) )
   30    CONTINUE
         DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
            CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, &
                       Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), &
                       GIVNUM( 2, I ) )
   40    CONTINUE
         PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
         PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
         DO 50 I = 0, PSIZ1 - 1
            ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
   50    CONTINUE
         DO 60 I = 0, PSIZ2 - 1
            ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
   60    CONTINUE
!
!        Multiply Blocks at CURR and CURR+1
!
!        Determine size of these matrices.  We add HALF to the value of
!        the SQRT in case the machine underestimates one of these
!        square roots.
!
         BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
         BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ &
                 1 ) ) ) )
         IF( BSIZ1.GT.0 ) THEN
            CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), &
                        BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
         END IF
         CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), &
                     1 )
         IF( BSIZ2.GT.0 ) THEN
            CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), &
                        BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
         END IF
         CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, &
                     Z( MID+BSIZ2 ), 1 )
!
         PTR = PTR + 2**( TLVLS-K )
   70 CONTINUE
!
      RETURN
!
!     End of DLAEDA
!
      END
      SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, &
                         LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      LOGICAL            NOINIT, RIGHTV
      INTEGER            INFO, LDB, LDH, N
      DOUBLE PRECISION   BIGNUM, EPS3, SMLNUM, WI, WR
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), H( LDH, * ), VI( * ), VR( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAEIN uses inverse iteration to find a right or left eigenvector
!  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!  matrix H.
!
!  Arguments
!  =========
!
!  RIGHTV   (input) LOGICAL
!          = .TRUE. : compute right eigenvector;
!          = .FALSE.: compute left eigenvector.
!
!  NOINIT   (input) LOGICAL
!          = .TRUE. : no initial vector supplied in (VR,VI).
!          = .FALSE.: initial vector supplied in (VR,VI).
!
!  N       (input) INTEGER
!          The order of the matrix H.  N >= 0.
!
!  H       (input) DOUBLE PRECISION array, dimension (LDH,N)
!          The upper Hessenberg matrix H.
!
!  LDH     (input) INTEGER
!          The leading dimension of the array H.  LDH >= max(1,N).
!
!  WR      (input) DOUBLE PRECISION
!  WI      (input) DOUBLE PRECISION
!          The real and imaginary parts of the eigenvalue of H whose
!          corresponding right or left eigenvector is to be computed.
!
!  VR      (input/output) DOUBLE PRECISION array, dimension (N)
!  VI      (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
!          a real starting vector for inverse iteration using the real
!          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
!          must contain the real and imaginary parts of a complex
!          starting vector for inverse iteration using the complex
!          eigenvalue (WR,WI); otherwise VR and VI need not be set.
!          On exit, if WI = 0.0 (real eigenvalue), VR contains the
!          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
!          VR and VI contain the real and imaginary parts of the
!          computed complex eigenvector. The eigenvector is normalized
!          so that the component of largest magnitude has magnitude 1;
!          here the magnitude of a complex number (x,y) is taken to be
!          |x| + |y|.
!          VI is not referenced if WI = 0.0.
!
!  B       (workspace) DOUBLE PRECISION array, dimension (LDB,N)
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= N+1.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension (N)
!
!  EPS3    (input) DOUBLE PRECISION
!          A small machine-dependent value which is used to perturb
!          close eigenvalues, and to replace zero pivots.
!
!  SMLNUM  (input) DOUBLE PRECISION
!          A machine-dependent value close to the underflow threshold.
!
!  BIGNUM  (input) DOUBLE PRECISION
!          A machine-dependent value close to the overflow threshold.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          = 1:  inverse iteration did not converge; VR is set to the
!                last iterate, and so is VI if WI.ne.0.0.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TENTH
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 )
!     ..
!     .. Local Scalars ..
      CHARACTER          NORMIN, TRANS
      INTEGER            I, I1, I2, I3, IERR, ITS, J
      DOUBLE PRECISION   ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML, &
                         REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W, &
                         W1, X, XI, XR, Y
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DLAPY2, DNRM2
      EXTERNAL           IDAMAX, DASUM, DLAPY2, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLADIV, DLATRS, DSCAL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
!     GROWTO is the threshold used in the acceptance test for an
!     eigenvector.
!
      ROOTN = SQRT( DBLE( N ) )
      GROWTO = TENTH / ROOTN
      NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
!
!     Form B = H - (WR,WI)*I (except that the subdiagonal elements and
!     the imaginary parts of the diagonal elements are not stored).
!
      DO 20 J = 1, N
         DO 10 I = 1, J - 1
            B( I, J ) = H( I, J )
   10    CONTINUE
         B( J, J ) = H( J, J ) - WR
   20 CONTINUE
!
      IF( WI.EQ.ZERO ) THEN
!
!        Real eigenvalue.
!
         IF( NOINIT ) THEN
!
!           Set initial vector.
!
            DO 30 I = 1, N
               VR( I ) = EPS3
   30       CONTINUE
         ELSE
!
!           Scale supplied initial vector.
!
            VNORM = DNRM2( N, VR, 1 )
            CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR, &
                        1 )
         END IF
!
         IF( RIGHTV ) THEN
!
!           LU decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
            DO 60 I = 1, N - 1
               EI = H( I+1, I )
               IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
!
!                 Interchange rows and eliminate.
!
                  X = B( I, I ) / EI
                  B( I, I ) = EI
                  DO 40 J = I + 1, N
                     TEMP = B( I+1, J )
                     B( I+1, J ) = B( I, J ) - X*TEMP
                     B( I, J ) = TEMP
   40             CONTINUE
               ELSE
!
!                 Eliminate without interchange.
!
                  IF( B( I, I ).EQ.ZERO ) &
                     B( I, I ) = EPS3
                  X = EI / B( I, I )
                  IF( X.NE.ZERO ) THEN
                     DO 50 J = I + 1, N
                        B( I+1, J ) = B( I+1, J ) - X*B( I, J )
   50                CONTINUE
                  END IF
               END IF
   60       CONTINUE
            IF( B( N, N ).EQ.ZERO ) &
               B( N, N ) = EPS3
!
            TRANS = 'N'
!
         ELSE
!
!           UL decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
            DO 90 J = N, 2, -1
               EJ = H( J, J-1 )
               IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
!
!                 Interchange columns and eliminate.
!
                  X = B( J, J ) / EJ
                  B( J, J ) = EJ
                  DO 70 I = 1, J - 1
                     TEMP = B( I, J-1 )
                     B( I, J-1 ) = B( I, J ) - X*TEMP
                     B( I, J ) = TEMP
   70             CONTINUE
               ELSE
!
!                 Eliminate without interchange.
!
                  IF( B( J, J ).EQ.ZERO ) &
                     B( J, J ) = EPS3
                  X = EJ / B( J, J )
                  IF( X.NE.ZERO ) THEN
                     DO 80 I = 1, J - 1
                        B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
   80                CONTINUE
                  END IF
               END IF
   90       CONTINUE
            IF( B( 1, 1 ).EQ.ZERO ) &
               B( 1, 1 ) = EPS3
!
            TRANS = 'T'
!
         END IF
!
         NORMIN = 'N'
         DO 110 ITS = 1, N
!
!           Solve U*x = scale*v for a right eigenvector
!             or U'*x = scale*v for a left eigenvector,
!           overwriting x on v.
!
            CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB, &
                         VR, SCALE, WORK, IERR )
            NORMIN = 'Y'
!
!           Test for sufficient growth in the norm of v.
!
            VNORM = DASUM( N, VR, 1 )
            IF( VNORM.GE.GROWTO*SCALE ) &
               GO TO 120
!
!           Choose new orthogonal starting vector and try again.
!
            TEMP = EPS3 / ( ROOTN+ONE )
            VR( 1 ) = EPS3
            DO 100 I = 2, N
               VR( I ) = TEMP
  100       CONTINUE
            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
  110    CONTINUE
!
!        Failure to find eigenvector in N iterations.
!
         INFO = 1
!
  120    CONTINUE
!
!        Normalize eigenvector.
!
         I = IDAMAX( N, VR, 1 )
         CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
      ELSE
!
!        Complex eigenvalue.
!
         IF( NOINIT ) THEN
!
!           Set initial vector.
!
            DO 130 I = 1, N
               VR( I ) = EPS3
               VI( I ) = ZERO
  130       CONTINUE
         ELSE
!
!           Scale supplied initial vector.
!
            NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) )
            REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
            CALL DSCAL( N, REC, VR, 1 )
            CALL DSCAL( N, REC, VI, 1 )
         END IF
!
         IF( RIGHTV ) THEN
!
!           LU decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
!           The imaginary part of the (i,j)-th element of U is stored in
!           B(j+1,i).
!
            B( 2, 1 ) = -WI
            DO 140 I = 2, N
               B( I+1, 1 ) = ZERO
  140       CONTINUE
!
            DO 170 I = 1, N - 1
               ABSBII = DLAPY2( B( I, I ), B( I+1, I ) )
               EI = H( I+1, I )
               IF( ABSBII.LT.ABS( EI ) ) THEN
!
!                 Interchange rows and eliminate.
!
                  XR = B( I, I ) / EI
                  XI = B( I+1, I ) / EI
                  B( I, I ) = EI
                  B( I+1, I ) = ZERO
                  DO 150 J = I + 1, N
                     TEMP = B( I+1, J )
                     B( I+1, J ) = B( I, J ) - XR*TEMP
                     B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
                     B( I, J ) = TEMP
                     B( J+1, I ) = ZERO
  150             CONTINUE
                  B( I+2, I ) = -WI
                  B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
                  B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
               ELSE
!
!                 Eliminate without interchanging rows.
!
                  IF( ABSBII.EQ.ZERO ) THEN
                     B( I, I ) = EPS3
                     B( I+1, I ) = ZERO
                     ABSBII = EPS3
                  END IF
                  EI = ( EI / ABSBII ) / ABSBII
                  XR = B( I, I )*EI
                  XI = -B( I+1, I )*EI
                  DO 160 J = I + 1, N
                     B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) + &
                                   XI*B( J+1, I )
                     B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
  160             CONTINUE
                  B( I+2, I+1 ) = B( I+2, I+1 ) - WI
               END IF
!
!              Compute 1-norm of offdiagonal elements of i-th row.
!
               WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) + &
                           DASUM( N-I, B( I+2, I ), 1 )
  170       CONTINUE
            IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO ) &
               B( N, N ) = EPS3
            WORK( N ) = ZERO
!
            I1 = N
            I2 = 1
            I3 = -1
         ELSE
!
!           UL decomposition with partial pivoting of conjg(B),
!           replacing zero pivots by EPS3.
!
!           The imaginary part of the (i,j)-th element of U is stored in
!           B(j+1,i).
!
            B( N+1, N ) = WI
            DO 180 J = 1, N - 1
               B( N+1, J ) = ZERO
  180       CONTINUE
!
            DO 210 J = N, 2, -1
               EJ = H( J, J-1 )
               ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) )
               IF( ABSBJJ.LT.ABS( EJ ) ) THEN
!
!                 Interchange columns and eliminate
!
                  XR = B( J, J ) / EJ
                  XI = B( J+1, J ) / EJ
                  B( J, J ) = EJ
                  B( J+1, J ) = ZERO
                  DO 190 I = 1, J - 1
                     TEMP = B( I, J-1 )
                     B( I, J-1 ) = B( I, J ) - XR*TEMP
                     B( J, I ) = B( J+1, I ) - XI*TEMP
                     B( I, J ) = TEMP
                     B( J+1, I ) = ZERO
  190             CONTINUE
                  B( J+1, J-1 ) = WI
                  B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
                  B( J, J-1 ) = B( J, J-1 ) - XR*WI
               ELSE
!
!                 Eliminate without interchange.
!
                  IF( ABSBJJ.EQ.ZERO ) THEN
                     B( J, J ) = EPS3
                     B( J+1, J ) = ZERO
                     ABSBJJ = EPS3
                  END IF
                  EJ = ( EJ / ABSBJJ ) / ABSBJJ
                  XR = B( J, J )*EJ
                  XI = -B( J+1, J )*EJ
                  DO 200 I = 1, J - 1
                     B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) + &
                                   XI*B( J+1, I )
                     B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
  200             CONTINUE
                  B( J, J-1 ) = B( J, J-1 ) + WI
               END IF
!
!              Compute 1-norm of offdiagonal elements of j-th column.
!
               WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) + &
                           DASUM( J-1, B( J+1, 1 ), LDB )
  210       CONTINUE
            IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO ) &
               B( 1, 1 ) = EPS3
            WORK( 1 ) = ZERO
!
            I1 = 1
            I2 = N
            I3 = 1
         END IF
!
         DO 270 ITS = 1, N
            SCALE = ONE
            VMAX = ONE
            VCRIT = BIGNUM
!
!           Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
!             or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
!           overwriting (xr,xi) on (vr,vi).
!
            DO 250 I = I1, I2, I3
!
               IF( WORK( I ).GT.VCRIT ) THEN
                  REC = ONE / VMAX
                  CALL DSCAL( N, REC, VR, 1 )
                  CALL DSCAL( N, REC, VI, 1 )
                  SCALE = SCALE*REC
                  VMAX = ONE
                  VCRIT = BIGNUM
               END IF
!
               XR = VR( I )
               XI = VI( I )
               IF( RIGHTV ) THEN
                  DO 220 J = I + 1, N
                     XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
                     XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
  220             CONTINUE
               ELSE
                  DO 230 J = 1, I - 1
                     XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
                     XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
  230             CONTINUE
               END IF
!
               W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
               IF( W.GT.SMLNUM ) THEN
                  IF( W.LT.ONE ) THEN
                     W1 = ABS( XR ) + ABS( XI )
                     IF( W1.GT.W*BIGNUM ) THEN
                        REC = ONE / W1
                        CALL DSCAL( N, REC, VR, 1 )
                        CALL DSCAL( N, REC, VI, 1 )
                        XR = VR( I )
                        XI = VI( I )
                        SCALE = SCALE*REC
                        VMAX = VMAX*REC
                     END IF
                  END IF
!
!                 Divide by diagonal element of B.
!
                  CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ), &
                               VI( I ) )
                  VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
                  VCRIT = BIGNUM / VMAX
               ELSE
                  DO 240 J = 1, N
                     VR( J ) = ZERO
                     VI( J ) = ZERO
  240             CONTINUE
                  VR( I ) = ONE
                  VI( I ) = ONE
                  SCALE = ZERO
                  VMAX = ONE
                  VCRIT = BIGNUM
               END IF
  250       CONTINUE
!
!           Test for sufficient growth in the norm of (VR,VI).
!
            VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 )
            IF( VNORM.GE.GROWTO*SCALE ) &
               GO TO 280
!
!           Choose a new orthogonal starting vector and try again.
!
            Y = EPS3 / ( ROOTN+ONE )
            VR( 1 ) = EPS3
            VI( 1 ) = ZERO
!
            DO 260 I = 2, N
               VR( I ) = Y
               VI( I ) = ZERO
  260       CONTINUE
            VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
  270    CONTINUE
!
!        Failure to find eigenvector in N iterations
!
         INFO = 1
!
  280    CONTINUE
!
!        Normalize eigenvector.
!
         VNORM = ZERO
         DO 290 I = 1, N
            VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
  290    CONTINUE
         CALL DSCAL( N, ONE / VNORM, VR, 1 )
         CALL DSCAL( N, ONE / VNORM, VI, 1 )
!
      END IF
!
      RETURN
!
!     End of DLAEIN
!
      END
      SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, CS1, RT1, RT2, SN1
!     ..
!
!  Purpose
!  =======
!
!  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
!     [  A   B  ]
!     [  B   C  ].
!  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
!  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
!  eigenvector for RT1, giving the decomposition
!
!     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
!     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
!
!  Arguments
!  =========
!
!  A       (input) DOUBLE PRECISION
!          The (1,1) element of the 2-by-2 matrix.
!
!  B       (input) DOUBLE PRECISION
!          The (1,2) element and the conjugate of the (2,1) element of
!          the 2-by-2 matrix.
!
!  C       (input) DOUBLE PRECISION
!          The (2,2) element of the 2-by-2 matrix.
!
!  RT1     (output) DOUBLE PRECISION
!          The eigenvalue of larger absolute value.
!
!  RT2     (output) DOUBLE PRECISION
!          The eigenvalue of smaller absolute value.
!
!  CS1     (output) DOUBLE PRECISION
!  SN1     (output) DOUBLE PRECISION
!          The vector (CS1, SN1) is a unit right eigenvector for RT1.
!
!  Further Details
!  ===============
!
!  RT1 is accurate to a few ulps barring over/underflow.
!
!  RT2 may be inaccurate if there is massive cancellation in the
!  determinant A*C-B*B; higher precision or correctly rounded or
!  correctly truncated arithmetic would be needed to compute RT2
!  accurately in all cases.
!
!  CS1 and SN1 are accurate to a few ulps barring over/underflow.
!
!  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!  Underflow is harmless if the input data is 0 or exceeds
!     underflow_threshold / macheps.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            SGN1, SGN2
      DOUBLE PRECISION   AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, &
                         TB, TN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
!     Compute the eigenvalues
!
      SM = A + C
      DF = A - C
      ADF = ABS( DF )
      TB = B + B
      AB = ABS( TB )
      IF( ABS( A ).GT.ABS( C ) ) THEN
         ACMX = A
         ACMN = C
      ELSE
         ACMX = C
         ACMN = A
      END IF
      IF( ADF.GT.AB ) THEN
         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
      ELSE IF( ADF.LT.AB ) THEN
         RT = AB*SQRT( ONE+( ADF / AB )**2 )
      ELSE
!
!        Includes case AB=ADF=0
!
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
         SGN1 = -1
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
         SGN1 = 1
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
!
!        Includes case RT1 = RT2 = 0
!
         RT1 = HALF*RT
         RT2 = -HALF*RT
         SGN1 = 1
      END IF
!
!     Compute the eigenvector
!
      IF( DF.GE.ZERO ) THEN
         CS = DF + RT
         SGN2 = 1
      ELSE
         CS = DF - RT
         SGN2 = -1
      END IF
      ACS = ABS( CS )
      IF( ACS.GT.AB ) THEN
         CT = -TB / CS
         SN1 = ONE / SQRT( ONE+CT*CT )
         CS1 = CT*SN1
      ELSE
         IF( AB.EQ.ZERO ) THEN
            CS1 = ONE
            SN1 = ZERO
         ELSE
            TN = -CS / TB
            CS1 = ONE / SQRT( ONE+TN*TN )
            SN1 = TN*CS1
         END IF
      END IF
      IF( SGN1.EQ.SGN2 ) THEN
         TN = CS1
         CS1 = -SN1
         SN1 = TN
      END IF
      RETURN
!
!     End of DLAEV2
!
      END
      SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, &
                         INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            WANTQ
      INTEGER            INFO, J1, LDQ, LDT, N, N1, N2
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
!  an upper quasi-triangular matrix T by an orthogonal similarity
!  transformation.
!
!  T must be in Schur canonical form, that is, block upper triangular
!  with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
!  has its diagonal elemnts equal and its off-diagonal elements of
!  opposite sign.
!
!  Arguments
!  =========
!
!  WANTQ   (input) LOGICAL
!          = .TRUE. : accumulate the transformation in the matrix Q;
!          = .FALSE.: do not accumulate the transformation.
!
!  N       (input) INTEGER
!          The order of the matrix T. N >= 0.
!
!  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
!          On entry, the upper quasi-triangular matrix T, in Schur
!          canonical form.
!          On exit, the updated matrix T, again in Schur canonical form.
!
!  LDT     (input)  INTEGER
!          The leading dimension of the array T. LDT >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
!          On exit, if WANTQ is .TRUE., the updated matrix Q.
!          If WANTQ is .FALSE., Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.
!          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
!
!  J1      (input) INTEGER
!          The index of the first row of the first block T11.
!
!  N1      (input) INTEGER
!          The order of the first block T11. N1 = 0, 1 or 2.
!
!  N2      (input) INTEGER
!          The order of the second block T22. N2 = 0, 1 or 2.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          = 1: the transformed matrix T would be too far from Schur
!               form; the blocks are not swapped and T and Q are
!               unchanged.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 1.0D+1 )
      INTEGER            LDD, LDX
      PARAMETER          ( LDD = 4, LDX = 2 )
!     ..
!     .. Local Scalars ..
      INTEGER            IERR, J2, J3, J4, K, ND
      DOUBLE PRECISION   CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, &
                         T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, &
                         WR1, WR2, XNORM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), &
                         X( LDX, 2 )
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, &
                         DROT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) &
         RETURN
      IF( J1+N1.GT.N ) &
         RETURN
!
      J2 = J1 + 1
      J3 = J1 + 2
      J4 = J1 + 3
!
      IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
!
!        Swap two 1-by-1 blocks.
!
         T11 = T( J1, J1 )
         T22 = T( J2, J2 )
!
!        Determine the transformation to perform the interchange.
!
         CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
!
!        Apply transformation to the matrix T.
!
         IF( J3.LE.N ) &
            CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, &
                       SN )
         CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
!
         T( J1, J1 ) = T22
         T( J2, J2 ) = T11
!
         IF( WANTQ ) THEN
!
!           Accumulate transformation in the matrix Q.
!
            CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
         END IF
!
      ELSE
!
!        Swapping involves at least one 2-by-2 block.
!
!        Copy the diagonal block of order N1+N2 to the local array D
!        and compute its norm.
!
         ND = N1 + N2
         CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
         DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK )
!
!        Compute machine-dependent threshold for test for accepting
!        swap.
!
         EPS = DLAMCH( 'P' )
         SMLNUM = DLAMCH( 'S' ) / EPS
         THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
!
!        Solve T11*X - X*T22 = scale*T12 for X.
!
         CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, &
                      D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, &
                      LDX, XNORM, IERR )
!
!        Swap the adjacent diagonal blocks.
!
         K = N1 + N1 + N2 - 3
         GO TO ( 10, 20, 30 )K
!
   10    CONTINUE
!
!        N1 = 1, N2 = 2: generate elementary reflector H so that:
!
!        ( scale, X11, X12 ) H = ( 0, 0, * )
!
         U( 1 ) = SCALE
         U( 2 ) = X( 1, 1 )
         U( 3 ) = X( 1, 2 )
         CALL DLARFG( 3, U( 3 ), U, 1, TAU )
         U( 3 ) = ONE
         T11 = T( J1, J1 )
!
!        Perform swap provisionally on diagonal block in D.
!
         CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
         CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
!
!        Test whether to reject swap.
!
         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, &
             3 )-T11 ) ).GT.THRESH )GO TO 50
!
!        Accept swap: apply transformation to the entire matrix T.
!
         CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
         CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
!
         T( J3, J1 ) = ZERO
         T( J3, J2 ) = ZERO
         T( J3, J3 ) = T11
!
         IF( WANTQ ) THEN
!
!           Accumulate transformation in the matrix Q.
!
            CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
         END IF
         GO TO 40
!
   20    CONTINUE
!
!        N1 = 2, N2 = 1: generate elementary reflector H so that:
!
!        H (  -X11 ) = ( * )
!          (  -X21 ) = ( 0 )
!          ( scale ) = ( 0 )
!
         U( 1 ) = -X( 1, 1 )
         U( 2 ) = -X( 2, 1 )
         U( 3 ) = SCALE
         CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
         U( 1 ) = ONE
         T33 = T( J3, J3 )
!
!        Perform swap provisionally on diagonal block in D.
!
         CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
         CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
!
!        Test whether to reject swap.
!
         IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, &
             1 )-T33 ) ).GT.THRESH )GO TO 50
!
!        Accept swap: apply transformation to the entire matrix T.
!
         CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
         CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
!
         T( J1, J1 ) = T33
         T( J2, J1 ) = ZERO
         T( J3, J1 ) = ZERO
!
         IF( WANTQ ) THEN
!
!           Accumulate transformation in the matrix Q.
!
            CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
         END IF
         GO TO 40
!
   30    CONTINUE
!
!        N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
!        that:
!
!        H(2) H(1) (  -X11  -X12 ) = (  *  * )
!                  (  -X21  -X22 )   (  0  * )
!                  ( scale    0  )   (  0  0 )
!                  (    0  scale )   (  0  0 )
!
         U1( 1 ) = -X( 1, 1 )
         U1( 2 ) = -X( 2, 1 )
         U1( 3 ) = SCALE
         CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
         U1( 1 ) = ONE
!
         TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
         U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
         U2( 2 ) = -TEMP*U1( 3 )
         U2( 3 ) = SCALE
         CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
         U2( 1 ) = ONE
!
!        Perform swap provisionally on diagonal block in D.
!
         CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
         CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
         CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
         CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
!
!        Test whether to reject swap.
!
         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), &
             ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
!
!        Accept swap: apply transformation to the entire matrix T.
!
         CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
         CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
         CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
         CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
!
         T( J3, J1 ) = ZERO
         T( J3, J2 ) = ZERO
         T( J4, J1 ) = ZERO
         T( J4, J2 ) = ZERO
!
         IF( WANTQ ) THEN
!
!           Accumulate transformation in the matrix Q.
!
            CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
            CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
         END IF
!
   40    CONTINUE
!
         IF( N2.EQ.2 ) THEN
!
!           Standardize new 2-by-2 block T11
!
            CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), &
                         T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
            CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, &
                       CS, SN )
            CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
            IF( WANTQ ) &
               CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
         END IF
!
         IF( N1.EQ.2 ) THEN
!
!           Standardize new 2-by-2 block T22
!
            J3 = J1 + N2
            J4 = J3 + 1
            CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), &
                         T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
            IF( J3+2.LE.N ) &
               CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), &
                          LDT, CS, SN )
            CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
            IF( WANTQ ) &
               CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
         END IF
!
      END IF
      RETURN
!
!     Exit with INFO = 1 if swap was rejected.
!
   50 CONTINUE
      INFO = 1
      RETURN
!
!     End of DLAEXC
!
      END
      SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, &
                        WR2, WI )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            LDA, LDB
      DOUBLE PRECISION   SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
!  problem  A - w B, with scaling as necessary to avoid over-/underflow.
!
!  The scaling factor "s" results in a modified eigenvalue equation
!
!      s A - w B
!
!  where  s  is a non-negative scaling factor chosen so that  w,  w B,
!  and  s A  do not overflow and, if possible, do not underflow, either.
!
!  Arguments
!  =========
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA, 2)
!          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm
!          is less than 1/SAFMIN.  Entries less than
!          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= 2.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB, 2)
!          On entry, the 2 x 2 upper triangular matrix B.  It is
!          assumed that the one-norm of B is less than 1/SAFMIN.  The
!          diagonals should be at least sqrt(SAFMIN) times the largest
!          element of B (in absolute value); if a diagonal is smaller
!          than that, then  +/- sqrt(SAFMIN) will be used instead of
!          that diagonal.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= 2.
!
!  SAFMIN  (input) DOUBLE PRECISION
!          The smallest positive number s.t. 1/SAFMIN does not
!          overflow.  (This should always be DLAMCH('S') -- it is an
!          argument in order to avoid having to call DLAMCH frequently.)
!
!  SCALE1  (output) DOUBLE PRECISION
!          A scaling factor used to avoid over-/underflow in the
!          eigenvalue equation which defines the first eigenvalue.  If
!          the eigenvalues are complex, then the eigenvalues are
!          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the
!          exponent range of the machine), SCALE1=SCALE2, and SCALE1
!          will always be positive.  If the eigenvalues are real, then
!          the first (real) eigenvalue is  WR1 / SCALE1 , but this may
!          overflow or underflow, and in fact, SCALE1 may be zero or
!          less than the underflow threshhold if the exact eigenvalue
!          is sufficiently large.
!
!  SCALE2  (output) DOUBLE PRECISION
!          A scaling factor used to avoid over-/underflow in the
!          eigenvalue equation which defines the second eigenvalue.  If
!          the eigenvalues are complex, then SCALE2=SCALE1.  If the
!          eigenvalues are real, then the second (real) eigenvalue is
!          WR2 / SCALE2 , but this may overflow or underflow, and in
!          fact, SCALE2 may be zero or less than the underflow
!          threshhold if the exact eigenvalue is sufficiently large.
!
!  WR1     (output) DOUBLE PRECISION
!          If the eigenvalue is real, then WR1 is SCALE1 times the
!          eigenvalue closest to the (2,2) element of A B**(-1).  If the
!          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
!          part of the eigenvalues.
!
!  WR2     (output) DOUBLE PRECISION
!          If the eigenvalue is real, then WR2 is SCALE2 times the
!          other eigenvalue.  If the eigenvalue is complex, then
!          WR1=WR2 is SCALE1 times the real part of the eigenvalues.
!
!  WI      (output) DOUBLE PRECISION
!          If the eigenvalue is real, then WI is zero.  If the
!          eigenvalue is complex, then WI is SCALE1 times the imaginary
!          part of the eigenvalues.  WI will always be non-negative.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = ONE / TWO )
      DOUBLE PRECISION   FUZZY1
      PARAMETER          ( FUZZY1 = ONE+1.0D-5 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   A11, A12, A21, A22, ABI22, ANORM, AS11, AS12, &
                         AS22, ASCALE, B11, B12, B22, BINV11, BINV22, &
                         BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5, &
                         DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2, &
                         SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET, &
                         WSCALE, WSIZE, WSMALL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
      RTMIN = SQRT( SAFMIN )
      RTMAX = ONE / RTMIN
      SAFMAX = ONE / SAFMIN
!
!     Scale A
!
      ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), &
              ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
      ASCALE = ONE / ANORM
      A11 = ASCALE*A( 1, 1 )
      A21 = ASCALE*A( 2, 1 )
      A12 = ASCALE*A( 1, 2 )
      A22 = ASCALE*A( 2, 2 )
!
!     Perturb B if necessary to insure non-singularity
!
      B11 = B( 1, 1 )
      B12 = B( 1, 2 )
      B22 = B( 2, 2 )
      BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
      IF( ABS( B11 ).LT.BMIN ) &
         B11 = SIGN( BMIN, B11 )
      IF( ABS( B22 ).LT.BMIN ) &
         B22 = SIGN( BMIN, B22 )
!
!     Scale B
!
      BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
      BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
      BSCALE = ONE / BSIZE
      B11 = B11*BSCALE
      B12 = B12*BSCALE
      B22 = B22*BSCALE
!
!     Compute larger eigenvalue by method described by C. van Loan
!
!     ( AS is A shifted by -SHIFT*B )
!
      BINV11 = ONE / B11
      BINV22 = ONE / B22
      S1 = A11*BINV11
      S2 = A22*BINV22
      IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
         AS12 = A12 - S1*B12
         AS22 = A22 - S1*B22
         SS = A21*( BINV11*BINV22 )
         ABI22 = AS22*BINV22 - SS*B12
         PP = HALF*ABI22
         SHIFT = S1
      ELSE
         AS12 = A12 - S2*B12
         AS11 = A11 - S2*B11
         SS = A21*( BINV11*BINV22 )
         ABI22 = -SS*B12
         PP = HALF*( AS11*BINV11+ABI22 )
         SHIFT = S2
      END IF
      QQ = SS*AS12
      IF( ABS( PP*RTMIN ).GE.ONE ) THEN
         DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
         R = SQRT( ABS( DISCR ) )*RTMAX
      ELSE
         IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
            DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
            R = SQRT( ABS( DISCR ) )*RTMIN
         ELSE
            DISCR = PP**2 + QQ
            R = SQRT( ABS( DISCR ) )
         END IF
      END IF
!
!     Note: the test of R in the following IF is to cover the case when
!           DISCR is small and negative and is flushed to zero during
!           the calculation of R.  On machines which have a consistent
!           flush-to-zero threshhold and handle numbers above that
!           threshhold correctly, it would not be necessary.
!
      IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
         SUM = PP + SIGN( R, PP )
         DIFF = PP - SIGN( R, PP )
         WBIG = SHIFT + SUM
!
!        Compute smaller eigenvalue
!
         WSMALL = SHIFT + DIFF
         IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
            WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
            WSMALL = WDET / WBIG
         END IF
!
!        Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
!        for WR1.
!
         IF( PP.GT.ABI22 ) THEN
            WR1 = MIN( WBIG, WSMALL )
            WR2 = MAX( WBIG, WSMALL )
         ELSE
            WR1 = MAX( WBIG, WSMALL )
            WR2 = MIN( WBIG, WSMALL )
         END IF
         WI = ZERO
      ELSE
!
!        Complex eigenvalues
!
         WR1 = SHIFT + PP
         WR2 = WR1
         WI = R
      END IF
!
!     Further scaling to avoid underflow and overflow in computing
!     SCALE1 and overflow in computing w*B.
!
!     This scale factor (WSCALE) is bounded from above using C1 and C2,
!     and from below using C3 and C4.
!        C1 implements the condition  s A  must never overflow.
!        C2 implements the condition  w B  must never overflow.
!        C3, with C2,
!           implement the condition that s A - w B must never overflow.
!        C4 implements the condition  s    should not underflow.
!        C5 implements the condition  max(s,|w|) should be at least 2.
!
      C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
      C2 = SAFMIN*MAX( ONE, BNORM )
      C3 = BSIZE*SAFMIN
      IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
         C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
      ELSE
         C4 = ONE
      END IF
      IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
         C5 = MIN( ONE, ASCALE*BSIZE )
      ELSE
         C5 = ONE
      END IF
!
!     Scale first eigenvalue
!
      WABS = ABS( WR1 ) + ABS( WI )
      WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ), &
              MIN( C4, HALF*MAX( WABS, C5 ) ) )
      IF( WSIZE.NE.ONE ) THEN
         WSCALE = ONE / WSIZE
         IF( WSIZE.GT.ONE ) THEN
            SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )* &
                     MIN( ASCALE, BSIZE )
         ELSE
            SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )* &
                     MAX( ASCALE, BSIZE )
         END IF
         WR1 = WR1*WSCALE
         IF( WI.NE.ZERO ) THEN
            WI = WI*WSCALE
            WR2 = WR1
            SCALE2 = SCALE1
         END IF
      ELSE
         SCALE1 = ASCALE*BSIZE
         SCALE2 = SCALE1
      END IF
!
!     Scale second eigenvalue (if real)
!
      IF( WI.EQ.ZERO ) THEN
         WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ), &
                 MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
         IF( WSIZE.NE.ONE ) THEN
            WSCALE = ONE / WSIZE
            IF( WSIZE.GT.ONE ) THEN
               SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )* &
                        MIN( ASCALE, BSIZE )
            ELSE
               SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )* &
                        MAX( ASCALE, BSIZE )
            END IF
            WR2 = WR2*WSCALE
         ELSE
            SCALE2 = ASCALE*BSIZE
         END IF
      END IF
!
!     End of DLAG2
!
      RETURN
      END
      SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, &
                         SNV, CSQ, SNQ )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      LOGICAL            UPPER
      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, &
                         SNU, SNV
!     ..
!
!  Purpose
!  =======
!
!  DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
!  that if ( UPPER ) then
!
!            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
!                        ( 0  A3 )     ( x  x  )
!  and
!            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
!                        ( 0  B3 )     ( x  x  )
!
!  or if ( .NOT.UPPER ) then
!
!            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
!                        ( A2 A3 )     ( 0  x  )
!  and
!            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
!                        ( B2 B3 )     ( 0  x  )
!
!  The rows of the transformed A and B are parallel, where
!
!    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
!        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
!
!  Z' denotes the transpose of Z.
!
!
!  Arguments
!  =========
!
!  UPPER   (input) LOGICAL
!          = .TRUE.: the input matrices A and B are upper triangular.
!          = .FALSE.: the input matrices A and B are lower triangular.
!
!  A1      (input) DOUBLE PRECISION
!  A2      (input) DOUBLE PRECISION
!  A3      (input) DOUBLE PRECISION
!          On entry, A1, A2 and A3 are elements of the input 2-by-2
!          upper (lower) triangular matrix A.
!
!  B1      (input) DOUBLE PRECISION
!  B2      (input) DOUBLE PRECISION
!  B3      (input) DOUBLE PRECISION
!          On entry, B1, B2 and B3 are elements of the input 2-by-2
!          upper (lower) triangular matrix B.
!
!  CSU     (output) DOUBLE PRECISION
!  SNU     (output) DOUBLE PRECISION
!          The desired orthogonal matrix U.
!
!  CSV     (output) DOUBLE PRECISION
!  SNV     (output) DOUBLE PRECISION
!          The desired orthogonal matrix V.
!
!  CSQ     (output) DOUBLE PRECISION
!  SNQ     (output) DOUBLE PRECISION
!          The desired orthogonal matrix Q.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12, &
                         AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2, &
                         SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R, &
                         VB11, VB11R, VB12, VB21, VB22, VB22R
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARTG, DLASV2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      IF( UPPER ) THEN
!
!        Input matrices A and B are upper triangular matrices
!
!        Form matrix C = A*adj(B) = ( a b )
!                                   ( 0 d )
!
         A = A1*B3
         D = A3*B1
         B = A2*B1 - A1*B2
!
!        The SVD of real 2-by-2 triangular C
!
!         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
!         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
!
         CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
!
         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) ) &
              THEN
!
!           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
!           and (1,2) element of |U|'*|A| and |V|'*|B|.
!
            UA11R = CSL*A1
            UA12 = CSL*A2 + SNL*A3
!
            VB11R = CSR*B1
            VB12 = CSR*B2 + SNR*B3
!
            AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
            AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
!
!           zero (1,2) elements of U'*A and V'*B
!
            IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
               IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 / &
                   ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
                  CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
            END IF
!
            CSU = CSL
            SNU = -SNL
            CSV = CSR
            SNV = -SNR
!
         ELSE
!
!           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
!           and (2,2) element of |U|'*|A| and |V|'*|B|.
!
            UA21 = -SNL*A1
            UA22 = -SNL*A2 + CSL*A3
!
            VB21 = -SNR*B1
            VB22 = -SNR*B2 + CSR*B3
!
            AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
            AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
!
!           zero (2,2) elements of U'*A and V'*B, and then swap.
!
            IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
               IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 / &
                   ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
                  CALL DLARTG( -UA21, UA22, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
            END IF
!
            CSU = SNL
            SNU = CSL
            CSV = SNR
            SNV = CSR
!
         END IF
!
      ELSE
!
!        Input matrices A and B are lower triangular matrices
!
!        Form matrix C = A*adj(B) = ( a 0 )
!                                   ( c d )
!
         A = A1*B3
         D = A3*B1
         C = A2*B3 - A3*B2
!
!        The SVD of real 2-by-2 triangular C
!
!         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
!         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
!
         CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
!
         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) ) &
              THEN
!
!           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
!           and (2,1) element of |U|'*|A| and |V|'*|B|.
!
            UA21 = -SNR*A1 + CSR*A2
            UA22R = CSR*A3
!
            VB21 = -SNL*B1 + CSL*B2
            VB22R = CSL*B3
!
            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
!
!           zero (2,1) elements of U'*A and V'*B.
!
            IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
               IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 / &
                   ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
                  CALL DLARTG( UA22R, UA21, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
            END IF
!
            CSU = CSR
            SNU = -SNR
            CSV = CSL
            SNV = -SNL
!
         ELSE
!
!           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
!           and (1,1) element of |U|'*|A| and |V|'*|B|.
!
            UA11 = CSR*A1 + SNR*A2
            UA12 = SNR*A3
!
            VB11 = CSL*B1 + SNL*B2
            VB12 = SNL*B3
!
            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
!
!           zero (1,1) elements of U'*A and V'*B, and then swap.
!
            IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
               IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 / &
                   ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
                  CALL DLARTG( UA12, UA11, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
            END IF
!
            CSU = SNR
            SNU = CSR
            CSV = SNL
            SNV = CSL
!
         END IF
!
      END IF
!
      RETURN
!
!     End of DLAGS2
!
      END
      SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
      DOUBLE PRECISION   LAMBDA, TOL
!     ..
!     .. Array Arguments ..
      INTEGER            IN( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
!  tridiagonal matrix and lambda is a scalar, as
!
!     T - lambda*I = PLU,
!
!  where P is a permutation matrix, L is a unit lower tridiagonal matrix
!  with at most one non-zero sub-diagonal elements per column and U is
!  an upper triangular matrix with at most two non-zero super-diagonal
!  elements per column.
!
!  The factorization is obtained by Gaussian elimination with partial
!  pivoting and implicit row scaling.
!
!  The parameter LAMBDA is included in the routine so that DLAGTF may
!  be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
!  inverse iteration.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix T.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, A must contain the diagonal elements of T.
!
!          On exit, A is overwritten by the n diagonal elements of the
!          upper triangular matrix U of the factorization of T.
!
!  LAMBDA  (input) DOUBLE PRECISION
!          On entry, the scalar lambda.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, B must contain the (n-1) super-diagonal elements of
!          T.
!
!          On exit, B is overwritten by the (n-1) super-diagonal
!          elements of the matrix U of the factorization of T.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, C must contain the (n-1) sub-diagonal elements of
!          T.
!
!          On exit, C is overwritten by the (n-1) sub-diagonal elements
!          of the matrix L of the factorization of T.
!
!  TOL     (input) DOUBLE PRECISION
!          On entry, a relative tolerance used to indicate whether or
!          not the matrix (T - lambda*I) is nearly singular. TOL should
!          normally be chose as approximately the largest relative error
!          in the elements of T. For example, if the elements of T are
!          correct to about 4 significant figures, then TOL should be
!          set to about 5*10**(-4). If TOL is supplied as less than eps,
!          where eps is the relative machine precision, then the value
!          eps is used in place of TOL.
!
!  D       (output) DOUBLE PRECISION array, dimension (N-2)
!          On exit, D is overwritten by the (n-2) second super-diagonal
!          elements of the matrix U of the factorization of T.
!
!  IN      (output) INTEGER array, dimension (N)
!          On exit, IN contains details of the permutation matrix P. If
!          an interchange occurred at the kth step of the elimination,
!          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
!          returns the smallest positive integer j such that
!
!             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
!
!          where norm( A(j) ) denotes the sum of the absolute values of
!          the jth row of the matrix A. If no such j exists then IN(n)
!          is returned as zero. If IN(n) is returned as positive, then a
!          diagonal element of U is small, indicating that
!          (T - lambda*I) is singular or nearly singular,
!
!  INFO    (output) INTEGER
!          = 0   : successful exit
!          .lt. 0: if INFO = -k, the kth argument had an illegal value
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            K
      DOUBLE PRECISION   EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DLAGTF', -INFO )
         RETURN
      END IF
!
      IF( N.EQ.0 ) &
         RETURN
!
      A( 1 ) = A( 1 ) - LAMBDA
      IN( N ) = 0
      IF( N.EQ.1 ) THEN
         IF( A( 1 ).EQ.ZERO ) &
            IN( 1 ) = 1
         RETURN
      END IF
!
      EPS = DLAMCH( 'Epsilon' )
!
      TL = MAX( TOL, EPS )
      SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
      DO 10 K = 1, N - 1
         A( K+1 ) = A( K+1 ) - LAMBDA
         SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
         IF( K.LT.( N-1 ) ) &
            SCALE2 = SCALE2 + ABS( B( K+1 ) )
         IF( A( K ).EQ.ZERO ) THEN
            PIV1 = ZERO
         ELSE
            PIV1 = ABS( A( K ) ) / SCALE1
         END IF
         IF( C( K ).EQ.ZERO ) THEN
            IN( K ) = 0
            PIV2 = ZERO
            SCALE1 = SCALE2
            IF( K.LT.( N-1 ) ) &
               D( K ) = ZERO
         ELSE
            PIV2 = ABS( C( K ) ) / SCALE2
            IF( PIV2.LE.PIV1 ) THEN
               IN( K ) = 0
               SCALE1 = SCALE2
               C( K ) = C( K ) / A( K )
               A( K+1 ) = A( K+1 ) - C( K )*B( K )
               IF( K.LT.( N-1 ) ) &
                  D( K ) = ZERO
            ELSE
               IN( K ) = 1
               MULT = A( K ) / C( K )
               A( K ) = C( K )
               TEMP = A( K+1 )
               A( K+1 ) = B( K ) - MULT*TEMP
               IF( K.LT.( N-1 ) ) THEN
                  D( K ) = B( K+1 )
                  B( K+1 ) = -MULT*D( K )
               END IF
               B( K ) = TEMP
               C( K ) = MULT
            END IF
         END IF
         IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) &
            IN( N ) = K
   10 CONTINUE
      IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) &
         IN( N ) = N
!
      RETURN
!
!     End of DLAGTF
!
      END
      SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, &
                         B, LDB )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            LDB, LDX, N, NRHS
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAGTM performs a matrix-vector product of the form
!
!     B := alpha * A * X + beta * B
!
!  where A is a tridiagonal matrix of order N, B and X are N by NRHS
!  matrices, and alpha and beta are real scalars, each of which may be
!  0., 1., or -1.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER
!          Specifies the operation applied to A.
!          = 'N':  No transpose, B := alpha * A * X + beta * B
!          = 'T':  Transpose,    B := alpha * A'* X + beta * B
!          = 'C':  Conjugate transpose = Transpose
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices X and B.
!
!  ALPHA   (input) DOUBLE PRECISION
!          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
!          it is assumed to be 0.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) sub-diagonal elements of T.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of T.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) super-diagonal elements of T.
!
!  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          The N by NRHS matrix X.
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(N,1).
!
!  BETA    (input) DOUBLE PRECISION
!          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!          it is assumed to be 1.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N by NRHS matrix B.
!          On exit, B is overwritten by the matrix expression
!          B := alpha * A * X + beta * B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(N,1).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Multiply B by BETA if BETA.NE.1.
!
      IF( BETA.EQ.ZERO ) THEN
         DO 20 J = 1, NRHS
            DO 10 I = 1, N
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE IF( BETA.EQ.-ONE ) THEN
         DO 40 J = 1, NRHS
            DO 30 I = 1, N
               B( I, J ) = -B( I, J )
   30       CONTINUE
   40    CONTINUE
      END IF
!
      IF( ALPHA.EQ.ONE ) THEN
         IF( LSAME( TRANS, 'N' ) ) THEN
!
!           Compute B := B + A*X
!
            DO 60 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + &
                              DU( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + &
                              D( N )*X( N, J )
                  DO 50 I = 2, N - 1
                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + &
                                 D( I )*X( I, J ) + DU( I )*X( I+1, J )
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE
!
!           Compute B := B + A'*X
!
            DO 80 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + &
                              DL( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + &
                              D( N )*X( N, J )
                  DO 70 I = 2, N - 1
                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + &
                                 D( I )*X( I, J ) + DL( I )*X( I+1, J )
   70             CONTINUE
               END IF
   80       CONTINUE
         END IF
      ELSE IF( ALPHA.EQ.-ONE ) THEN
         IF( LSAME( TRANS, 'N' ) ) THEN
!
!           Compute B := B - A*X
!
            DO 100 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - &
                              DU( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - &
                              D( N )*X( N, J )
                  DO 90 I = 2, N - 1
                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - &
                                 D( I )*X( I, J ) - DU( I )*X( I+1, J )
   90             CONTINUE
               END IF
  100       CONTINUE
         ELSE
!
!           Compute B := B - A'*X
!
            DO 120 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - &
                              DL( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - &
                              D( N )*X( N, J )
                  DO 110 I = 2, N - 1
                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - &
                                 D( I )*X( I, J ) - DL( I )*X( I+1, J )
  110             CONTINUE
               END IF
  120       CONTINUE
         END IF
      END IF
      RETURN
!
!     End of DLAGTM
!
      END
      SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, JOB, N
      DOUBLE PRECISION   TOL
!     ..
!     .. Array Arguments ..
      INTEGER            IN( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAGTS may be used to solve one of the systems of equations
!
!     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,
!
!  where T is an n by n tridiagonal matrix, for x, following the
!  factorization of (T - lambda*I) as
!
!     (T - lambda*I) = P*L*U ,
!
!  by routine DLAGTF. The choice of equation to be solved is
!  controlled by the argument JOB, and in each case there is an option
!  to perturb zero or very small diagonal elements of U, this option
!  being intended for use in applications such as inverse iteration.
!
!  Arguments
!  =========
!
!  JOB     (input) INTEGER
!          Specifies the job to be performed by DLAGTS as follows:
!          =  1: The equations  (T - lambda*I)x = y  are to be solved,
!                but diagonal elements of U are not to be perturbed.
!          = -1: The equations  (T - lambda*I)x = y  are to be solved
!                and, if overflow would otherwise occur, the diagonal
!                elements of U are to be perturbed. See argument TOL
!                below.
!          =  2: The equations  (T - lambda*I)'x = y  are to be solved,
!                but diagonal elements of U are not to be perturbed.
!          = -2: The equations  (T - lambda*I)'x = y  are to be solved
!                and, if overflow would otherwise occur, the diagonal
!                elements of U are to be perturbed. See argument TOL
!                below.
!
!  N       (input) INTEGER
!          The order of the matrix T.
!
!  A       (input) DOUBLE PRECISION array, dimension (N)
!          On entry, A must contain the diagonal elements of U as
!          returned from DLAGTF.
!
!  B       (input) DOUBLE PRECISION array, dimension (N-1)
!          On entry, B must contain the first super-diagonal elements of
!          U as returned from DLAGTF.
!
!  C       (input) DOUBLE PRECISION array, dimension (N-1)
!          On entry, C must contain the sub-diagonal elements of L as
!          returned from DLAGTF.
!
!  D       (input) DOUBLE PRECISION array, dimension (N-2)
!          On entry, D must contain the second super-diagonal elements
!          of U as returned from DLAGTF.
!
!  IN      (input) INTEGER array, dimension (N)
!          On entry, IN must contain details of the matrix P as returned
!          from DLAGTF.
!
!  Y       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the right hand side vector y.
!          On exit, Y is overwritten by the solution vector x.
!
!  TOL     (input/output) DOUBLE PRECISION
!          On entry, with  JOB .lt. 0, TOL should be the minimum
!          perturbation to be made to very small diagonal elements of U.
!          TOL should normally be chosen as about eps*norm(U), where eps
!          is the relative machine precision, but if TOL is supplied as
!          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
!          If  JOB .gt. 0  then TOL is not referenced.
!
!          On exit, TOL is changed as described above, only if TOL is
!          non-positive on entry. Otherwise TOL is unchanged.
!
!  INFO    (output) INTEGER
!          = 0   : successful exit
!          .lt. 0: if INFO = -i, the i-th argument had an illegal value
!          .gt. 0: overflow would occur when computing the INFO(th)
!                  element of the solution vector x. This can only occur
!                  when JOB is supplied as positive and either means
!                  that a diagonal element of U is very small, or that
!                  the elements of the right-hand side vector y are very
!                  large.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            K
      DOUBLE PRECISION   ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAGTS', -INFO )
         RETURN
      END IF
!
      IF( N.EQ.0 ) &
         RETURN
!
      EPS = DLAMCH( 'Epsilon' )
      SFMIN = DLAMCH( 'Safe minimum' )
      BIGNUM = ONE / SFMIN
!
      IF( JOB.LT.0 ) THEN
         IF( TOL.LE.ZERO ) THEN
            TOL = ABS( A( 1 ) )
            IF( N.GT.1 ) &
               TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
            DO 10 K = 3, N
               TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), &
                     ABS( D( K-2 ) ) )
   10       CONTINUE
            TOL = TOL*EPS
            IF( TOL.EQ.ZERO ) &
               TOL = EPS
         END IF
      END IF
!
      IF( ABS( JOB ).EQ.1 ) THEN
         DO 20 K = 2, N
            IF( IN( K-1 ).EQ.0 ) THEN
               Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
            ELSE
               TEMP = Y( K-1 )
               Y( K-1 ) = Y( K )
               Y( K ) = TEMP - C( K-1 )*Y( K )
            END IF
   20    CONTINUE
         IF( JOB.EQ.1 ) THEN
            DO 30 K = N, 1, -1
               IF( K.LE.N-2 ) THEN
                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
               ELSE IF( K.EQ.N-1 ) THEN
                  TEMP = Y( K ) - B( K )*Y( K+1 )
               ELSE
                  TEMP = Y( K )
               END IF
               AK = A( K )
               ABSAK = ABS( AK )
               IF( ABSAK.LT.ONE ) THEN
                  IF( ABSAK.LT.SFMIN ) THEN
                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) &
                          THEN
                        INFO = K
                        RETURN
                     ELSE
                        TEMP = TEMP*BIGNUM
                        AK = AK*BIGNUM
                     END IF
                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
                     INFO = K
                     RETURN
                  END IF
               END IF
               Y( K ) = TEMP / AK
   30       CONTINUE
         ELSE
            DO 50 K = N, 1, -1
               IF( K.LE.N-2 ) THEN
                  TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
               ELSE IF( K.EQ.N-1 ) THEN
                  TEMP = Y( K ) - B( K )*Y( K+1 )
               ELSE
                  TEMP = Y( K )
               END IF
               AK = A( K )
               PERT = SIGN( TOL, AK )
   40          CONTINUE
               ABSAK = ABS( AK )
               IF( ABSAK.LT.ONE ) THEN
                  IF( ABSAK.LT.SFMIN ) THEN
                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) &
                          THEN
                        AK = AK + PERT
                        PERT = 2*PERT
                        GO TO 40
                     ELSE
                        TEMP = TEMP*BIGNUM
                        AK = AK*BIGNUM
                     END IF
                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
                     AK = AK + PERT
                     PERT = 2*PERT
                     GO TO 40
                  END IF
               END IF
               Y( K ) = TEMP / AK
   50       CONTINUE
         END IF
      ELSE
!
!        Come to here if  JOB = 2 or -2
!
         IF( JOB.EQ.2 ) THEN
            DO 60 K = 1, N
               IF( K.GE.3 ) THEN
                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
               ELSE IF( K.EQ.2 ) THEN
                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
               ELSE
                  TEMP = Y( K )
               END IF
               AK = A( K )
               ABSAK = ABS( AK )
               IF( ABSAK.LT.ONE ) THEN
                  IF( ABSAK.LT.SFMIN ) THEN
                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) &
                          THEN
                        INFO = K
                        RETURN
                     ELSE
                        TEMP = TEMP*BIGNUM
                        AK = AK*BIGNUM
                     END IF
                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
                     INFO = K
                     RETURN
                  END IF
               END IF
               Y( K ) = TEMP / AK
   60       CONTINUE
         ELSE
            DO 80 K = 1, N
               IF( K.GE.3 ) THEN
                  TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
               ELSE IF( K.EQ.2 ) THEN
                  TEMP = Y( K ) - B( K-1 )*Y( K-1 )
               ELSE
                  TEMP = Y( K )
               END IF
               AK = A( K )
               PERT = SIGN( TOL, AK )
   70          CONTINUE
               ABSAK = ABS( AK )
               IF( ABSAK.LT.ONE ) THEN
                  IF( ABSAK.LT.SFMIN ) THEN
                     IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) &
                          THEN
                        AK = AK + PERT
                        PERT = 2*PERT
                        GO TO 70
                     ELSE
                        TEMP = TEMP*BIGNUM
                        AK = AK*BIGNUM
                     END IF
                  ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
                     AK = AK + PERT
                     PERT = 2*PERT
                     GO TO 70
                  END IF
               END IF
               Y( K ) = TEMP / AK
   80       CONTINUE
         END IF
!
         DO 90 K = N, 2, -1
            IF( IN( K-1 ).EQ.0 ) THEN
               Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
            ELSE
               TEMP = Y( K-1 )
               Y( K-1 ) = Y( K )
               Y( K ) = TEMP - C( K-1 )*Y( K )
            END IF
   90    CONTINUE
      END IF
!
!     End of DLAGTS
!
      END
      SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, &
                         CSR, SNR )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            LDA, LDB
      DOUBLE PRECISION   CSL, CSR, SNL, SNR
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ), &
                         B( LDB, * ), BETA( 2 )
!     ..
!
!  Purpose
!  =======
!
!  DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
!  matrix pencil (A,B) where B is upper triangular. This routine
!  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
!  SNR such that
!
!  1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
!     types), then
!
!     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!
!     [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],
!
!  2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
!     then
!
!     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!
!     [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]
!
!     where b11 >= b22 > 0.
!
!
!  Arguments
!  =========
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
!          On entry, the 2 x 2 matrix A.
!          On exit, A is overwritten by the ``A-part'' of the
!          generalized Schur form.
!
!  LDA     (input) INTEGER
!          THe leading dimension of the array A.  LDA >= 2.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
!          On entry, the upper triangular 2 x 2 matrix B.
!          On exit, B is overwritten by the ``B-part'' of the
!          generalized Schur form.
!
!  LDB     (input) INTEGER
!          THe leading dimension of the array B.  LDB >= 2.
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
!  BETA    (output) DOUBLE PRECISION array, dimension (2)
!          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
!          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may
!          be zero.
!
!  CSL     (output) DOUBLE PRECISION
!          The cosine of the left rotation matrix.
!
!  SNL     (output) DOUBLE PRECISION
!          The sine of the left rotation matrix.
!
!  CSR     (output) DOUBLE PRECISION
!          The cosine of the right rotation matrix.
!
!  SNR     (output) DOUBLE PRECISION
!          The sine of the right rotation matrix.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ, &
                         R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1, &
                         WR2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAG2, DLARTG, DLASV2, DROT
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
      SAFMIN = DLAMCH( 'S' )
      ULP = DLAMCH( 'P' )
!
!     Scale A
!
      ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ), &
              ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
      ASCALE = ONE / ANORM
      A( 1, 1 ) = ASCALE*A( 1, 1 )
      A( 1, 2 ) = ASCALE*A( 1, 2 )
      A( 2, 1 ) = ASCALE*A( 2, 1 )
      A( 2, 2 ) = ASCALE*A( 2, 2 )
!
!     Scale B
!
      BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ), &
              SAFMIN )
      BSCALE = ONE / BNORM
      B( 1, 1 ) = BSCALE*B( 1, 1 )
      B( 1, 2 ) = BSCALE*B( 1, 2 )
      B( 2, 2 ) = BSCALE*B( 2, 2 )
!
!     Check if A can be deflated
!
      IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
         CSL = ONE
         SNL = ZERO
         CSR = ONE
         SNR = ZERO
         A( 2, 1 ) = ZERO
         B( 2, 1 ) = ZERO
!
!     Check if B is singular
!
      ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
         CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
         CSR = ONE
         SNR = ZERO
         CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
         CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
         A( 2, 1 ) = ZERO
         B( 1, 1 ) = ZERO
         B( 2, 1 ) = ZERO
!
      ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
         CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
         SNR = -SNR
         CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
         CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
         CSL = ONE
         SNL = ZERO
         A( 2, 1 ) = ZERO
         B( 2, 1 ) = ZERO
         B( 2, 2 ) = ZERO
!
      ELSE
!
!        B is nonsingular, first compute the eigenvalues of (A,B)
!
         CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, &
                     WI )
!
         IF( WI.EQ.ZERO ) THEN
!
!           two real eigenvalues, compute s*A-w*B
!
            H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
            H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
            H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
!
            RR = DLAPY2( H1, H2 )
            QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
!
            IF( RR.GT.QQ ) THEN
!
!              find right rotation matrix to zero 1,1 element of
!              (sA - wB)
!
               CALL DLARTG( H2, H1, CSR, SNR, T )
!
            ELSE
!
!              find right rotation matrix to zero 2,1 element of
!              (sA - wB)
!
               CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
!
            END IF
!
            SNR = -SNR
            CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
            CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
!
!           compute inf norms of A and B
!
            H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ), &
                 ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
            H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), &
                 ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
!
            IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
!
!              find left rotation matrix Q to zero out B(2,1)
!
               CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
!
            ELSE
!
!              find left rotation matrix Q to zero out A(2,1)
!
               CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
!
            END IF
!
            CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
            CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
!
            A( 2, 1 ) = ZERO
            B( 2, 1 ) = ZERO
!
         ELSE
!
!           a pair of complex conjugate eigenvalues
!           first compute the SVD of the matrix B
!
            CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR, &
                         CSR, SNL, CSL )
!
!           Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
!           Z is right rotation matrix computed from DLASV2
!
            CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
            CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
            CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
            CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
!
            B( 2, 1 ) = ZERO
            B( 1, 2 ) = ZERO
!
         END IF
!
      END IF
!
!     Unscaling
!
      A( 1, 1 ) = ANORM*A( 1, 1 )
      A( 2, 1 ) = ANORM*A( 2, 1 )
      A( 1, 2 ) = ANORM*A( 1, 2 )
      A( 2, 2 ) = ANORM*A( 2, 2 )
      B( 1, 1 ) = BNORM*B( 1, 1 )
      B( 2, 1 ) = BNORM*B( 2, 1 )
      B( 1, 2 ) = BNORM*B( 1, 2 )
      B( 2, 2 ) = BNORM*B( 2, 2 )
!
      IF( WI.EQ.ZERO ) THEN
         ALPHAR( 1 ) = A( 1, 1 )
         ALPHAR( 2 ) = A( 2, 2 )
         ALPHAI( 1 ) = ZERO
         ALPHAI( 2 ) = ZERO
         BETA( 1 ) = B( 1, 1 )
         BETA( 2 ) = B( 2, 2 )
      ELSE
         ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
         ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
         ALPHAR( 2 ) = ALPHAR( 1 )
         ALPHAI( 2 ) = -ALPHAI( 1 )
         BETA( 1 ) = ONE
         BETA( 2 ) = ONE
      END IF
!
   10 CONTINUE
!
      RETURN
!
!     End of DLAGV2
!
      END
      SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, &
                         ILOZ, IHIZ, Z, LDZ, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            WANTT, WANTZ
      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAHQR is an auxiliary routine called by DHSEQR to update the
!  eigenvalues and Schur decomposition already computed by DHSEQR, by
!  dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
!
!  Arguments
!  =========
!
!  WANTT   (input) LOGICAL
!          = .TRUE. : the full Schur form T is required;
!          = .FALSE.: only eigenvalues are required.
!
!  WANTZ   (input) LOGICAL
!          = .TRUE. : the matrix of Schur vectors Z is required;
!          = .FALSE.: Schur vectors are not required.
!
!  N       (input) INTEGER
!          The order of the matrix H.  N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          It is assumed that H is already upper quasi-triangular in
!          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
!          ILO = 1). DLAHQR works primarily with the Hessenberg
!          submatrix in rows and columns ILO to IHI, but applies
!          transformations to all of H if WANTT is .TRUE..
!          1 <= ILO <= max(1,IHI); IHI <= N.
!
!  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
!          On entry, the upper Hessenberg matrix H.
!          On exit, if WANTT is .TRUE., H is upper quasi-triangular in
!          rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
!          standard form. If WANTT is .FALSE., the contents of H are
!          unspecified on exit.
!
!  LDH     (input) INTEGER
!          The leading dimension of the array H. LDH >= max(1,N).
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          The real and imaginary parts, respectively, of the computed
!          eigenvalues ILO to IHI are stored in the corresponding
!          elements of WR and WI. If two eigenvalues are computed as a
!          complex conjugate pair, they are stored in consecutive
!          elements of WR and WI, say the i-th and (i+1)th, with
!          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
!          eigenvalues are stored in the same order as on the diagonal
!          of the Schur form returned in H, with WR(i) = H(i,i), and, if
!          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
!          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
!
!  ILOZ    (input) INTEGER
!  IHIZ    (input) INTEGER
!          Specify the rows of Z to which transformations must be
!          applied if WANTZ is .TRUE..
!          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          If WANTZ is .TRUE., on entry Z must contain the current
!          matrix Z of transformations accumulated by DHSEQR, and on
!          exit Z has been updated; transformations are applied only to
!          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
!          If WANTZ is .FALSE., Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z. LDZ >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
!               in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
!               elements i+1:ihi of WR and WI contain those eigenvalues
!               which have been successfully computed.
!
!  Further Details
!  ===============
!
!  2-96 Based on modifications by
!     David Day, Sandia National Laboratory, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D0 )
      DOUBLE PRECISION   DAT1, DAT2
      PARAMETER          ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
      DOUBLE PRECISION   AVE, CS, DISC, H00, H10, H11, H12, H21, H22, &
                         H33, H33S, H43H34, H44, H44S, OVFL, S, SMLNUM, &
                         SN, SUM, T1, T2, T3, TST1, ULP, UNFL, V1, V2, &
                         V3
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   V( 3 ), WORK( 1 )
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANHS
      EXTERNAL           DLAMCH, DLANHS
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLANV2, DLARFG, DROT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
      IF( ILO.EQ.IHI ) THEN
         WR( ILO ) = H( ILO, ILO )
         WI( ILO ) = ZERO
         RETURN
      END IF
!
      NH = IHI - ILO + 1
      NZ = IHIZ - ILOZ + 1
!
!     Set machine-dependent constants for the stopping criterion.
!     If norm(H) <= sqrt(OVFL), overflow should not occur.
!
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( NH / ULP )
!
!     I1 and I2 are the indices of the first row and last column of H
!     to which transformations must be applied. If eigenvalues only are
!     being computed, I1 and I2 are set inside the main loop.
!
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
!
!     ITN is the total number of QR iterations allowed.
!
      ITN = 30*NH
!
!     The main loop begins here. I is the loop index and decreases from
!     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
!     with the active submatrix in rows and columns L to I.
!     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
!     H(L,L-1) is negligible so that the matrix splits.
!
      I = IHI
   10 CONTINUE
      L = ILO
      IF( I.LT.ILO ) &
         GO TO 150
!
!     Perform QR iterations on rows and columns ILO to I until a
!     submatrix of order 1 or 2 splits off at the bottom because a
!     subdiagonal element has become negligible.
!
      DO 130 ITS = 0, ITN
!
!        Look for a single small subdiagonal element.
!
         DO 20 K = I, L + 1, -1
            TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
            IF( TST1.EQ.ZERO ) &
               TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
            IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) &
               GO TO 30
   20    CONTINUE
   30    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
!
!           H(L,L-1) is negligible
!
            H( L, L-1 ) = ZERO
         END IF
!
!        Exit from loop if a submatrix of order 1 or 2 has split off.
!
         IF( L.GE.I-1 ) &
            GO TO 140
!
!        Now the active submatrix is in rows and columns L to I. If
!        eigenvalues only are being computed, only the active submatrix
!        need be transformed.
!
         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
!
         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
!
!           Exceptional shift.
!
            S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
            H44 = DAT1*S + H( I, I )
            H33 = H44
            H43H34 = DAT2*S*S
         ELSE
!
!           Prepare to use Francis' double shift
!           (i.e. 2nd degree generalized Rayleigh quotient)
!
            H44 = H( I, I )
            H33 = H( I-1, I-1 )
            H43H34 = H( I, I-1 )*H( I-1, I )
            S = H( I-1, I-2 )*H( I-1, I-2 )
            DISC = ( H33-H44 )*HALF
            DISC = DISC*DISC + H43H34
            IF( DISC.GT.ZERO ) THEN
!
!              Real roots: use Wilkinson's shift twice
!
               DISC = SQRT( DISC )
               AVE = HALF*( H33+H44 )
               IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN
                  H33 = H33*H44 - H43H34
                  H44 = H33 / ( SIGN( DISC, AVE )+AVE )
               ELSE
                  H44 = SIGN( DISC, AVE ) + AVE
               END IF
               H33 = H44
               H43H34 = ZERO
            END IF
         END IF
!
!        Look for two consecutive small subdiagonal elements.
!
         DO 40 M = I - 2, L, -1
!           Determine the effect of starting the double-shift QR
!           iteration at row M, and see if this would make H(M,M-1)
!           negligible.
!
            H11 = H( M, M )
            H22 = H( M+1, M+1 )
            H21 = H( M+1, M )
            H12 = H( M, M+1 )
            H44S = H44 - H11
            H33S = H33 - H11
            V1 = ( H33S*H44S-H43H34 ) / H21 + H12
            V2 = H22 - H11 - H33S - H44S
            V3 = H( M+2, M+1 )
            S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
            V1 = V1 / S
            V2 = V2 / S
            V3 = V3 / S
            V( 1 ) = V1
            V( 2 ) = V2
            V( 3 ) = V3
            IF( M.EQ.L ) &
               GO TO 50
            H00 = H( M-1, M-1 )
            H10 = H( M, M-1 )
            TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
            IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) &
               GO TO 50
   40    CONTINUE
   50    CONTINUE
!
!        Double-shift QR step
!
         DO 120 K = M, I - 1
!
!           The first iteration of this loop determines a reflection G
!           from the vector V and applies it from left and right to H,
!           thus creating a nonzero bulge below the subdiagonal.
!
!           Each subsequent iteration determines a reflection G to
!           restore the Hessenberg form in the (K-1)th column, and thus
!           chases the bulge one step toward the bottom of the active
!           submatrix. NR is the order of G.
!
            NR = MIN( 3, I-K+1 )
            IF( K.GT.M ) &
               CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
            IF( K.GT.M ) THEN
               H( K, K-1 ) = V( 1 )
               H( K+1, K-1 ) = ZERO
               IF( K.LT.I-1 ) &
                  H( K+2, K-1 ) = ZERO
            ELSE IF( M.GT.L ) THEN
               H( K, K-1 ) = -H( K, K-1 )
            END IF
            V2 = V( 2 )
            T2 = T1*V2
            IF( NR.EQ.3 ) THEN
               V3 = V( 3 )
               T3 = T1*V3
!
!              Apply G from the left to transform the rows of the matrix
!              in columns K to I2.
!
               DO 60 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
                  H( K+2, J ) = H( K+2, J ) - SUM*T3
   60          CONTINUE
!
!              Apply G from the right to transform the columns of the
!              matrix in rows I1 to min(K+3,I).
!
               DO 70 J = I1, MIN( K+3, I )
                  SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
                  H( J, K+2 ) = H( J, K+2 ) - SUM*T3
   70          CONTINUE
!
               IF( WANTZ ) THEN
!
!                 Accumulate transformations in the matrix Z
!
                  DO 80 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
                     Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
   80             CONTINUE
               END IF
            ELSE IF( NR.EQ.2 ) THEN
!
!              Apply G from the left to transform the rows of the matrix
!              in columns K to I2.
!
               DO 90 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
   90          CONTINUE
!
!              Apply G from the right to transform the columns of the
!              matrix in rows I1 to min(K+3,I).
!
               DO 100 J = I1, I
                  SUM = H( J, K ) + V2*H( J, K+1 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
  100          CONTINUE
!
               IF( WANTZ ) THEN
!
!                 Accumulate transformations in the matrix Z
!
                  DO 110 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
  110             CONTINUE
               END IF
            END IF
  120    CONTINUE
!
  130 CONTINUE
!
!     Failure to converge in remaining number of iterations
!
      INFO = I
      RETURN
!
  140 CONTINUE
!
      IF( L.EQ.I ) THEN
!
!        H(I,I-1) is negligible: one eigenvalue has converged.
!
         WR( I ) = H( I, I )
         WI( I ) = ZERO
      ELSE IF( L.EQ.I-1 ) THEN
!
!        H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
!
!        Transform the 2-by-2 submatrix to standard Schur form,
!        and compute and store the eigenvalues.
!
         CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), &
                      H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), &
                      CS, SN )
!
         IF( WANTT ) THEN
!
!           Apply the transformation to the rest of H.
!
            IF( I2.GT.I ) &
               CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, &
                          CS, SN )
            CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
         END IF
         IF( WANTZ ) THEN
!
!           Apply the transformation to Z.
!
            CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
         END IF
      END IF
!
!     Decrement number of remaining iterations, and return to start of
!     the main loop with new value of I.
!
      ITN = ITN - ITS
      I = L - 1
      GO TO 10
!
  150 CONTINUE
      RETURN
!
!     End of DLAHQR
!
      END
      SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            K, LDA, LDT, LDY, N, NB
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), T( LDT, NB ), TAU( NB ), &
                         Y( LDY, NB )
!     ..
!
!  Purpose
!  =======
!
!  DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
!  matrix A so that elements below the k-th subdiagonal are zero. The
!  reduction is performed by an orthogonal similarity transformation
!  Q' * A * Q. The routine returns the matrices V and T which determine
!  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
!
!  This is an auxiliary routine called by DGEHRD.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  K       (input) INTEGER
!          The offset for the reduction. Elements below the k-th
!          subdiagonal in the first NB columns are reduced to zero.
!
!  NB      (input) INTEGER
!          The number of columns to be reduced.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
!          On entry, the n-by-(n-k+1) general matrix A.
!          On exit, the elements on and above the k-th subdiagonal in
!          the first NB columns are overwritten with the corresponding
!          elements of the reduced matrix; the elements below the k-th
!          subdiagonal, with the array TAU, represent the matrix Q as a
!          product of elementary reflectors. The other columns of A are
!          unchanged. See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (NB)
!          The scalar factors of the elementary reflectors. See Further
!          Details.
!
!  T       (output) DOUBLE PRECISION array, dimension (LDT,NB)
!          The upper triangular matrix T.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T.  LDT >= NB.
!
!  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
!          The n-by-nb matrix Y.
!
!  LDY     (input) INTEGER
!          The leading dimension of the array Y. LDY >= N.
!
!  Further Details
!  ===============
!
!  The matrix Q is represented as a product of nb elementary reflectors
!
!     Q = H(1) H(2) . . . H(nb).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
!  A(i+k+1:n,i), and tau in TAU(i).
!
!  The elements of the vectors v together form the (n-k+1)-by-nb matrix
!  V which is needed, with T and Y, to apply the transformation to the
!  unreduced part of the matrix, using an update of the form:
!  A := (I - V*T*V') * (A - Y*V').
!
!  The contents of A on exit are illustrated by the following example
!  with n = 7, k = 3 and nb = 2:
!
!     ( a   h   a   a   a )
!     ( a   h   a   a   a )
!     ( a   h   a   a   a )
!     ( h   h   a   a   a )
!     ( v1  h   a   a   a )
!     ( v1  v2  a   a   a )
!     ( v1  v2  a   a   a )
!
!  where a denotes an element of the original matrix A, h denotes a
!  modified element of the upper Hessenberg matrix H, and vi denotes an
!  element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   EI
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.1 ) &
         RETURN
!
      DO 10 I = 1, NB
         IF( I.GT.1 ) THEN
!
!           Update A(1:n,i)
!
!           Compute i-th column of A - Y * V'
!
            CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, &
                        A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
!
!           Apply I - V * T' * V' to this column (call it b) from the
!           left, using the last column of T as workspace
!
!           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
!                    ( V2 )             ( b2 )
!
!           where V1 is unit lower triangular
!
!           w := V1' * b1
!
            CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
            CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ), &
                        LDA, T( 1, NB ), 1 )
!
!           w := w + V2'*b2
!
            CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), &
                        LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
!
!           w := T'*w
!
            CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT, &
                        T( 1, NB ), 1 )
!
!           b2 := b2 - V2*w
!
            CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ), &
                        LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
!
!           b1 := b1 - V1*w
!
            CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1, &
                        A( K+1, 1 ), LDA, T( 1, NB ), 1 )
            CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
!
            A( K+I-1, I-1 ) = EI
         END IF
!
!        Generate the elementary reflector H(i) to annihilate
!        A(k+i+1:n,i)
!
         CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, &
                      TAU( I ) )
         EI = A( K+I, I )
         A( K+I, I ) = ONE
!
!        Compute  Y(1:n,i)
!
         CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA, &
                     A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
         CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA, &
                     A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
         CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1, &
                     ONE, Y( 1, I ), 1 )
         CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 )
!
!        Compute T(1:i,i)
!
         CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT, &
                     T( 1, I ), 1 )
         T( I, I ) = TAU( I )
!
   10 CONTINUE
      A( K+NB, NB ) = EI
!
      RETURN
!
!     End of DLAHRD
!
      END
      SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            J, JOB
      DOUBLE PRECISION   C, GAMMA, S, SEST, SESTPR
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   W( J ), X( J )
!     ..
!
!  Purpose
!  =======
!
!  DLAIC1 applies one step of incremental condition estimation in
!  its simplest version:
!
!  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
!  lower triangular matrix L, such that
!           twonorm(L*x) = sest
!  Then DLAIC1 computes sestpr, s, c such that
!  the vector
!                  [ s*x ]
!           xhat = [  c  ]
!  is an approximate singular vector of
!                  [ L     0  ]
!           Lhat = [ w' gamma ]
!  in the sense that
!           twonorm(Lhat*xhat) = sestpr.
!
!  Depending on JOB, an estimate for the largest or smallest singular
!  value is computed.
!
!  Note that [s c]' and sestpr**2 is an eigenpair of the system
!
!      diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]
!                                            [ gamma ]
!
!  where  alpha =  x'*w.
!
!  Arguments
!  =========
!
!  JOB     (input) INTEGER
!          = 1: an estimate for the largest singular value is computed.
!          = 2: an estimate for the smallest singular value is computed.
!
!  J       (input) INTEGER
!          Length of X and W
!
!  X       (input) DOUBLE PRECISION array, dimension (J)
!          The j-vector x.
!
!  SEST    (input) DOUBLE PRECISION
!          Estimated singular value of j by j matrix L
!
!  W       (input) DOUBLE PRECISION array, dimension (J)
!          The j-vector w.
!
!  GAMMA   (input) DOUBLE PRECISION
!          The diagonal element gamma.
!
!  SEDTPR  (output) DOUBLE PRECISION
!          Estimated singular value of (j+1) by (j+1) matrix Lhat.
!
!  S       (output) DOUBLE PRECISION
!          Sine needed in forming xhat.
!
!  C       (output) DOUBLE PRECISION
!          Cosine needed in forming xhat.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      DOUBLE PRECISION   HALF, FOUR
      PARAMETER          ( HALF = 0.5D0, FOUR = 4.0D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS, &
                         NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           DDOT, DLAMCH
!     ..
!     .. Executable Statements ..
!
      EPS = DLAMCH( 'Epsilon' )
      ALPHA = DDOT( J, X, 1, W, 1 )
!
      ABSALP = ABS( ALPHA )
      ABSGAM = ABS( GAMMA )
      ABSEST = ABS( SEST )
!
      IF( JOB.EQ.1 ) THEN
!
!        Estimating largest singular value
!
!        special cases
!
         IF( SEST.EQ.ZERO ) THEN
            S1 = MAX( ABSGAM, ABSALP )
            IF( S1.EQ.ZERO ) THEN
               S = ZERO
               C = ONE
               SESTPR = ZERO
            ELSE
               S = ALPHA / S1
               C = GAMMA / S1
               TMP = SQRT( S*S+C*C )
               S = S / TMP
               C = C / TMP
               SESTPR = S1*TMP
            END IF
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ONE
            C = ZERO
            TMP = MAX( ABSEST, ABSALP )
            S1 = ABSEST / TMP
            S2 = ABSALP / TMP
            SESTPR = TMP*SQRT( S1*S1+S2*S2 )
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ONE
               C = ZERO
               SESTPR = S2
            ELSE
               S = ZERO
               C = ONE
               SESTPR = S1
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               S = SQRT( ONE+TMP*TMP )
               SESTPR = S2*S
               C = ( GAMMA / S2 ) / S
               S = SIGN( ONE, ALPHA ) / S
            ELSE
               TMP = S2 / S1
               C = SQRT( ONE+TMP*TMP )
               SESTPR = S1*C
               S = ( ALPHA / S1 ) / C
               C = SIGN( ONE, GAMMA ) / C
            END IF
            RETURN
         ELSE
!
!           normal case
!
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
!
            B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
            C = ZETA1*ZETA1
            IF( B.GT.ZERO ) THEN
               T = C / ( B+SQRT( B*B+C ) )
            ELSE
               T = SQRT( B*B+C ) - B
            END IF
!
            SINE = -ZETA1 / T
            COSINE = -ZETA2 / ( ONE+T )
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            SESTPR = SQRT( T+ONE )*ABSEST
            RETURN
         END IF
!
      ELSE IF( JOB.EQ.2 ) THEN
!
!        Estimating smallest singular value
!
!        special cases
!
         IF( SEST.EQ.ZERO ) THEN
            SESTPR = ZERO
            IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
               SINE = ONE
               COSINE = ZERO
            ELSE
               SINE = -GAMMA
               COSINE = ALPHA
            END IF
            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
            S = SINE / S1
            C = COSINE / S1
            TMP = SQRT( S*S+C*C )
            S = S / TMP
            C = C / TMP
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ZERO
            C = ONE
            SESTPR = ABSGAM
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ZERO
               C = ONE
               SESTPR = S1
            ELSE
               S = ONE
               C = ZERO
               SESTPR = S2
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               C = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST*( TMP / C )
               S = -( GAMMA / S2 ) / C
               C = SIGN( ONE, ALPHA ) / C
            ELSE
               TMP = S2 / S1
               S = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST / S
               C = ( ALPHA / S1 ) / S
               S = -SIGN( ONE, GAMMA ) / S
            END IF
            RETURN
         ELSE
!
!           normal case
!
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
!
            NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ), &
                    ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
!
!           See if root is closer to zero or to ONE
!
            TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
            IF( TEST.GE.ZERO ) THEN
!
!              root is close to zero, compute directly
!
               B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
               C = ZETA2*ZETA2
               T = C / ( B+SQRT( ABS( B*B-C ) ) )
               SINE = ZETA1 / ( ONE-T )
               COSINE = -ZETA2 / T
               SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
            ELSE
!
!              root is closer to ONE, shift by that amount
!
               B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
               C = ZETA1*ZETA1
               IF( B.GE.ZERO ) THEN
                  T = -C / ( B+SQRT( B*B+C ) )
               ELSE
                  T = B - SQRT( B*B+C )
               END IF
               SINE = -ZETA1 / T
               COSINE = -ZETA2 / ( ONE+T )
               SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
            END IF
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            RETURN
!
         END IF
      END IF
      RETURN
!
!     End of DLAIC1
!
      END
      SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, &
                         LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            LTRANS
      INTEGER            INFO, LDA, LDB, LDX, NA, NW
      DOUBLE PRECISION   CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DLALN2 solves a system of the form  (ca A - w D ) X = s B
!  or (ca A' - w D) X = s B   with possible scaling ("s") and
!  perturbation of A.  (A' means A-transpose.)
!
!  A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!  real diagonal matrix, w is a real or complex value, and X and B are
!  NA x 1 matrices -- real if w is real, complex if w is complex.  NA
!  may be 1 or 2.
!
!  If w is complex, X and B are represented as NA x 2 matrices,
!  the first column of each being the real part and the second
!  being the imaginary part.
!
!  "s" is a scaling factor (.LE. 1), computed by DLALN2, which is
!  so chosen that X can be computed without overflow.  X is further
!  scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!  than overflow.
!
!  If both singular values of (ca A - w D) are less than SMIN,
!  SMIN*identity will be used instead of (ca A - w D).  If only one
!  singular value is less than SMIN, one element of (ca A - w D) will be
!  perturbed enough to make the smallest singular value roughly SMIN.
!  If both singular values are at least SMIN, (ca A - w D) will not be
!  perturbed.  In any case, the perturbation will be at most some small
!  multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values
!  are computed by infinity-norm approximations, and thus will only be
!  correct to a factor of 2 or so.
!
!  Note: all input quantities are assumed to be smaller than overflow
!  by a reasonable factor.  (See BIGNUM.)
!
!  Arguments
!  ==========
!
!  LTRANS  (input) LOGICAL
!          =.TRUE.:  A-transpose will be used.
!          =.FALSE.: A will be used (not transposed.)
!
!  NA      (input) INTEGER
!          The size of the matrix A.  It may (only) be 1 or 2.
!
!  NW      (input) INTEGER
!          1 if "w" is real, 2 if "w" is complex.  It may only be 1
!          or 2.
!
!  SMIN    (input) DOUBLE PRECISION
!          The desired lower bound on the singular values of A.  This
!          should be a safe distance away from underflow or overflow,
!          say, between (underflow/machine precision) and  (machine
!          precision * overflow ).  (See BIGNUM and ULP.)
!
!  CA      (input) DOUBLE PRECISION
!          The coefficient c, which A is multiplied by.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,NA)
!          The NA x NA matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of A.  It must be at least NA.
!
!  D1      (input) DOUBLE PRECISION
!          The 1,1 element in the diagonal matrix D.
!
!  D2      (input) DOUBLE PRECISION
!          The 2,2 element in the diagonal matrix D.  Not used if NW=1.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NW)
!          The NA x NW matrix B (right-hand side).  If NW=2 ("w" is
!          complex), column 1 contains the real part of B and column 2
!          contains the imaginary part.
!
!  LDB     (input) INTEGER
!          The leading dimension of B.  It must be at least NA.
!
!  WR      (input) DOUBLE PRECISION
!          The real part of the scalar "w".
!
!  WI      (input) DOUBLE PRECISION
!          The imaginary part of the scalar "w".  Not used if NW=1.
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NW)
!          The NA x NW matrix X (unknowns), as computed by DLALN2.
!          If NW=2 ("w" is complex), on exit, column 1 will contain
!          the real part of X and column 2 will contain the imaginary
!          part.
!
!  LDX     (input) INTEGER
!          The leading dimension of X.  It must be at least NA.
!
!  SCALE   (output) DOUBLE PRECISION
!          The scale factor that B must be multiplied by to insure
!          that overflow does not occur when computing X.  Thus,
!          (ca A - w D) X  will be SCALE*B, not B (ignoring
!          perturbations of A.)  It will be at most 1.
!
!  XNORM   (output) DOUBLE PRECISION
!          The infinity-norm of X, when X is regarded as an NA x NW
!          real matrix.
!
!  INFO    (output) INTEGER
!          An error flag.  It will be set to zero if no error occurs,
!          a negative number if an argument is in error, or a positive
!          number if  ca A - w D  had to be perturbed.
!          The possible values are:
!          = 0: No error occurred, and (ca A - w D) did not have to be
!                 perturbed.
!          = 1: (ca A - w D) had to be perturbed to make its smallest
!               (or only) singular value greater than SMIN.
!          NOTE: In the interests of speed, this routine does not
!                check the inputs for errors.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            ICMAX, J
      DOUBLE PRECISION   BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, &
                         CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, &
                         LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, &
                         UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, &
                         UR22, XI1, XI2, XR1, XR2
!     ..
!     .. Local Arrays ..
      LOGICAL            RSWAP( 4 ), ZSWAP( 4 )
      INTEGER            IPIVOT( 4, 4 )
      DOUBLE PRECISION   CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLADIV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Equivalences ..
      EQUIVALENCE        ( CI( 1, 1 ), CIV( 1 ) ), &
                         ( CR( 1, 1 ), CRV( 1 ) )
!     ..
!     .. Data statements ..
      DATA               ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
      DATA               RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
      DATA               IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, &
                         3, 2, 1 /
!     ..
!     .. Executable Statements ..
!
!     Compute BIGNUM
!
      SMLNUM = TWO*DLAMCH( 'Safe minimum' )
      BIGNUM = ONE / SMLNUM
      SMINI = MAX( SMIN, SMLNUM )
!
!     Don't check for input errors
!
      INFO = 0
!
!     Standard Initializations
!
      SCALE = ONE
!
      IF( NA.EQ.1 ) THEN
!
!        1 x 1  (i.e., scalar) system   C X = B
!
         IF( NW.EQ.1 ) THEN
!
!           Real 1x1 system.
!
!           C = ca A - w D
!
            CSR = CA*A( 1, 1 ) - WR*D1
            CNORM = ABS( CSR )
!
!           If | C | < SMINI, use C = SMINI
!
            IF( CNORM.LT.SMINI ) THEN
               CSR = SMINI
               CNORM = SMINI
               INFO = 1
            END IF
!
!           Check scaling for  X = B / C
!
            BNORM = ABS( B( 1, 1 ) )
            IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
               IF( BNORM.GT.BIGNUM*CNORM ) &
                  SCALE = ONE / BNORM
            END IF
!
!           Compute X
!
            X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
            XNORM = ABS( X( 1, 1 ) )
         ELSE
!
!           Complex 1x1 system (w is complex)
!
!           C = ca A - w D
!
            CSR = CA*A( 1, 1 ) - WR*D1
            CSI = -WI*D1
            CNORM = ABS( CSR ) + ABS( CSI )
!
!           If | C | < SMINI, use C = SMINI
!
            IF( CNORM.LT.SMINI ) THEN
               CSR = SMINI
               CSI = ZERO
               CNORM = SMINI
               INFO = 1
            END IF
!
!           Check scaling for  X = B / C
!
            BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
            IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
               IF( BNORM.GT.BIGNUM*CNORM ) &
                  SCALE = ONE / BNORM
            END IF
!
!           Compute X
!
            CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, &
                         X( 1, 1 ), X( 1, 2 ) )
            XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
         END IF
!
      ELSE
!
!        2x2 System
!
!        Compute the real part of  C = ca A - w D  (or  ca A' - w D )
!
         CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
         CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
         IF( LTRANS ) THEN
            CR( 1, 2 ) = CA*A( 2, 1 )
            CR( 2, 1 ) = CA*A( 1, 2 )
         ELSE
            CR( 2, 1 ) = CA*A( 2, 1 )
            CR( 1, 2 ) = CA*A( 1, 2 )
         END IF
!
         IF( NW.EQ.1 ) THEN
!
!           Real 2x2 system  (w is real)
!
!           Find the largest element in C
!
            CMAX = ZERO
            ICMAX = 0
!
            DO 10 J = 1, 4
               IF( ABS( CRV( J ) ).GT.CMAX ) THEN
                  CMAX = ABS( CRV( J ) )
                  ICMAX = J
               END IF
   10       CONTINUE
!
!           If norm(C) < SMINI, use SMINI*identity.
!
            IF( CMAX.LT.SMINI ) THEN
               BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
               IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
                  IF( BNORM.GT.BIGNUM*SMINI ) &
                     SCALE = ONE / BNORM
               END IF
               TEMP = SCALE / SMINI
               X( 1, 1 ) = TEMP*B( 1, 1 )
               X( 2, 1 ) = TEMP*B( 2, 1 )
               XNORM = TEMP*BNORM
               INFO = 1
               RETURN
            END IF
!
!           Gaussian elimination with complete pivoting.
!
            UR11 = CRV( ICMAX )
            CR21 = CRV( IPIVOT( 2, ICMAX ) )
            UR12 = CRV( IPIVOT( 3, ICMAX ) )
            CR22 = CRV( IPIVOT( 4, ICMAX ) )
            UR11R = ONE / UR11
            LR21 = UR11R*CR21
            UR22 = CR22 - UR12*LR21
!
!           If smaller pivot < SMINI, use SMINI
!
            IF( ABS( UR22 ).LT.SMINI ) THEN
               UR22 = SMINI
               INFO = 1
            END IF
            IF( RSWAP( ICMAX ) ) THEN
               BR1 = B( 2, 1 )
               BR2 = B( 1, 1 )
            ELSE
               BR1 = B( 1, 1 )
               BR2 = B( 2, 1 )
            END IF
            BR2 = BR2 - LR21*BR1
            BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
            IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
               IF( BBND.GE.BIGNUM*ABS( UR22 ) ) &
                  SCALE = ONE / BBND
            END IF
!
            XR2 = ( BR2*SCALE ) / UR22
            XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
            IF( ZSWAP( ICMAX ) ) THEN
               X( 1, 1 ) = XR2
               X( 2, 1 ) = XR1
            ELSE
               X( 1, 1 ) = XR1
               X( 2, 1 ) = XR2
            END IF
            XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
!
!           Further scaling if  norm(A) norm(X) > overflow
!
            IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
               IF( XNORM.GT.BIGNUM / CMAX ) THEN
                  TEMP = CMAX / BIGNUM
                  X( 1, 1 ) = TEMP*X( 1, 1 )
                  X( 2, 1 ) = TEMP*X( 2, 1 )
                  XNORM = TEMP*XNORM
                  SCALE = TEMP*SCALE
               END IF
            END IF
         ELSE
!
!           Complex 2x2 system  (w is complex)
!
!           Find the largest element in C
!
            CI( 1, 1 ) = -WI*D1
            CI( 2, 1 ) = ZERO
            CI( 1, 2 ) = ZERO
            CI( 2, 2 ) = -WI*D2
            CMAX = ZERO
            ICMAX = 0
!
            DO 20 J = 1, 4
               IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
                  CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
                  ICMAX = J
               END IF
   20       CONTINUE
!
!           If norm(C) < SMINI, use SMINI*identity.
!
            IF( CMAX.LT.SMINI ) THEN
               BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), &
                       ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
               IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
                  IF( BNORM.GT.BIGNUM*SMINI ) &
                     SCALE = ONE / BNORM
               END IF
               TEMP = SCALE / SMINI
               X( 1, 1 ) = TEMP*B( 1, 1 )
               X( 2, 1 ) = TEMP*B( 2, 1 )
               X( 1, 2 ) = TEMP*B( 1, 2 )
               X( 2, 2 ) = TEMP*B( 2, 2 )
               XNORM = TEMP*BNORM
               INFO = 1
               RETURN
            END IF
!
!           Gaussian elimination with complete pivoting.
!
            UR11 = CRV( ICMAX )
            UI11 = CIV( ICMAX )
            CR21 = CRV( IPIVOT( 2, ICMAX ) )
            CI21 = CIV( IPIVOT( 2, ICMAX ) )
            UR12 = CRV( IPIVOT( 3, ICMAX ) )
            UI12 = CIV( IPIVOT( 3, ICMAX ) )
            CR22 = CRV( IPIVOT( 4, ICMAX ) )
            CI22 = CIV( IPIVOT( 4, ICMAX ) )
            IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
!
!              Code when off-diagonals of pivoted C are real
!
               IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
                  TEMP = UI11 / UR11
                  UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
                  UI11R = -TEMP*UR11R
               ELSE
                  TEMP = UR11 / UI11
                  UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
                  UR11R = -TEMP*UI11R
               END IF
               LR21 = CR21*UR11R
               LI21 = CR21*UI11R
               UR12S = UR12*UR11R
               UI12S = UR12*UI11R
               UR22 = CR22 - UR12*LR21
               UI22 = CI22 - UR12*LI21
            ELSE
!
!              Code when diagonals of pivoted C are real
!
               UR11R = ONE / UR11
               UI11R = ZERO
               LR21 = CR21*UR11R
               LI21 = CI21*UR11R
               UR12S = UR12*UR11R
               UI12S = UI12*UR11R
               UR22 = CR22 - UR12*LR21 + UI12*LI21
               UI22 = -UR12*LI21 - UI12*LR21
            END IF
            U22ABS = ABS( UR22 ) + ABS( UI22 )
!
!           If smaller pivot < SMINI, use SMINI
!
            IF( U22ABS.LT.SMINI ) THEN
               UR22 = SMINI
               UI22 = ZERO
               INFO = 1
            END IF
            IF( RSWAP( ICMAX ) ) THEN
               BR2 = B( 1, 1 )
               BR1 = B( 2, 1 )
               BI2 = B( 1, 2 )
               BI1 = B( 2, 2 )
            ELSE
               BR1 = B( 1, 1 )
               BR2 = B( 2, 1 )
               BI1 = B( 1, 2 )
               BI2 = B( 2, 2 )
            END IF
            BR2 = BR2 - LR21*BR1 + LI21*BI1
            BI2 = BI2 - LI21*BR1 - LR21*BI1
            BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* &
                   ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), &
                   ABS( BR2 )+ABS( BI2 ) )
            IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
               IF( BBND.GE.BIGNUM*U22ABS ) THEN
                  SCALE = ONE / BBND
                  BR1 = SCALE*BR1
                  BI1 = SCALE*BI1
                  BR2 = SCALE*BR2
                  BI2 = SCALE*BI2
               END IF
            END IF
!
            CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
            XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
            XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
            IF( ZSWAP( ICMAX ) ) THEN
               X( 1, 1 ) = XR2
               X( 2, 1 ) = XR1
               X( 1, 2 ) = XI2
               X( 2, 2 ) = XI1
            ELSE
               X( 1, 1 ) = XR1
               X( 2, 1 ) = XR2
               X( 1, 2 ) = XI1
               X( 2, 2 ) = XI2
            END IF
            XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
!
!           Further scaling if  norm(A) norm(X) > overflow
!
            IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
               IF( XNORM.GT.BIGNUM / CMAX ) THEN
                  TEMP = CMAX / BIGNUM
                  X( 1, 1 ) = TEMP*X( 1, 1 )
                  X( 2, 1 ) = TEMP*X( 2, 1 )
                  X( 1, 2 ) = TEMP*X( 1, 2 )
                  X( 2, 2 ) = TEMP*X( 2, 2 )
                  XNORM = TEMP*XNORM
                  SCALE = TEMP*SCALE
               END IF
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DLALN2
!
      END
      SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, &
                         PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, &
                         POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     December 1, 1999
!
!     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, &
                         LDGNUM, NL, NR, NRHS, SQRE
      DOUBLE PRECISION   C, S
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), DIFL( * ), &
                         DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ), &
                         POLES( LDGNUM, * ), WORK( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLALS0 applies back the multiplying factors of either the left or the
!  right singular vector matrix of a diagonal matrix appended by a row
!  to the right hand side matrix B in solving the least squares problem
!  using the divide-and-conquer SVD approach.
!
!  For the left singular vector matrix, three types of orthogonal
!  matrices are involved:
!
!  (1L) Givens rotations: the number of such rotations is GIVPTR; the
!       pairs of columns/rows they were applied to are stored in GIVCOL;
!       and the C- and S-values of these rotations are stored in GIVNUM.
!
!  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
!       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
!       J-th row.
!
!  (3L) The left singular vector matrix of the remaining matrix.
!
!  For the right singular vector matrix, four types of orthogonal
!  matrices are involved:
!
!  (1R) The right singular vector matrix of the remaining matrix.
!
!  (2R) If SQRE = 1, one extra Givens rotation to generate the right
!       null space.
!
!  (3R) The inverse transformation of (2L).
!
!  (4R) The inverse transformation of (1L).
!
!  Arguments
!  =========
!
!  ICOMPQ (input) INTEGER
!         Specifies whether singular vectors are to be computed in
!         factored form:
!         = 0: Left singular vector matrix.
!         = 1: Right singular vector matrix.
!
!  NL     (input) INTEGER
!         The row dimension of the upper block. NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block. NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has row dimension N = NL + NR + 1,
!         and column dimension M = N + SQRE.
!
!  NRHS   (input) INTEGER
!         The number of columns of B and BX. NRHS must be at least 1.
!
!  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
!         On input, B contains the right hand sides of the least
!         squares problem in rows 1 through M. On output, B contains
!         the solution X in rows 1 through N.
!
!  LDB    (input) INTEGER
!         The leading dimension of B. LDB must be at least
!         max(1,MAX( M, N ) ).
!
!  BX     (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
!
!  LDBX   (input) INTEGER
!         The leading dimension of BX.
!
!  PERM   (input) INTEGER array, dimension ( N )
!         The permutations (from deflation and sorting) applied
!         to the two blocks.
!
!  GIVPTR (input) INTEGER
!         The number of Givens rotations which took place in this
!         subproblem.
!
!  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
!         Each pair of numbers indicates a pair of rows/columns
!         involved in a Givens rotation.
!
!  LDGCOL (input) INTEGER
!         The leading dimension of GIVCOL, must be at least N.
!
!  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!         Each number indicates the C or S value used in the
!         corresponding Givens rotation.
!
!  LDGNUM (input) INTEGER
!         The leading dimension of arrays DIFR, POLES and
!         GIVNUM, must be at least K.
!
!  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!         On entry, POLES(1:K, 1) contains the new singular
!         values obtained from solving the secular equation, and
!         POLES(1:K, 2) is an array containing the poles in the secular
!         equation.
!
!  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).
!         On entry, DIFL(I) is the distance between I-th updated
!         (undeflated) singular value and the I-th (undeflated) old
!         singular value.
!
!  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
!         On entry, DIFR(I, 1) contains the distances between I-th
!         updated (undeflated) singular value and the I+1-th
!         (undeflated) old singular value. And DIFR(I, 2) is the
!         normalizing factor for the I-th right singular vector.
!
!  Z      (input) DOUBLE PRECISION array, dimension ( K )
!         Contain the components of the deflation-adjusted updating row
!         vector.
!
!  K      (input) INTEGER
!         Contains the dimension of the non-deflated matrix,
!         This is the order of the related secular equation. 1 <= K <=N.
!
!  C      (input) DOUBLE PRECISION
!         C contains garbage if SQRE =0 and the C-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  S      (input) DOUBLE PRECISION
!         S contains garbage if SQRE =0 and the S-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension ( K )
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!       California at Berkeley, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, NEGONE
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, M, N, NLP1
      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL, &
                         XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3, DNRM2
      EXTERNAL           DLAMC3, DNRM2
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( NL.LT.1 ) THEN
         INFO = -2
      ELSE IF( NR.LT.1 ) THEN
         INFO = -3
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -4
      END IF
!
      N = NL + NR + 1
!
      IF( NRHS.LT.1 ) THEN
         INFO = -5
      ELSE IF( LDB.LT.N ) THEN
         INFO = -7
      ELSE IF( LDBX.LT.N ) THEN
         INFO = -9
      ELSE IF( GIVPTR.LT.0 ) THEN
         INFO = -11
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -13
      ELSE IF( LDGNUM.LT.N ) THEN
         INFO = -15
      ELSE IF( K.LT.1 ) THEN
         INFO = -20
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLALS0', -INFO )
         RETURN
      END IF
!
      M = N + SQRE
      NLP1 = NL + 1
!
      IF( ICOMPQ.EQ.0 ) THEN
!
!        Apply back orthogonal transformations from the left.
!
!        Step (1L): apply back the Givens rotations performed.
!
         DO 10 I = 1, GIVPTR
            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, &
                       B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), &
                       GIVNUM( I, 1 ) )
   10    CONTINUE
!
!        Step (2L): permute rows of B.
!
         CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
         DO 20 I = 2, N
            CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
   20    CONTINUE
!
!        Step (3L): apply the inverse of the left singular vector
!        matrix to BX.
!
         IF( K.EQ.1 ) THEN
            CALL DCOPY( NRHS, BX, LDBX, B, LDB )
            IF( Z( 1 ).LT.ZERO ) THEN
               CALL DSCAL( NRHS, NEGONE, B, LDB )
            END IF
         ELSE
            DO 50 J = 1, K
               DIFLJ = DIFL( J )
               DJ = POLES( J, 1 )
               DSIGJ = -POLES( J, 2 )
               IF( J.LT.K ) THEN
                  DIFRJ = -DIFR( J, 1 )
                  DSIGJP = -POLES( J+1, 2 )
               END IF
               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) ) &
                    THEN
                  WORK( J ) = ZERO
               ELSE
                  WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ / &
                              ( POLES( J, 2 )+DJ )
               END IF
               DO 30 I = 1, J - 1
                  IF( ( Z( I ).EQ.ZERO ) .OR. &
                      ( POLES( I, 2 ).EQ.ZERO ) ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = POLES( I, 2 )*Z( I ) / &
                                 ( DLAMC3( POLES( I, 2 ), DSIGJ )- &
                                 DIFLJ ) / ( POLES( I, 2 )+DJ )
                  END IF
   30          CONTINUE
               DO 40 I = J + 1, K
                  IF( ( Z( I ).EQ.ZERO ) .OR. &
                      ( POLES( I, 2 ).EQ.ZERO ) ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = POLES( I, 2 )*Z( I ) / &
                                 ( DLAMC3( POLES( I, 2 ), DSIGJP )+ &
                                 DIFRJ ) / ( POLES( I, 2 )+DJ )
                  END IF
   40          CONTINUE
               WORK( 1 ) = NEGONE
               TEMP = DNRM2( K, WORK, 1 )
               CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, &
                           B( J, 1 ), LDB )
               CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ), &
                            LDB, INFO )
   50       CONTINUE
         END IF
!
!        Move the deflated rows of BX to B also.
!
         IF( K.LT.MAX( M, N ) ) &
            CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX, &
                         B( K+1, 1 ), LDB )
      ELSE
!
!        Apply back the right orthogonal transformations.
!
!        Step (1R): apply back the new right singular vector matrix
!        to B.
!
         IF( K.EQ.1 ) THEN
            CALL DCOPY( NRHS, B, LDB, BX, LDBX )
         ELSE
            DO 80 J = 1, K
               DSIGJ = POLES( J, 2 )
               IF( Z( J ).EQ.ZERO ) THEN
                  WORK( J ) = ZERO
               ELSE
                  WORK( J ) = -Z( J ) / DIFL( J ) / &
                              ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
               END IF
               DO 60 I = 1, J - 1
                  IF( Z( J ).EQ.ZERO ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1, &
                                 2 ) )-DIFR( I, 1 ) ) / &
                                 ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
                  END IF
   60          CONTINUE
               DO 70 I = J + 1, K
                  IF( Z( J ).EQ.ZERO ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I, &
                                 2 ) )-DIFL( I ) ) / &
                                 ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
                  END IF
   70          CONTINUE
               CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, &
                           BX( J, 1 ), LDBX )
   80       CONTINUE
         END IF
!
!        Step (2R): if SQRE = 1, apply back the rotation that is
!        related to the right null space of the subproblem.
!
         IF( SQRE.EQ.1 ) THEN
            CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
            CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
         END IF
         IF( K.LT.MAX( M, N ) ) &
            CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ), &
                         LDBX )
!
!        Step (3R): permute rows of B.
!
         CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
         IF( SQRE.EQ.1 ) THEN
            CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
         END IF
         DO 90 I = 2, N
            CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
   90    CONTINUE
!
!        Step (4R): apply back the Givens rotations performed.
!
         DO 100 I = GIVPTR, 1, -1
            CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB, &
                       B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ), &
                       -GIVNUM( I, 1 ) )
  100    CONTINUE
      END IF
!
      RETURN
!
!     End of DLALS0
!
      END
      SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, &
                         LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, &
                         GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, &
                         SMLSIZ
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), &
                         K( * ), PERM( LDGCOL, * )
      DOUBLE PRECISION   B( LDB, * ), BX( LDBX, * ), C( * ), &
                         DIFL( LDU, * ), DIFR( LDU, * ), &
                         GIVNUM( LDU, * ), POLES( LDU, * ), S( * ), &
                         U( LDU, * ), VT( LDU, * ), WORK( * ), &
                         Z( LDU, * )
!     ..
!
!  Purpose
!  =======
!
!  DLALSA is an itermediate step in solving the least squares problem
!  by computing the SVD of the coefficient matrix in compact form (The
!  singular vectors are computed as products of simple orthorgonal
!  matrices.).
!
!  If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
!  matrix of an upper bidiagonal matrix to the right hand side; and if
!  ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
!  right hand side. The singular vector matrices were generated in
!  compact form by DLALSA.
!
!  Arguments
!  =========
!
!
!  ICOMPQ (input) INTEGER
!         Specifies whether the left or the right singular vector
!         matrix is involved.
!         = 0: Left singular vector matrix
!         = 1: Right singular vector matrix
!
!  SMLSIZ (input) INTEGER
!         The maximum size of the subproblems at the bottom of the
!         computation tree.
!
!  N      (input) INTEGER
!         The row and column dimensions of the upper bidiagonal matrix.
!
!  NRHS   (input) INTEGER
!         The number of columns of B and BX. NRHS must be at least 1.
!
!  B      (input) DOUBLE PRECISION array, dimension ( LDB, NRHS )
!         On input, B contains the right hand sides of the least
!         squares problem in rows 1 through M. On output, B contains
!         the solution X in rows 1 through N.
!
!  LDB    (input) INTEGER
!         The leading dimension of B in the calling subprogram.
!         LDB must be at least max(1,MAX( M, N ) ).
!
!  BX     (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
!         On exit, the result of applying the left or right singular
!         vector matrix to B.
!
!  LDBX   (input) INTEGER
!         The leading dimension of BX.
!
!  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
!         On entry, U contains the left singular vector matrices of all
!         subproblems at the bottom level.
!
!  LDU    (input) INTEGER, LDU = > N.
!         The leading dimension of arrays U, VT, DIFL, DIFR,
!         POLES, GIVNUM, and Z.
!
!  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
!         On entry, VT' contains the right singular vector matrices of
!         all subproblems at the bottom level.
!
!  K      (input) INTEGER array, dimension ( N ).
!
!  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
!
!  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
!         distances between singular values on the I-th level and
!         singular values on the (I -1)-th level, and DIFR(*, 2 * I)
!         record the normalizing factors of the right singular vectors
!         matrices of subproblems on I-th level.
!
!  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
!         On entry, Z(1, I) contains the components of the deflation-
!         adjusted updating row vector for subproblems on the I-th
!         level.
!
!  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
!         singular values involved in the secular equations on the I-th
!         level.
!
!  GIVPTR (input) INTEGER array, dimension ( N ).
!         On entry, GIVPTR( I ) records the number of Givens
!         rotations performed on the I-th problem on the computation
!         tree.
!
!  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
!         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
!         locations of Givens rotations performed on the I-th level on
!         the computation tree.
!
!  LDGCOL (input) INTEGER, LDGCOL = > N.
!         The leading dimension of arrays GIVCOL and PERM.
!
!  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).
!         On entry, PERM(*, I) records permutations done on the I-th
!         level of the computation tree.
!
!  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
!         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
!         values of Givens rotations performed on the I-th level on the
!         computation tree.
!
!  C      (input) DOUBLE PRECISION array, dimension ( N ).
!         On entry, if the I-th subproblem is not square,
!         C( I ) contains the C-value of a Givens rotation related to
!         the right null space of the I-th subproblem.
!
!  S      (input) DOUBLE PRECISION array, dimension ( N ).
!         On entry, if the I-th subproblem is not square,
!         S( I ) contains the S-value of a Givens rotation related to
!         the right null space of the I-th subproblem.
!
!  WORK   (workspace) DOUBLE PRECISION array.
!         The dimension must be at least N.
!
!  IWORK  (workspace) INTEGER array.
!         The dimension must be at least 3 * N
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!       California at Berkeley, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2, &
                         ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL, &
                         NR, NRF, NRP1, SQRE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( SMLSIZ.LT.3 ) THEN
         INFO = -2
      ELSE IF( N.LT.SMLSIZ ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.1 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.N ) THEN
         INFO = -6
      ELSE IF( LDBX.LT.N ) THEN
         INFO = -8
      ELSE IF( LDU.LT.N ) THEN
         INFO = -10
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLALSA', -INFO )
         RETURN
      END IF
!
!     Book-keeping and  setting up the computation tree.
!
      INODE = 1
      NDIML = INODE + N
      NDIMR = NDIML + N
!
      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), &
                   IWORK( NDIMR ), SMLSIZ )
!
!     The following code applies back the left singular vector factors.
!     For applying back the right singular vector factors, go to 50.
!
      IF( ICOMPQ.EQ.1 ) THEN
         GO TO 50
      END IF
!
!     The nodes on the bottom level of the tree were solved
!     by DLASDQ. The corresponding left and right singular vector
!     matrices are in explicit form. First apply back the left
!     singular vector matrices.
!
      NDB1 = ( ND+1 ) / 2
      DO 10 I = NDB1, ND
!
!        IC : center row of each node
!        NL : number of rows of left  subproblem
!        NR : number of rows of right subproblem
!        NLF: starting row of the left   subproblem
!        NRF: starting row of the right  subproblem
!
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NR = IWORK( NDIMR+I1 )
         NLF = IC - NL
         NRF = IC + 1
         CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, &
                     B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
         CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, &
                     B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
   10 CONTINUE
!
!     Next copy the rows of B that correspond to unchanged rows
!     in the bidiagonal matrix to BX.
!
      DO 20 I = 1, ND
         IC = IWORK( INODE+I-1 )
         CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
   20 CONTINUE
!
!     Finally go through the left singular vector matrices of all
!     the other subproblems bottom-up on the tree.
!
      J = 2**NLVL
      SQRE = 0
!
      DO 40 LVL = NLVL, 1, -1
         LVL2 = 2*LVL - 1
!
!        find the first node LF and last node LL on
!        the current level LVL
!
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 30 I = LF, LL
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            NRF = IC + 1
            J = J - 1
            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX, &
                         B( NLF, 1 ), LDB, PERM( NLF, LVL ), &
                         GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, &
                         GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), &
                         DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), &
                         Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, &
                         INFO )
   30    CONTINUE
   40 CONTINUE
      GO TO 90
!
!     ICOMPQ = 1: applying back the right singular vector factors.
!
   50 CONTINUE
!
!     First now go through the right singular vector matrices of all
!     the tree nodes top-down.
!
      J = 0
      DO 70 LVL = 1, NLVL
         LVL2 = 2*LVL - 1
!
!        Find the first node LF and last node LL on
!        the current level LVL.
!
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 60 I = LL, LF, -1
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            NRF = IC + 1
            IF( I.EQ.LL ) THEN
               SQRE = 0
            ELSE
               SQRE = 1
            END IF
            J = J + 1
            CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB, &
                         BX( NLF, 1 ), LDBX, PERM( NLF, LVL ), &
                         GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, &
                         GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ), &
                         DIFL( NLF, LVL ), DIFR( NLF, LVL2 ), &
                         Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK, &
                         INFO )
   60    CONTINUE
   70 CONTINUE
!
!     The nodes on the bottom level of the tree were solved
!     by DLASDQ. The corresponding right singular vector
!     matrices are in explicit form. Apply them back.
!
      NDB1 = ( ND+1 ) / 2
      DO 80 I = NDB1, ND
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NR = IWORK( NDIMR+I1 )
         NLP1 = NL + 1
         IF( I.EQ.ND ) THEN
            NRP1 = NR
         ELSE
            NRP1 = NR + 1
         END IF
         NLF = IC - NL
         NRF = IC + 1
         CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, &
                     B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
         CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, &
                     B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
   80 CONTINUE
!
   90 CONTINUE
!
      RETURN
!
!     End of DLALSA
!
      END
      SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, &
                         RANK, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS, RANK, SMLSIZ
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLALSD uses the singular value decomposition of A to solve the least
!  squares problem of finding X to minimize the Euclidean norm of each
!  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
!  are N-by-NRHS. The solution X overwrites B.
!
!  The singular values of A smaller than RCOND times the largest
!  singular value are treated as zero in solving the least squares
!  problem; in this case a minimum norm solution is returned.
!  The actual singular values are returned in D in ascending order.
!
!  This code makes very mild assumptions about floating point
!  arithmetic. It will work on machines with a guard digit in
!  add/subtract, or on those binary machines without guard digits
!  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
!  It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  UPLO   (input) CHARACTER*1
!         = 'U': D and E define an upper bidiagonal matrix.
!         = 'L': D and E define a  lower bidiagonal matrix.
!
!  SMLSIZ (input) INTEGER
!         The maximum size of the subproblems at the bottom of the
!         computation tree.
!
!  N      (input) INTEGER
!         The dimension of the  bidiagonal matrix.  N >= 0.
!
!  NRHS   (input) INTEGER
!         The number of columns of B. NRHS must be at least 1.
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry D contains the main diagonal of the bidiagonal
!         matrix. On exit, if INFO = 0, D contains its singular values.
!
!  E      (input) DOUBLE PRECISION array, dimension (N-1)
!         Contains the super-diagonal entries of the bidiagonal matrix.
!         On exit, E has been destroyed.
!
!  B      (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!         On input, B contains the right hand sides of the least
!         squares problem. On output, B contains the solution X.
!
!  LDB    (input) INTEGER
!         The leading dimension of B in the calling subprogram.
!         LDB must be at least max(1,N).
!
!  RCOND  (input) DOUBLE PRECISION
!         The singular values of A less than or equal to RCOND times
!         the largest singular value are treated as zero in solving
!         the least squares problem. If RCOND is negative,
!         machine precision is used instead.
!         For example, if diag(S)*X=B were the least squares problem,
!         where diag(S) is a diagonal matrix of singular values, the
!         solution would be X(i) = B(i) / S(i) if S(i) is greater than
!         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
!         RCOND*max(S).
!
!  RANK   (output) INTEGER
!         The number of singular values of A greater than RCOND times
!         the largest singular value.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension at least
!         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
!         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
!
!  IWORK  (workspace) INTEGER array, dimension at least
!         (3*N*NLVL + 11*N)
!
!  INFO   (output) INTEGER
!         = 0:  successful exit.
!         < 0:  if INFO = -i, the i-th argument had an illegal value.
!         > 0:  The algorithm failed to compute an singular value while
!               working on the submatrix lying in rows and columns
!               INFO/(N+1) through MOD(INFO,N+1).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Ren-Cang Li, Computer Science Division, University of
!       California at Berkeley, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM, &
                         GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL, &
                         NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI, &
                         SMLSZP, SQRE, ST, ST1, U, VT, Z
      DOUBLE PRECISION   CS, EPS, ORGNRM, R, SN, TOL
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           IDAMAX, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL, &
                         DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG, SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.1 ) THEN
         INFO = -4
      ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLALSD', -INFO )
         RETURN
      END IF
!
      EPS = DLAMCH( 'Epsilon' )
!
!     Set up the tolerance.
!
      IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
         RCOND = EPS
      END IF
!
      RANK = 0
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         IF( D( 1 ).EQ.ZERO ) THEN
            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
         ELSE
            RANK = 1
            CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
            D( 1 ) = ABS( D( 1 ) )
         END IF
         RETURN
      END IF
!
!     Rotate the matrix if it is lower bidiagonal.
!
      IF( UPLO.EQ.'L' ) THEN
         DO 10 I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( NRHS.EQ.1 ) THEN
               CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
            ELSE
               WORK( I*2-1 ) = CS
               WORK( I*2 ) = SN
            END IF
   10    CONTINUE
         IF( NRHS.GT.1 ) THEN
            DO 30 I = 1, NRHS
               DO 20 J = 1, N - 1
                  CS = WORK( J*2-1 )
                  SN = WORK( J*2 )
                  CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
   20          CONTINUE
   30       CONTINUE
         END IF
      END IF
!
!     Scale.
!
      NM1 = N - 1
      ORGNRM = DLANST( 'M', N, D, E )
      IF( ORGNRM.EQ.ZERO ) THEN
         CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
         RETURN
      END IF
!
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
!
!     If N is smaller than the minimum divide size SMLSIZ, then solve
!     the problem with another solver.
!
      IF( N.LE.SMLSIZ ) THEN
         NWORK = 1 + N*N
         CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
         CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B, &
                      LDB, WORK( NWORK ), INFO )
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
         DO 40 I = 1, N
            IF( D( I ).LE.TOL ) THEN
               CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
            ELSE
               CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ), &
                            LDB, INFO )
               RANK = RANK + 1
            END IF
   40    CONTINUE
         CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, &
                     WORK( NWORK ), N )
         CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
!
!        Unscale.
!
         CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
         CALL DLASRT( 'D', N, D, INFO )
         CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
!
         RETURN
      END IF
!
!     Book-keeping and setting up some constants.
!
      NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
!
      SMLSZP = SMLSIZ + 1
!
      U = 1
      VT = 1 + SMLSIZ*N
      DIFL = VT + SMLSZP*N
      DIFR = DIFL + NLVL*N
      Z = DIFR + NLVL*N*2
      C = Z + NLVL*N
      S = C + N
      POLES = S + N
      GIVNUM = POLES + 2*NLVL*N
      BX = GIVNUM + 2*NLVL*N
      NWORK = BX + N*NRHS
!
      SIZEI = 1 + N
      K = SIZEI + N
      GIVPTR = K + N
      PERM = GIVPTR + N
      GIVCOL = PERM + NLVL*N
      IWK = GIVCOL + NLVL*N*2
!
      ST = 1
      SQRE = 0
      ICMPQ1 = 1
      ICMPQ2 = 0
      NSUB = 0
!
      DO 50 I = 1, N
         IF( ABS( D( I ) ).LT.EPS ) THEN
            D( I ) = SIGN( EPS, D( I ) )
         END IF
   50 CONTINUE
!
      DO 60 I = 1, NM1
         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
            NSUB = NSUB + 1
            IWORK( NSUB ) = ST
!
!           Subproblem found. First determine its size and then
!           apply divide and conquer on it.
!
            IF( I.LT.NM1 ) THEN
!
!              A subproblem with E(I) small for I < NM1.
!
               NSIZE = I - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
!
!              A subproblem with E(NM1) not too small but I = NM1.
!
               NSIZE = N - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
            ELSE
!
!              A subproblem with E(NM1) small. This implies an
!              1-by-1 subproblem at D(N), which is not solved
!              explicitly.
!
               NSIZE = I - ST + 1
               IWORK( SIZEI+NSUB-1 ) = NSIZE
               NSUB = NSUB + 1
               IWORK( NSUB ) = N
               IWORK( SIZEI+NSUB-1 ) = 1
               CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
            END IF
            ST1 = ST - 1
            IF( NSIZE.EQ.1 ) THEN
!
!              This is a 1-by-1 subproblem and is not solved
!              explicitly.
!
               CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
            ELSE IF( NSIZE.LE.SMLSIZ ) THEN
!
!              This is a small subproblem and is solved by DLASDQ.
!
               CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE, &
                            WORK( VT+ST1 ), N )
               CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ), &
                            E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ), &
                            N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
               CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB, &
                            WORK( BX+ST1 ), N )
            ELSE
!
!              A large problem. Solve it using divide and conquer.
!
               CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ), &
                            E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ), &
                            IWORK( K+ST1 ), WORK( DIFL+ST1 ), &
                            WORK( DIFR+ST1 ), WORK( Z+ST1 ), &
                            WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ), &
                            IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ), &
                            WORK( GIVNUM+ST1 ), WORK( C+ST1 ), &
                            WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ), &
                            INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
               BXST = BX + ST1
               CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ), &
                            LDB, WORK( BXST ), N, WORK( U+ST1 ), N, &
                            WORK( VT+ST1 ), IWORK( K+ST1 ), &
                            WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), &
                            WORK( Z+ST1 ), WORK( POLES+ST1 ), &
                            IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, &
                            IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), &
                            WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), &
                            IWORK( IWK ), INFO )
               IF( INFO.NE.0 ) THEN
                  RETURN
               END IF
            END IF
            ST = I + 1
         END IF
   60 CONTINUE
!
!     Apply the singular values and treat the tiny ones as zero.
!
      TOL = RCOND*ABS( D( IDAMAX( N, D, 1 ) ) )
!
      DO 70 I = 1, N
!
!        Some of the elements in D can be negative because 1-by-1
!        subproblems were not solved explicitly.
!
         IF( ABS( D( I ) ).LE.TOL ) THEN
            CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
         ELSE
            RANK = RANK + 1
            CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, &
                         WORK( BX+I-1 ), N, INFO )
         END IF
         D( I ) = ABS( D( I ) )
   70 CONTINUE
!
!     Now apply back the right singular vectors.
!
      ICMPQ2 = 1
      DO 80 I = 1, NSUB
         ST = IWORK( I )
         ST1 = ST - 1
         NSIZE = IWORK( SIZEI+I-1 )
         BXST = BX + ST1
         IF( NSIZE.EQ.1 ) THEN
            CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
         ELSE IF( NSIZE.LE.SMLSIZ ) THEN
            CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, &
                        WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO, &
                        B( ST, 1 ), LDB )
         ELSE
            CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N, &
                         B( ST, 1 ), LDB, WORK( U+ST1 ), N, &
                         WORK( VT+ST1 ), IWORK( K+ST1 ), &
                         WORK( DIFL+ST1 ), WORK( DIFR+ST1 ), &
                         WORK( Z+ST1 ), WORK( POLES+ST1 ), &
                         IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N, &
                         IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ), &
                         WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ), &
                         IWORK( IWK ), INFO )
            IF( INFO.NE.0 ) THEN
               RETURN
            END IF
         END IF
   80 CONTINUE
!
!     Unscale and sort the singular values.
!
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
      CALL DLASRT( 'D', N, D, INFO )
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
!
      RETURN
!
!     End of DLALSD
!
      END
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          CMACH
!     ..
!
!  Purpose
!  =======
!
!  DLAMCH determines double precision machine parameters.
!
!  Arguments
!  =========
!
!  CMACH   (input) CHARACTER*1
!          Specifies the value to be returned by DLAMCH:
!          = 'E' or 'e',   DLAMCH := eps
!          = 'S' or 's ,   DLAMCH := sfmin
!          = 'B' or 'b',   DLAMCH := base
!          = 'P' or 'p',   DLAMCH := eps*base
!          = 'N' or 'n',   DLAMCH := t
!          = 'R' or 'r',   DLAMCH := rnd
!          = 'M' or 'm',   DLAMCH := emin
!          = 'U' or 'u',   DLAMCH := rmin
!          = 'L' or 'l',   DLAMCH := emax
!          = 'O' or 'o',   DLAMCH := rmax
!
!          where
!
!          eps   = relative machine precision
!          sfmin = safe minimum, such that 1/sfmin does not overflow
!          base  = base of the machine
!          prec  = eps*base
!          t     = number of (base) digits in the mantissa
!          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
!          emin  = minimum exponent before (gradual) underflow
!          rmin  = underflow threshold - base**(emin-1)
!          emax  = largest exponent before overflow
!          rmax  = overflow threshold  - (base**emax)*(1-eps)
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, &
                         RND, SFMIN, SMALL, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAMC2
!     ..
!     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, &
                         EMAX, RMAX, PREC
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
!
!           Use SMALL plus a bit, to avoid the possibility of rounding
!           causing overflow when computing  1/sfmin.
!
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
!
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
!
      DLAMCH = RMACH
      RETURN
!
!     End of DLAMCH
!
      END
!
!***********************************************************************
!
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
!     ..
!
!  Purpose
!  =======
!
!  DLAMC1 determines the machine parameters given by BETA, T, RND, and
!  IEEE1.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  IEEE1   (output) LOGICAL
!          Specifies whether rounding appears to be done in the IEEE
!          'round to nearest' style.
!
!  Further Details
!  ===============
!
!  The routine is based on the routine  ENVRON  by Malcolm and
!  incorporates suggestions by Gentleman and Marovich. See
!
!     Malcolm M. A. (1972) Algorithms to reveal properties of
!        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
!
!     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
!        that reveal properties of floating point arithmetic units.
!        Comms. of the ACM, 17, 276-277.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
!     ..
!     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
!
!        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
!        IEEE1, T and RND.
!
!        Throughout this routine  we use the function  DLAMC3  to ensure
!        that relevant values are  stored and not held in registers,  or
!        are not affected by optimizers.
!
!        Compute  a = 2.0**m  with the  smallest positive integer m such
!        that
!
!           fl( a + 1.0 ) = a.
!
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 10
         END IF
!+       END WHILE
!
!        Now compute  b = 2.0**m  with the smallest positive integer m
!        such that
!
!           fl( a + b ) .gt. a.
!
         B = 1
         C = DLAMC3( A, B )
!
!+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
!+       END WHILE
!
!        Now compute the base.  a and c  are neighbouring floating point
!        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
!        their difference is beta. Adding 0.25 to c is to ensure that it
!        is truncated to beta and not ( beta - 1 ).
!
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
!
!        Now determine whether rounding or chopping occurs,  by adding a
!        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
!
         B = LBETA
         F = DLAMC3( B / 2, -B / 100 )
         C = DLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = DLAMC3( B / 2, B / 100 )
         C = DLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) ) &
            LRND = .FALSE.
!
!        Try and decide whether rounding is done in the  IEEE  'round to
!        nearest' style. B/2 is half a unit in the last place of the two
!        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
!        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
!        A, but adding B/2 to SAVEC should change SAVEC.
!
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
!
!        Now find  the  mantissa, t.  It should  be the  integer part of
!        log to the base beta of a,  however it is safer to determine  t
!        by powering.  So we find t as the smallest positive integer for
!        which
!
!           fl( beta**t + 1.0 ) = 1.0.
!
         LT = 0
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 30
         END IF
!+       END WHILE
!
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
!
!     End of DLAMC1
!
      END
!
!***********************************************************************
!
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      DOUBLE PRECISION   EPS, RMAX, RMIN
!     ..
!
!  Purpose
!  =======
!
!  DLAMC2 determines the machine parameters specified in its argument
!  list.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  EPS     (output) DOUBLE PRECISION
!          The smallest positive number such that
!
!             fl( 1.0 - EPS ) .LT. 1.0,
!
!          where fl denotes the computed value.
!
!  EMIN    (output) INTEGER
!          The minimum exponent before (gradual) underflow occurs.
!
!  RMIN    (output) DOUBLE PRECISION
!          The smallest normalized number for the machine, given by
!          BASE**( EMIN - 1 ), where  BASE  is the floating point value
!          of BETA.
!
!  EMAX    (output) INTEGER
!          The maximum exponent before overflow occurs.
!
!  RMAX    (output) DOUBLE PRECISION
!          The largest positive number for the machine, given by
!          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
!          value of BETA.
!
!  Further Details
!  ===============
!
!  The computation of  EPS  is based on a routine PARANOIA by
!  W. Kahan of the University of California at Berkeley.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, &
                         NGNMIN, NGPMIN
      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, &
                         SIXTH, SMALL, THIRD, TWO, ZERO
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, &
                         LRMIN, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
!
!        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
!        BETA, T, RND, EPS, EMIN and RMIN.
!
!        Throughout this routine  we use the function  DLAMC3  to ensure
!        that relevant values are stored  and not held in registers,  or
!        are not affected by optimizers.
!
!        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
!
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
!
!        Start to find EPS.
!
         B = LBETA
         A = B**( -LT )
         LEPS = A
!
!        Try some tricks to see whether or not this is the correct  EPS.
!
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = DLAMC3( B, -HALF )
         THIRD = DLAMC3( SIXTH, SIXTH )
         B = DLAMC3( THIRD, -HALF )
         B = DLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS ) &
            B = LEPS
!
         LEPS = 1
!
!+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = DLAMC3( HALF, -C )
            B = DLAMC3( HALF, C )
            C = DLAMC3( HALF, -B )
            B = DLAMC3( HALF, C )
            GO TO 10
         END IF
!+       END WHILE
!
         IF( A.LT.LEPS ) &
            LEPS = A
!
!        Computation of EPS complete.
!
!        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
!        Keep dividing  A by BETA until (gradual) underflow occurs. This
!        is detected when we cannot recover the previous A.
!
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = DLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = DLAMC3( ONE, SMALL )
         CALL DLAMC4( NGPMIN, ONE, LBETA )
         CALL DLAMC4( NGNMIN, -ONE, LBETA )
         CALL DLAMC4( GPMIN, A, LBETA )
         CALL DLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
!
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
!            ( Non twos-complement machines, no gradual underflow;
!              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
!            ( Non twos-complement machines, with gradual underflow;
!              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
!            ( Twos-complement machines, no gradual underflow;
!              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. &
                  ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
!            ( Twos-complement machines with gradual underflow;
!              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
!         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
!**
! Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
!**
!
!        Assume IEEE arithmetic if we found denormalised  numbers above,
!        or if arithmetic seems to round in the  IEEE style,  determined
!        in routine DLAMC1. A true IEEE machine should have both  things
!        true; however, faulty machines may have one or the other.
!
         IEEE = IEEE .OR. LIEEE1
!
!        Compute  RMIN by successive division by  BETA. We could compute
!        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
!        this computation.
!
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
!
!        Finally, call DLAMC5 to compute EMAX and RMAX.
!
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
!
      RETURN
!
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', &
            '  EMIN = ', I8, / &
            ' If, after inspection, the value EMIN looks', &
            ' acceptable please comment out ', &
            / ' the IF block as marked within the code of routine', &
            ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
!
!     End of DLAMC2
!
      END
!
!***********************************************************************
!
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
!     ..
!
!  Purpose
!  =======
!
!  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
!  the addition of  A  and  B ,  for use in situations where optimizers
!  might hold one of these in a register.
!
!  Arguments
!  =========
!
!  A, B    (input) DOUBLE PRECISION
!          The values A and B.
!
! =====================================================================
!
!     .. Executable Statements ..
!
      DLAMC3 = A + B
!
      RETURN
!
!     End of DLAMC3
!
      END
!
!***********************************************************************
!
      SUBROUTINE DLAMC4( EMIN, START, BASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      DOUBLE PRECISION   START
!     ..
!
!  Purpose
!  =======
!
!  DLAMC4 is a service routine for DLAMC2.
!
!  Arguments
!  =========
!
!  EMIN    (output) EMIN
!          The minimum exponent before (gradual) underflow, computed by
!          setting A = START and dividing by BASE until the previous A
!          can not be recovered.
!
!  START   (input) DOUBLE PRECISION
!          The starting point for determining EMIN.
!
!  BASE    (input) INTEGER
!          The base of the machine.
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
!     ..
!     .. Executable Statements ..
!
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
!+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
!    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. &
          ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = DLAMC3( A / BASE, ZERO )
         C1 = DLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = DLAMC3( A*RBASE, ZERO )
         C2 = DLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
!+    END WHILE
!
      RETURN
!
!     End of DLAMC4
!
      END
!
!***********************************************************************
!
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      DOUBLE PRECISION   RMAX
!     ..
!
!  Purpose
!  =======
!
!  DLAMC5 attempts to compute RMAX, the largest machine floating-point
!  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
!  approximately to a power of 2.  It will fail on machines where this
!  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
!  EMAX = 28718).  It will also fail if the value supplied for EMIN is
!  too large (i.e. too close to zero), probably with overflow.
!
!  Arguments
!  =========
!
!  BETA    (input) INTEGER
!          The base of floating-point arithmetic.
!
!  P       (input) INTEGER
!          The number of base BETA digits in the mantissa of a
!          floating-point value.
!
!  EMIN    (input) INTEGER
!          The minimum exponent before (gradual) underflow.
!
!  IEEE    (input) LOGICAL
!          A logical flag specifying whether or not the arithmetic
!          system is thought to comply with the IEEE standard.
!
!  EMAX    (output) INTEGER
!          The largest exponent before overflow
!
!  RMAX    (output) DOUBLE PRECISION
!          The largest machine floating-point number.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MOD
!     ..
!     .. Executable Statements ..
!
!     First compute LEXP and UEXP, two powers of 2 that bound
!     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
!     approximately to the bound that is closest to abs(EMIN).
!     (EMAX is the exponent of the required number RMAX).
!
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
!
!     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
!     than or equal to EMIN. EXBITS is the number of bits needed to
!     store the exponent.
!
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
!
!     EXPSUM is the exponent range, approximately equal to
!     EMAX - EMIN + 1 .
!
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
!
!     NBITS is the total number of bits needed to store a
!     floating-point number.
!
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
!
!        Either there are an odd number of bits used to store a
!        floating-point number, which is unlikely, or some bits are
!        not used in the representation of numbers, which is possible,
!        (e.g. Cray machines) or the mantissa has an implicit bit,
!        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
!        most likely. We have to assume the last alternative.
!        If this is true, then we need to reduce EMAX by one because
!        there must be some way of representing zero in an implicit-bit
!        system. On machines like Cray, we are reducing EMAX by one
!        unnecessarily.
!
         EMAX = EMAX - 1
      END IF
!
      IF( IEEE ) THEN
!
!        Assume we are on an IEEE machine which reserves one exponent
!        for infinity and NaN.
!
         EMAX = EMAX - 1
      END IF
!
!     Now create RMAX, the largest machine number, which should
!     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
!
!     First compute 1.0 - BETA**(-P), being careful that the
!     result is less than 1.0 .
!
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE ) &
            OLDY = Y
         Y = DLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE ) &
         Y = OLDY
!
!     Now multiply by BETA**EMAX to get RMAX.
!
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
!
      RMAX = Y
      RETURN
!
!     End of DLAMC5
!
      END
      SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            DTRD1, DTRD2, N1, N2
!     ..
!     .. Array Arguments ..
      INTEGER            INDEX( * )
      DOUBLE PRECISION   A( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAMRG will create a permutation list which will merge the elements
!  of A (which is composed of two independently sorted sets) into a
!  single set which is sorted in ascending order.
!
!  Arguments
!  =========
!
!  N1     (input) INTEGER
!  N2     (input) INTEGER
!         These arguements contain the respective lengths of the two
!         sorted lists to be merged.
!
!  A      (input) DOUBLE PRECISION array, dimension (N1+N2)
!         The first N1 elements of A contain a list of numbers which
!         are sorted in either ascending or descending order.  Likewise
!         for the final N2 elements.
!
!  DTRD1  (input) INTEGER
!  DTRD2  (input) INTEGER
!         These are the strides to be taken through the array A.
!         Allowable strides are 1 and -1.  They indicate whether a
!         subset of A is sorted in ascending (DTRDx = 1) or descending
!         (DTRDx = -1) order.
!
!  INDEX  (output) INTEGER array, dimension (N1+N2)
!         On exit this array will contain a permutation such that
!         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
!         sorted in ascending order.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IND1, IND2, N1SV, N2SV
!     ..
!     .. Executable Statements ..
!
      N1SV = N1
      N2SV = N2
      IF( DTRD1.GT.0 ) THEN
         IND1 = 1
      ELSE
         IND1 = N1
      END IF
      IF( DTRD2.GT.0 ) THEN
         IND2 = 1 + N1
      ELSE
         IND2 = N1 + N2
      END IF
      I = 1
!     while ( (N1SV > 0) & (N2SV > 0) )
   10 CONTINUE
      IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
         IF( A( IND1 ).LE.A( IND2 ) ) THEN
            INDEX( I ) = IND1
            I = I + 1
            IND1 = IND1 + DTRD1
            N1SV = N1SV - 1
         ELSE
            INDEX( I ) = IND2
            I = I + 1
            IND2 = IND2 + DTRD2
            N2SV = N2SV - 1
         END IF
         GO TO 10
      END IF
!     end while
      IF( N1SV.EQ.0 ) THEN
         DO 20 N1SV = 1, N2SV
            INDEX( I ) = IND2
            I = I + 1
            IND2 = IND2 + DTRD2
   20    CONTINUE
      ELSE
!     N2SV .EQ. 0
         DO 30 N2SV = 1, N1SV
            INDEX( I ) = IND1
            I = I + 1
            IND1 = IND1 + DTRD1
   30    CONTINUE
      END IF
!
      RETURN
!
!     End of DLAMRG
!
      END
      DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, &
                       WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            KL, KU, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANGB  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the element of  largest absolute value  of an
!  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
!
!  Description
!  ===========
!
!  DLANGB returns the value
!
!     DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANGB as described
!          above.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANGB is
!          set to zero.
!
!  KL      (input) INTEGER
!          The number of sub-diagonals of the matrix A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of super-diagonals of the matrix A.  KU >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
!          column of A is stored in the j-th column of the array AB as
!          follows:
!          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KL+KU+1.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, K, L
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         DO 20 J = 1, N
            DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
               VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         DO 40 J = 1, N
            SUM = ZERO
            DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
               SUM = SUM + ABS( AB( I, J ) )
   30       CONTINUE
            VALUE = MAX( VALUE, SUM )
   40    CONTINUE
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         DO 50 I = 1, N
            WORK( I ) = ZERO
   50    CONTINUE
         DO 70 J = 1, N
            K = KU + 1 - J
            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
   60       CONTINUE
   70    CONTINUE
         VALUE = ZERO
         DO 80 I = 1, N
            VALUE = MAX( VALUE, WORK( I ) )
   80    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         DO 90 J = 1, N
            L = MAX( 1, J-KU )
            K = KU + 1 - J + L
            CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
   90    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANGB = VALUE
      RETURN
!
!     End of DLANGB
!
      END
      DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANGE  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  real matrix A.
!
!  Description
!  ===========
!
!  DLANGE returns the value
!
!     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANGE as described
!          above.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.  When M = 0,
!          DLANGE is set to zero.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.  When N = 0,
!          DLANGE is set to zero.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The m by n matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(M,1).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         DO 20 J = 1, N
            DO 10 I = 1, M
               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         DO 40 J = 1, N
            SUM = ZERO
            DO 30 I = 1, M
               SUM = SUM + ABS( A( I, J ) )
   30       CONTINUE
            VALUE = MAX( VALUE, SUM )
   40    CONTINUE
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         DO 50 I = 1, M
            WORK( I ) = ZERO
   50    CONTINUE
         DO 70 J = 1, N
            DO 60 I = 1, M
               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
   60       CONTINUE
   70    CONTINUE
         VALUE = ZERO
         DO 80 I = 1, M
            VALUE = MAX( VALUE, WORK( I ) )
   80    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         DO 90 J = 1, N
            CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
   90    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANGE = VALUE
      RETURN
!
!     End of DLANGE
!
      END
      DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DL( * ), DU( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANGT  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  real tridiagonal matrix A.
!
!  Description
!  ===========
!
!  DLANGT returns the value
!
!     DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANGT as described
!          above.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANGT is
!          set to zero.
!
!  DL      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) sub-diagonal elements of A.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of A.
!
!  DU      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) super-diagonal elements of A.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   ANORM, SCALE, SUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.LE.0 ) THEN
         ANORM = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         ANORM = ABS( D( N ) )
         DO 10 I = 1, N - 1
            ANORM = MAX( ANORM, ABS( DL( I ) ) )
            ANORM = MAX( ANORM, ABS( D( I ) ) )
            ANORM = MAX( ANORM, ABS( DU( I ) ) )
   10    CONTINUE
      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
!
!        Find norm1(A).
!
         IF( N.EQ.1 ) THEN
            ANORM = ABS( D( 1 ) )
         ELSE
            ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ), &
                    ABS( D( N ) )+ABS( DU( N-1 ) ) )
            DO 20 I = 2, N - 1
               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+ &
                       ABS( DU( I-1 ) ) )
   20       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         IF( N.EQ.1 ) THEN
            ANORM = ABS( D( 1 ) )
         ELSE
            ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ), &
                    ABS( D( N ) )+ABS( DL( N-1 ) ) )
            DO 30 I = 2, N - 1
               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+ &
                       ABS( DL( I-1 ) ) )
   30       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         CALL DLASSQ( N, D, 1, SCALE, SUM )
         IF( N.GT.1 ) THEN
            CALL DLASSQ( N-1, DL, 1, SCALE, SUM )
            CALL DLASSQ( N-1, DU, 1, SCALE, SUM )
         END IF
         ANORM = SCALE*SQRT( SUM )
      END IF
!
      DLANGT = ANORM
      RETURN
!
!     End of DLANGT
!
      END
      DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANHS  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  Hessenberg matrix A.
!
!  Description
!  ===========
!
!  DLANHS returns the value
!
!     DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANHS as described
!          above.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANHS is
!          set to zero.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The n by n upper Hessenberg matrix A; the part of A below the
!          first sub-diagonal is not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(N,1).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         DO 20 J = 1, N
            DO 10 I = 1, MIN( N, J+1 )
               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         DO 40 J = 1, N
            SUM = ZERO
            DO 30 I = 1, MIN( N, J+1 )
               SUM = SUM + ABS( A( I, J ) )
   30       CONTINUE
            VALUE = MAX( VALUE, SUM )
   40    CONTINUE
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         DO 50 I = 1, N
            WORK( I ) = ZERO
   50    CONTINUE
         DO 70 J = 1, N
            DO 60 I = 1, MIN( N, J+1 )
               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
   60       CONTINUE
   70    CONTINUE
         VALUE = ZERO
         DO 80 I = 1, N
            VALUE = MAX( VALUE, WORK( I ) )
   80    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         DO 90 J = 1, N
            CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
   90    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANHS = VALUE
      RETURN
!
!     End of DLANHS
!
      END
      DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, &
                       WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            K, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANSB  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the element of  largest absolute value  of an
!  n by n symmetric band matrix A,  with k super-diagonals.
!
!  Description
!  ===========
!
!  DLANSB returns the value
!
!     DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANSB as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          band matrix A is supplied.
!          = 'U':  Upper triangular part is supplied
!          = 'L':  Lower triangular part is supplied
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANSB is
!          set to zero.
!
!  K       (input) INTEGER
!          The number of super-diagonals or sub-diagonals of the
!          band matrix A.  K >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangle of the symmetric band matrix A,
!          stored in the first K+1 rows of AB.  The j-th column of A is
!          stored in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= K+1.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!          WORK is not referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, L
      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 20 J = 1, N
               DO 10 I = MAX( K+2-J, 1 ), K + 1
                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40 J = 1, N
               DO 30 I = 1, MIN( N+1-J, K+1 )
                  VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. &
               ( NORM.EQ.'1' ) ) THEN
!
!        Find normI(A) ( = norm1(A), since A is symmetric).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 60 J = 1, N
               SUM = ZERO
               L = K + 1 - J
               DO 50 I = MAX( 1, J-K ), J - 1
                  ABSA = ABS( AB( L+I, J ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
   50          CONTINUE
               WORK( J ) = SUM + ABS( AB( K+1, J ) )
   60       CONTINUE
            DO 70 I = 1, N
               VALUE = MAX( VALUE, WORK( I ) )
   70       CONTINUE
         ELSE
            DO 80 I = 1, N
               WORK( I ) = ZERO
   80       CONTINUE
            DO 100 J = 1, N
               SUM = WORK( J ) + ABS( AB( 1, J ) )
               L = 1 - J
               DO 90 I = J + 1, MIN( N, J+K )
                  ABSA = ABS( AB( L+I, J ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
   90          CONTINUE
               VALUE = MAX( VALUE, SUM )
  100       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         IF( K.GT.0 ) THEN
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 110 J = 2, N
                  CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), &
                               1, SCALE, SUM )
  110          CONTINUE
               L = K + 1
            ELSE
               DO 120 J = 1, N - 1
                  CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, &
                               SUM )
  120          CONTINUE
               L = 1
            END IF
            SUM = 2*SUM
         ELSE
            L = 1
         END IF
         CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANSB = VALUE
      RETURN
!
!     End of DLANSB
!
      END
      DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANSP  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  real symmetric matrix A,  supplied in packed form.
!
!  Description
!  ===========
!
!  DLANSP returns the value
!
!     DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANSP as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is supplied.
!          = 'U':  Upper triangular part of A is supplied
!          = 'L':  Lower triangular part of A is supplied
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is
!          set to zero.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangle of the symmetric matrix A, packed
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!          WORK is not referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, K
      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            K = 1
            DO 20 J = 1, N
               DO 10 I = K, K + J - 1
                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
   10          CONTINUE
               K = K + J
   20       CONTINUE
         ELSE
            K = 1
            DO 40 J = 1, N
               DO 30 I = K, K + N - J
                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
   30          CONTINUE
               K = K + N - J + 1
   40       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. &
               ( NORM.EQ.'1' ) ) THEN
!
!        Find normI(A) ( = norm1(A), since A is symmetric).
!
         VALUE = ZERO
         K = 1
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 60 J = 1, N
               SUM = ZERO
               DO 50 I = 1, J - 1
                  ABSA = ABS( AP( K ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
                  K = K + 1
   50          CONTINUE
               WORK( J ) = SUM + ABS( AP( K ) )
               K = K + 1
   60       CONTINUE
            DO 70 I = 1, N
               VALUE = MAX( VALUE, WORK( I ) )
   70       CONTINUE
         ELSE
            DO 80 I = 1, N
               WORK( I ) = ZERO
   80       CONTINUE
            DO 100 J = 1, N
               SUM = WORK( J ) + ABS( AP( K ) )
               K = K + 1
               DO 90 I = J + 1, N
                  ABSA = ABS( AP( K ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
                  K = K + 1
   90          CONTINUE
               VALUE = MAX( VALUE, SUM )
  100       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         K = 2
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 2, N
               CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
               K = K + J
  110       CONTINUE
         ELSE
            DO 120 J = 1, N - 1
               CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
               K = K + N - J + 1
  120       CONTINUE
         END IF
         SUM = 2*SUM
         K = 1
         DO 130 I = 1, N
            IF( AP( K ).NE.ZERO ) THEN
               ABSA = ABS( AP( K ) )
               IF( SCALE.LT.ABSA ) THEN
                  SUM = ONE + SUM*( SCALE / ABSA )**2
                  SCALE = ABSA
               ELSE
                  SUM = SUM + ( ABSA / SCALE )**2
               END IF
            END IF
            IF( LSAME( UPLO, 'U' ) ) THEN
               K = K + I + 1
            ELSE
               K = K + N - I + 1
            END IF
  130    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANSP = VALUE
      RETURN
!
!     End of DLANSP
!
      END
      DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANST  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  real symmetric tridiagonal matrix A.
!
!  Description
!  ===========
!
!  DLANST returns the value
!
!     DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANST as described
!          above.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANST is
!          set to zero.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of A.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) sub-diagonal or super-diagonal elements of A.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   ANORM, SCALE, SUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.LE.0 ) THEN
         ANORM = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         ANORM = ABS( D( N ) )
         DO 10 I = 1, N - 1
            ANORM = MAX( ANORM, ABS( D( I ) ) )
            ANORM = MAX( ANORM, ABS( E( I ) ) )
   10    CONTINUE
      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. &
               LSAME( NORM, 'I' ) ) THEN
!
!        Find norm1(A).
!
         IF( N.EQ.1 ) THEN
            ANORM = ABS( D( 1 ) )
         ELSE
            ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), &
                    ABS( E( N-1 ) )+ABS( D( N ) ) )
            DO 20 I = 2, N - 1
               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ &
                       ABS( E( I-1 ) ) )
   20       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         IF( N.GT.1 ) THEN
            CALL DLASSQ( N-1, E, 1, SCALE, SUM )
            SUM = 2*SUM
         END IF
         CALL DLASSQ( N, D, 1, SCALE, SUM )
         ANORM = SCALE*SQRT( SUM )
      END IF
!
      DLANST = ANORM
      RETURN
!
!     End of DLANST
!
      END
      DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANSY  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  real symmetric matrix A.
!
!  Description
!  ===========
!
!  DLANSY returns the value
!
!     DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANSY as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is to be referenced.
!          = 'U':  Upper triangular part of A is referenced
!          = 'L':  Lower triangular part of A is referenced
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANSY is
!          set to zero.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The symmetric matrix A.  If UPLO = 'U', the leading n by n
!          upper triangular part of A contains the upper triangular part
!          of the matrix A, and the strictly lower triangular part of A
!          is not referenced.  If UPLO = 'L', the leading n by n lower
!          triangular part of A contains the lower triangular part of
!          the matrix A, and the strictly upper triangular part of A is
!          not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(N,1).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!          WORK is not referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 20 J = 1, N
               DO 10 I = 1, J
                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40 J = 1, N
               DO 30 I = J, N
                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. &
               ( NORM.EQ.'1' ) ) THEN
!
!        Find normI(A) ( = norm1(A), since A is symmetric).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 60 J = 1, N
               SUM = ZERO
               DO 50 I = 1, J - 1
                  ABSA = ABS( A( I, J ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
   50          CONTINUE
               WORK( J ) = SUM + ABS( A( J, J ) )
   60       CONTINUE
            DO 70 I = 1, N
               VALUE = MAX( VALUE, WORK( I ) )
   70       CONTINUE
         ELSE
            DO 80 I = 1, N
               WORK( I ) = ZERO
   80       CONTINUE
            DO 100 J = 1, N
               SUM = WORK( J ) + ABS( A( J, J ) )
               DO 90 I = J + 1, N
                  ABSA = ABS( A( I, J ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
   90          CONTINUE
               VALUE = MAX( VALUE, SUM )
  100       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         SCALE = ZERO
         SUM = ONE
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 2, N
               CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
  110       CONTINUE
         ELSE
            DO 120 J = 1, N - 1
               CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
  120       CONTINUE
         END IF
         SUM = 2*SUM
         CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANSY = VALUE
      RETURN
!
!     End of DLANSY
!
      END
      DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, &
                       LDAB, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            K, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANTB  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the element of  largest absolute value  of an
!  n by n triangular band matrix A,  with ( k + 1 ) diagonals.
!
!  Description
!  ===========
!
!  DLANTB returns the value
!
!     DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANTB as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANTB is
!          set to zero.
!
!  K       (input) INTEGER
!          The number of super-diagonals of the matrix A if UPLO = 'U',
!          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
!          K >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangular band matrix A, stored in the
!          first k+1 rows of AB.  The j-th column of A is stored
!          in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!          Note that when DIAG = 'U', the elements of the array AB
!          corresponding to the diagonal elements of the matrix A are
!          not referenced, but are assumed to be one.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= K+1.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UDIAG
      INTEGER            I, J, L
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         IF( LSAME( DIAG, 'U' ) ) THEN
            VALUE = ONE
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = MAX( K+2-J, 1 ), K
                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = 2, MIN( N+1-J, K+1 )
                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            VALUE = ZERO
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = MAX( K+2-J, 1 ), K + 1
                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  DO 70 I = 1, MIN( N+1-J, K+1 )
                     VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         UDIAG = LSAME( DIAG, 'U' )
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 90 I = MAX( K+2-J, 1 ), K
                     SUM = SUM + ABS( AB( I, J ) )
   90             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 100 I = MAX( K+2-J, 1 ), K + 1
                     SUM = SUM + ABS( AB( I, J ) )
  100             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  110       CONTINUE
         ELSE
            DO 140 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 120 I = 2, MIN( N+1-J, K+1 )
                     SUM = SUM + ABS( AB( I, J ) )
  120             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 130 I = 1, MIN( N+1-J, K+1 )
                     SUM = SUM + ABS( AB( I, J ) )
  130             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  140       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 150 I = 1, N
                  WORK( I ) = ONE
  150          CONTINUE
               DO 170 J = 1, N
                  L = K + 1 - J
                  DO 160 I = MAX( 1, J-K ), J - 1
                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
  160             CONTINUE
  170          CONTINUE
            ELSE
               DO 180 I = 1, N
                  WORK( I ) = ZERO
  180          CONTINUE
               DO 200 J = 1, N
                  L = K + 1 - J
                  DO 190 I = MAX( 1, J-K ), J
                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
  190             CONTINUE
  200          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 210 I = 1, N
                  WORK( I ) = ONE
  210          CONTINUE
               DO 230 J = 1, N
                  L = 1 - J
                  DO 220 I = J + 1, MIN( N, J+K )
                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
  220             CONTINUE
  230          CONTINUE
            ELSE
               DO 240 I = 1, N
                  WORK( I ) = ZERO
  240          CONTINUE
               DO 260 J = 1, N
                  L = 1 - J
                  DO 250 I = J, MIN( N, J+K )
                     WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
  250             CONTINUE
  260          CONTINUE
            END IF
         END IF
         DO 270 I = 1, N
            VALUE = MAX( VALUE, WORK( I ) )
  270    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = N
               IF( K.GT.0 ) THEN
                  DO 280 J = 2, N
                     CALL DLASSQ( MIN( J-1, K ), &
                                  AB( MAX( K+2-J, 1 ), J ), 1, SCALE, &
                                  SUM )
  280             CONTINUE
               END IF
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 290 J = 1, N
                  CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), &
                               1, SCALE, SUM )
  290          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = N
               IF( K.GT.0 ) THEN
                  DO 300 J = 1, N - 1
                     CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE, &
                                  SUM )
  300             CONTINUE
               END IF
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 310 J = 1, N
                  CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE, &
                               SUM )
  310          CONTINUE
            END IF
         END IF
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANTB = VALUE
      RETURN
!
!     End of DLANTB
!
      END
      DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANTP  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  triangular matrix A, supplied in packed form.
!
!  Description
!  ===========
!
!  DLANTP returns the value
!
!     DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANTP as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.  When N = 0, DLANTP is
!          set to zero.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangular matrix A, packed columnwise in
!          a linear array.  The j-th column of A is stored in the array
!          AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          Note that when DIAG = 'U', the elements of the array AP
!          corresponding to the diagonal elements of the matrix A are
!          not referenced, but are assumed to be one.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UDIAG
      INTEGER            I, J, K
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         K = 1
         IF( LSAME( DIAG, 'U' ) ) THEN
            VALUE = ONE
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = K, K + J - 2
                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
   10             CONTINUE
                  K = K + J
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = K + 1, K + N - J
                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
   30             CONTINUE
                  K = K + N - J + 1
   40          CONTINUE
            END IF
         ELSE
            VALUE = ZERO
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = K, K + J - 1
                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
   50             CONTINUE
                  K = K + J
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  DO 70 I = K, K + N - J
                     VALUE = MAX( VALUE, ABS( AP( I ) ) )
   70             CONTINUE
                  K = K + N - J + 1
   80          CONTINUE
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         K = 1
         UDIAG = LSAME( DIAG, 'U' )
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 90 I = K, K + J - 2
                     SUM = SUM + ABS( AP( I ) )
   90             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 100 I = K, K + J - 1
                     SUM = SUM + ABS( AP( I ) )
  100             CONTINUE
               END IF
               K = K + J
               VALUE = MAX( VALUE, SUM )
  110       CONTINUE
         ELSE
            DO 140 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 120 I = K + 1, K + N - J
                     SUM = SUM + ABS( AP( I ) )
  120             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 130 I = K, K + N - J
                     SUM = SUM + ABS( AP( I ) )
  130             CONTINUE
               END IF
               K = K + N - J + 1
               VALUE = MAX( VALUE, SUM )
  140       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         K = 1
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 150 I = 1, N
                  WORK( I ) = ONE
  150          CONTINUE
               DO 170 J = 1, N
                  DO 160 I = 1, J - 1
                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
                     K = K + 1
  160             CONTINUE
                  K = K + 1
  170          CONTINUE
            ELSE
               DO 180 I = 1, N
                  WORK( I ) = ZERO
  180          CONTINUE
               DO 200 J = 1, N
                  DO 190 I = 1, J
                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
                     K = K + 1
  190             CONTINUE
  200          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 210 I = 1, N
                  WORK( I ) = ONE
  210          CONTINUE
               DO 230 J = 1, N
                  K = K + 1
                  DO 220 I = J + 1, N
                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
                     K = K + 1
  220             CONTINUE
  230          CONTINUE
            ELSE
               DO 240 I = 1, N
                  WORK( I ) = ZERO
  240          CONTINUE
               DO 260 J = 1, N
                  DO 250 I = J, N
                     WORK( I ) = WORK( I ) + ABS( AP( K ) )
                     K = K + 1
  250             CONTINUE
  260          CONTINUE
            END IF
         END IF
         VALUE = ZERO
         DO 270 I = 1, N
            VALUE = MAX( VALUE, WORK( I ) )
  270    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = N
               K = 2
               DO 280 J = 2, N
                  CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
                  K = K + J
  280          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               K = 1
               DO 290 J = 1, N
                  CALL DLASSQ( J, AP( K ), 1, SCALE, SUM )
                  K = K + J
  290          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = N
               K = 2
               DO 300 J = 1, N - 1
                  CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
                  K = K + N - J + 1
  300          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               K = 1
               DO 310 J = 1, N
                  CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
                  K = K + N - J + 1
  310          CONTINUE
            END IF
         END IF
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANTP = VALUE
      RETURN
!
!     End of DLANTP
!
      END
      DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, &
                       WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLANTR  returns the value of the one norm,  or the Frobenius norm, or
!  the  infinity norm,  or the  element of  largest absolute value  of a
!  trapezoidal or triangular matrix A.
!
!  Description
!  ===========
!
!  DLANTR returns the value
!
!     DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in DLANTR as described
!          above.
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower trapezoidal.
!          = 'U':  Upper trapezoidal
!          = 'L':  Lower trapezoidal
!          Note that A is triangular instead of trapezoidal if M = N.
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A has unit diagonal.
!          = 'N':  Non-unit diagonal
!          = 'U':  Unit diagonal
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0, and if
!          UPLO = 'U', M <= N.  When M = 0, DLANTR is set to zero.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0, and if
!          UPLO = 'L', N <= M.  When N = 0, DLANTR is set to zero.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The trapezoidal matrix A (A is triangular if M = N).
!          If UPLO = 'U', the leading m by n upper trapezoidal part of
!          the array A contains the upper trapezoidal matrix, and the
!          strictly lower triangular part of A is not referenced.
!          If UPLO = 'L', the leading m by n lower trapezoidal part of
!          the array A contains the lower trapezoidal matrix, and the
!          strictly upper triangular part of A is not referenced.  Note
!          that when DIAG = 'U', the diagonal elements of A are not
!          referenced and are assumed to be one.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(M,1).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
!          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
!          referenced.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UDIAG
      INTEGER            I, J
      DOUBLE PRECISION   SCALE, SUM, VALUE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASSQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( MIN( M, N ).EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
!
!        Find max(abs(A(i,j))).
!
         IF( LSAME( DIAG, 'U' ) ) THEN
            VALUE = ONE
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 20 J = 1, N
                  DO 10 I = 1, MIN( M, J-1 )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J = 1, N
                  DO 30 I = J + 1, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            VALUE = ZERO
            IF( LSAME( UPLO, 'U' ) ) THEN
               DO 60 J = 1, N
                  DO 50 I = 1, MIN( M, J )
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80 J = 1, N
                  DO 70 I = J, M
                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
!
!        Find norm1(A).
!
         VALUE = ZERO
         UDIAG = LSAME( DIAG, 'U' )
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 1, N
               IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
                  SUM = ONE
                  DO 90 I = 1, J - 1
                     SUM = SUM + ABS( A( I, J ) )
   90             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 100 I = 1, MIN( M, J )
                     SUM = SUM + ABS( A( I, J ) )
  100             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  110       CONTINUE
         ELSE
            DO 140 J = 1, N
               IF( UDIAG ) THEN
                  SUM = ONE
                  DO 120 I = J + 1, M
                     SUM = SUM + ABS( A( I, J ) )
  120             CONTINUE
               ELSE
                  SUM = ZERO
                  DO 130 I = J, M
                     SUM = SUM + ABS( A( I, J ) )
  130             CONTINUE
               END IF
               VALUE = MAX( VALUE, SUM )
  140       CONTINUE
         END IF
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
!
!        Find normI(A).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 150 I = 1, M
                  WORK( I ) = ONE
  150          CONTINUE
               DO 170 J = 1, N
                  DO 160 I = 1, MIN( M, J-1 )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  160             CONTINUE
  170          CONTINUE
            ELSE
               DO 180 I = 1, M
                  WORK( I ) = ZERO
  180          CONTINUE
               DO 200 J = 1, N
                  DO 190 I = 1, MIN( M, J )
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  190             CONTINUE
  200          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               DO 210 I = 1, N
                  WORK( I ) = ONE
  210          CONTINUE
               DO 220 I = N + 1, M
                  WORK( I ) = ZERO
  220          CONTINUE
               DO 240 J = 1, N
                  DO 230 I = J + 1, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  230             CONTINUE
  240          CONTINUE
            ELSE
               DO 250 I = 1, M
                  WORK( I ) = ZERO
  250          CONTINUE
               DO 270 J = 1, N
                  DO 260 I = J, M
                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
  260             CONTINUE
  270          CONTINUE
            END IF
         END IF
         VALUE = ZERO
         DO 280 I = 1, M
            VALUE = MAX( VALUE, WORK( I ) )
  280    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
!
!        Find normF(A).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 290 J = 2, N
                  CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
  290          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 300 J = 1, N
                  CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
  300          CONTINUE
            END IF
         ELSE
            IF( LSAME( DIAG, 'U' ) ) THEN
               SCALE = ONE
               SUM = MIN( M, N )
               DO 310 J = 1, N
                  CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, &
                               SUM )
  310          CONTINUE
            ELSE
               SCALE = ZERO
               SUM = ONE
               DO 320 J = 1, N
                  CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
  320          CONTINUE
            END IF
         END IF
         VALUE = SCALE*SQRT( SUM )
      END IF
!
      DLANTR = VALUE
      RETURN
!
!     End of DLANTR
!
      END
      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
!     ..
!
!  Purpose
!  =======
!
!  DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
!  matrix in standard form:
!
!       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
!       [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
!
!  where either
!  1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!  2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!  conjugate eigenvalues.
!
!  Arguments
!  =========
!
!  A       (input/output) DOUBLE PRECISION
!  B       (input/output) DOUBLE PRECISION
!  C       (input/output) DOUBLE PRECISION
!  D       (input/output) DOUBLE PRECISION
!          On entry, the elements of the input matrix.
!          On exit, they are overwritten by the elements of the
!          standardised Schur form.
!
!  RT1R    (output) DOUBLE PRECISION
!  RT1I    (output) DOUBLE PRECISION
!  RT2R    (output) DOUBLE PRECISION
!  RT2I    (output) DOUBLE PRECISION
!          The real and imaginary parts of the eigenvalues. If the
!          eigenvalues are a complex conjugate pair, RT1I > 0.
!
!  CS      (output) DOUBLE PRECISION
!  SN      (output) DOUBLE PRECISION
!          Parameters of the rotation matrix.
!
!  Further Details
!  ===============
!
!  Modified by V. Sima, Research Institute for Informatics, Bucharest,
!  Romania, to reduce the risk of cancellation errors,
!  when computing real eigenvalues, and to ensure, if possible, that
!  abs(RT1R) >= abs(RT2R).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   MULTPL
      PARAMETER          ( MULTPL = 4.0D+0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB, &
                         SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
      EPS = DLAMCH( 'P' )
      IF( C.EQ.ZERO ) THEN
         CS = ONE
         SN = ZERO
         GO TO 10
!
      ELSE IF( B.EQ.ZERO ) THEN
!
!        Swap rows and columns
!
         CS = ZERO
         SN = ONE
         TEMP = D
         D = A
         A = TEMP
         B = -C
         C = ZERO
         GO TO 10
      ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) ) &
                THEN
         CS = ONE
         SN = ZERO
         GO TO 10
      ELSE
!
         TEMP = A - D
         P = HALF*TEMP
         BCMAX = MAX( ABS( B ), ABS( C ) )
         BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
         SCALE = MAX( ABS( P ), BCMAX )
         Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
!
!        If Z is of the order of the machine accuracy, postpone the
!        decision on the nature of eigenvalues
!
         IF( Z.GE.MULTPL*EPS ) THEN
!
!           Real eigenvalues. Compute A and D.
!
            Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
            A = D + Z
            D = D - ( BCMAX / Z )*BCMIS
!
!           Compute B and the rotation matrix
!
            TAU = DLAPY2( C, Z )
            CS = Z / TAU
            SN = C / TAU
            B = B - C
            C = ZERO
         ELSE
!
!           Complex eigenvalues, or real (almost) equal eigenvalues.
!           Make diagonal elements equal.
!
            SIGMA = B + C
            TAU = DLAPY2( SIGMA, TEMP )
            CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
            SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
!
!           Compute [ AA  BB ] = [ A  B ] [ CS -SN ]
!                   [ CC  DD ]   [ C  D ] [ SN  CS ]
!
            AA = A*CS + B*SN
            BB = -A*SN + B*CS
            CC = C*CS + D*SN
            DD = -C*SN + D*CS
!
!           Compute [ A  B ] = [ CS  SN ] [ AA  BB ]
!                   [ C  D ]   [-SN  CS ] [ CC  DD ]
!
            A = AA*CS + CC*SN
            B = BB*CS + DD*SN
            C = -AA*SN + CC*CS
            D = -BB*SN + DD*CS
!
            TEMP = HALF*( A+D )
            A = TEMP
            D = TEMP
!
            IF( C.NE.ZERO ) THEN
               IF( B.NE.ZERO ) THEN
                  IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
!
!                    Real eigenvalues: reduce to upper triangular form
!
                     SAB = SQRT( ABS( B ) )
                     SAC = SQRT( ABS( C ) )
                     P = SIGN( SAB*SAC, C )
                     TAU = ONE / SQRT( ABS( B+C ) )
                     A = TEMP + P
                     D = TEMP - P
                     B = B - C
                     C = ZERO
                     CS1 = SAB*TAU
                     SN1 = SAC*TAU
                     TEMP = CS*CS1 - SN*SN1
                     SN = CS*SN1 + SN*CS1
                     CS = TEMP
                  END IF
               ELSE
                  B = -C
                  C = ZERO
                  TEMP = CS
                  CS = -SN
                  SN = TEMP
               END IF
            END IF
         END IF
!
      END IF
!
   10 CONTINUE
!
!     Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
!
      RT1R = A
      RT2R = D
      IF( C.EQ.ZERO ) THEN
         RT1I = ZERO
         RT2I = ZERO
      ELSE
         RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
         RT2I = -RT1I
      END IF
      RETURN
!
!     End of DLANV2
!
      END
      SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      DOUBLE PRECISION   SSMIN
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  Given two column vectors X and Y, let
!
!                       A = ( X Y ).
!
!  The subroutine first computes the QR factorization of A = Q*R,
!  and then computes the SVD of the 2-by-2 upper triangular matrix R.
!  The smaller singular value of R is returned in SSMIN, which is used
!  as the measurement of the linear dependency of the vectors X and Y.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The length of the vectors X and Y.
!
!  X       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          On entry, X contains the N-vector X.
!          On exit, X is overwritten.
!
!  INCX    (input) INTEGER
!          The increment between successive elements of X. INCX > 0.
!
!  Y       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCY)
!          On entry, Y contains the N-vector Y.
!          On exit, Y is overwritten.
!
!  INCY    (input) INTEGER
!          The increment between successive elements of Y. INCY > 0.
!
!  SSMIN   (output) DOUBLE PRECISION
!          The smallest singular value of the N-by-2 matrix A = ( X Y ).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   A11, A12, A22, C, SSMAX, TAU
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DLARFG, DLAS2
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.1 ) THEN
         SSMIN = ZERO
         RETURN
      END IF
!
!     Compute the QR factorization of the N-by-2 matrix ( X Y )
!
      CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
      A11 = X( 1 )
      X( 1 ) = ONE
!
      C = -TAU*DDOT( N, X, INCX, Y, INCY )
      CALL DAXPY( N, C, X, INCX, Y, INCY )
!
      CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
!
      A12 = Y( 1 )
      A22 = Y( 1+INCY )
!
!     Compute the SVD of 2-by-2 Upper triangular matrix.
!
      CALL DLAS2( A11, A12, A22, SSMIN, SSMAX )
!
      RETURN
!
!     End of DLAPLL
!
      END
      SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      LOGICAL            FORWRD
      INTEGER            LDX, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            K( * )
      DOUBLE PRECISION   X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAPMT rearranges the columns of the M by N matrix X as specified
!  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
!  If FORWRD = .TRUE.,  forward permutation:
!
!       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
!
!  If FORWRD = .FALSE., backward permutation:
!
!       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
!
!  Arguments
!  =========
!
!  FORWRD  (input) LOGICAL
!          = .TRUE., forward permutation
!          = .FALSE., backward permutation
!
!  M       (input) INTEGER
!          The number of rows of the matrix X. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix X. N >= 0.
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
!          On entry, the M by N matrix X.
!          On exit, X contains the permuted matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X, LDX >= MAX(1,M).
!
!  K       (input) INTEGER array, dimension (N)
!          On entry, K contains the permutation vector.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, II, IN, J
      DOUBLE PRECISION   TEMP
!     ..
!     .. Executable Statements ..
!
      IF( N.LE.1 ) &
         RETURN
!
      DO 10 I = 1, N
         K( I ) = -K( I )
   10 CONTINUE
!
      IF( FORWRD ) THEN
!
!        Forward permutation
!
         DO 50 I = 1, N
!
            IF( K( I ).GT.0 ) &
               GO TO 40
!
            J = I
            K( J ) = -K( J )
            IN = K( J )
!
   20       CONTINUE
            IF( K( IN ).GT.0 ) &
               GO TO 40
!
            DO 30 II = 1, M
               TEMP = X( II, J )
               X( II, J ) = X( II, IN )
               X( II, IN ) = TEMP
   30       CONTINUE
!
            K( IN ) = -K( IN )
            J = IN
            IN = K( IN )
            GO TO 20
!
   40       CONTINUE
!
   50    CONTINUE
!
      ELSE
!
!        Backward permutation
!
         DO 90 I = 1, N
!
            IF( K( I ).GT.0 ) &
               GO TO 80
!
            K( I ) = -K( I )
            J = K( I )
   60       CONTINUE
            IF( J.EQ.I ) &
               GO TO 80
!
            DO 70 II = 1, M
               TEMP = X( II, I )
               X( II, I ) = X( II, J )
               X( II, J ) = TEMP
   70       CONTINUE
!
            K( J ) = -K( J )
            J = K( J )
            GO TO 60
!
   80       CONTINUE
!
   90    CONTINUE
!
      END IF
!
      RETURN
!
!     End of DLAPMT
!
      END
      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
!     ..
!
!  Purpose
!  =======
!
!  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
!  overflow.
!
!  Arguments
!  =========
!
!  X       (input) DOUBLE PRECISION
!  Y       (input) DOUBLE PRECISION
!          X and Y specify the values x and y.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, Z
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      XABS = ABS( X )
      YABS = ABS( Y )
      W = MAX( XABS, YABS )
      Z = MIN( XABS, YABS )
      IF( Z.EQ.ZERO ) THEN
         DLAPY2 = W
      ELSE
         DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
      END IF
      RETURN
!
!     End of DLAPY2
!
      END
      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y, Z
!     ..
!
!  Purpose
!  =======
!
!  DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
!  unnecessary overflow.
!
!  Arguments
!  =========
!
!  X       (input) DOUBLE PRECISION
!  Y       (input) DOUBLE PRECISION
!  Z       (input) DOUBLE PRECISION
!          X, Y and Z specify the values x, y and z.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, ZABS
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      XABS = ABS( X )
      YABS = ABS( Y )
      ZABS = ABS( Z )
      W = MAX( XABS, YABS, ZABS )
      IF( W.EQ.ZERO ) THEN
         DLAPY3 = ZERO
      ELSE
         DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ &
                  ( ZABS / W )**2 )
      END IF
      RETURN
!
!     End of DLAPY3
!
      END
      SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, &
                         AMAX, EQUED )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED
      INTEGER            KL, KU, LDAB, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), C( * ), R( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQGB equilibrates a general M by N band matrix A with KL
!  subdiagonals and KU superdiagonals using the row and scaling factors
!  in the vectors R and C.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, the equilibrated matrix, in the same storage format
!          as A.  See EQUED for the form of the equilibrated matrix.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDA >= KL+KU+1.
!
!  R       (output) DOUBLE PRECISION array, dimension (M)
!          The row scale factors for A.
!
!  C       (output) DOUBLE PRECISION array, dimension (N)
!          The column scale factors for A.
!
!  ROWCND  (output) DOUBLE PRECISION
!          Ratio of the smallest R(i) to the largest R(i).
!
!  COLCND  (output) DOUBLE PRECISION
!          Ratio of the smallest C(i) to the largest C(i).
!
!  AMAX    (input) DOUBLE PRECISION
!          Absolute value of largest matrix entry.
!
!  EQUED   (output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration
!          = 'R':  Row equilibration, i.e., A has been premultiplied by
!                  diag(R).
!          = 'C':  Column equilibration, i.e., A has been postmultiplied
!                  by diag(C).
!          = 'B':  Both row and column equilibration, i.e., A has been
!                  replaced by diag(R) * A * diag(C).
!
!  Internal Parameters
!  ===================
!
!  THRESH is a threshold value used to decide if row or column scaling
!  should be done based on the ratio of the row or column scaling
!  factors.  If ROWCND < THRESH, row scaling is done, and if
!  COLCND < THRESH, column scaling is done.
!
!  LARGE and SMALL are threshold values used to decide if row scaling
!  should be done based on the absolute size of the largest matrix
!  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, THRESH
      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   CJ, LARGE, SMALL
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( M.LE.0 .OR. N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
!
!     Initialize LARGE and SMALL.
!
      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      LARGE = ONE / SMALL
!
      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) &
           THEN
!
!        No row scaling
!
         IF( COLCND.GE.THRESH ) THEN
!
!           No column scaling
!
            EQUED = 'N'
         ELSE
!
!           Column scaling
!
            DO 20 J = 1, N
               CJ = C( J )
               DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
                  AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
   10          CONTINUE
   20       CONTINUE
            EQUED = 'C'
         END IF
      ELSE IF( COLCND.GE.THRESH ) THEN
!
!        Row scaling, no column scaling
!
         DO 40 J = 1, N
            DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
               AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
   30       CONTINUE
   40    CONTINUE
         EQUED = 'R'
      ELSE
!
!        Row and column scaling
!
         DO 60 J = 1, N
            CJ = C( J )
            DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
               AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
   50       CONTINUE
   60    CONTINUE
         EQUED = 'B'
      END IF
!
      RETURN
!
!     End of DLAQGB
!
      END
      SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, &
                         EQUED )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED
      INTEGER            LDA, M, N
      DOUBLE PRECISION   AMAX, COLCND, ROWCND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), R( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQGE equilibrates a general M by N matrix A using the row and
!  scaling factors in the vectors R and C.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M by N matrix A.
!          On exit, the equilibrated matrix.  See EQUED for the form of
!          the equilibrated matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(M,1).
!
!  R       (input) DOUBLE PRECISION array, dimension (M)
!          The row scale factors for A.
!
!  C       (input) DOUBLE PRECISION array, dimension (N)
!          The column scale factors for A.
!
!  ROWCND  (input) DOUBLE PRECISION
!          Ratio of the smallest R(i) to the largest R(i).
!
!  COLCND  (input) DOUBLE PRECISION
!          Ratio of the smallest C(i) to the largest C(i).
!
!  AMAX    (input) DOUBLE PRECISION
!          Absolute value of largest matrix entry.
!
!  EQUED   (output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration
!          = 'R':  Row equilibration, i.e., A has been premultiplied by
!                  diag(R).
!          = 'C':  Column equilibration, i.e., A has been postmultiplied
!                  by diag(C).
!          = 'B':  Both row and column equilibration, i.e., A has been
!                  replaced by diag(R) * A * diag(C).
!
!  Internal Parameters
!  ===================
!
!  THRESH is a threshold value used to decide if row or column scaling
!  should be done based on the ratio of the row or column scaling
!  factors.  If ROWCND < THRESH, row scaling is done, and if
!  COLCND < THRESH, column scaling is done.
!
!  LARGE and SMALL are threshold values used to decide if row scaling
!  should be done based on the absolute size of the largest matrix
!  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, THRESH
      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   CJ, LARGE, SMALL
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( M.LE.0 .OR. N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
!
!     Initialize LARGE and SMALL.
!
      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      LARGE = ONE / SMALL
!
      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) &
           THEN
!
!        No row scaling
!
         IF( COLCND.GE.THRESH ) THEN
!
!           No column scaling
!
            EQUED = 'N'
         ELSE
!
!           Column scaling
!
            DO 20 J = 1, N
               CJ = C( J )
               DO 10 I = 1, M
                  A( I, J ) = CJ*A( I, J )
   10          CONTINUE
   20       CONTINUE
            EQUED = 'C'
         END IF
      ELSE IF( COLCND.GE.THRESH ) THEN
!
!        Row scaling, no column scaling
!
         DO 40 J = 1, N
            DO 30 I = 1, M
               A( I, J ) = R( I )*A( I, J )
   30       CONTINUE
   40    CONTINUE
         EQUED = 'R'
      ELSE
!
!        Row and column scaling
!
         DO 60 J = 1, N
            CJ = C( J )
            DO 50 I = 1, M
               A( I, J ) = CJ*R( I )*A( I, J )
   50       CONTINUE
   60    CONTINUE
         EQUED = 'B'
      END IF
!
      RETURN
!
!     End of DLAQGE
!
      END
      SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, &
                         WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            LDA, M, N, OFFSET
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQP2 computes a QR factorization with column pivoting of
!  the block A(OFFSET+1:M,1:N).
!  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A. N >= 0.
!
!  OFFSET  (input) INTEGER
!          The number of rows of the matrix A that must be pivoted
!          but no factorized. OFFSET >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
!          the triangular factor obtained; the elements in block
!          A(OFFSET+1:M,1:N) below the diagonal, together with the
!          array TAU, represent the orthogonal matrix Q as a product of
!          elementary reflectors. Block A(1:OFFSET,1:N) has been
!          accordingly pivoted, but no factorized.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!          to the front of A*P (a leading column); if JPVT(i) = 0,
!          the i-th column of A is a free column.
!          On exit, if JPVT(i) = k, then the i-th column of A*P
!          was the k-th column of A.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
!          The scalar factors of the elementary reflectors.
!
!  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
!          The vector with the partial column norms.
!
!  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
!          The vector with the exact column norms.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
!    X. Sun, Computer Science Dept., Duke University, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
      DOUBLE PRECISION   AII, TEMP, TEMP2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, DSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DNRM2
      EXTERNAL           IDAMAX, DNRM2
!     ..
!     .. Executable Statements ..
!
      MN = MIN( M-OFFSET, N )
!
!     Compute factorization.
!
      DO 20 I = 1, MN
!
         OFFPI = OFFSET + I
!
!        Determine ith pivot column and swap if necessary.
!
         PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
!
         IF( PVT.NE.I ) THEN
            CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( I )
            JPVT( I ) = ITEMP
            VN1( PVT ) = VN1( I )
            VN2( PVT ) = VN2( I )
         END IF
!
!        Generate elementary reflector H(i).
!
         IF( OFFPI.LT.M ) THEN
            CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, &
                         TAU( I ) )
         ELSE
            CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
         END IF
!
         IF( I.LT.N ) THEN
!
!           Apply H(i)' to A(offset+i:m,i+1:n) from the left.
!
            AII = A( OFFPI, I )
            A( OFFPI, I ) = ONE
            CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, &
                        TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
            A( OFFPI, I ) = AII
         END IF
!
!        Update partial column norms.
!
         DO 10 J = I + 1, N
            IF( VN1( J ).NE.ZERO ) THEN
               TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
               TEMP = MAX( TEMP, ZERO )
               TEMP2 = ONE + 0.05D0*TEMP*( VN1( J ) / VN2( J ) )**2
               IF( TEMP2.EQ.ONE ) THEN
                  IF( OFFPI.LT.M ) THEN
                     VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
                     VN2( J ) = VN1( J )
                  ELSE
                     VN1( J ) = ZERO
                     VN2( J ) = ZERO
                  END IF
               ELSE
                  VN1( J ) = VN1( J )*SQRT( TEMP )
               END IF
            END IF
   10    CONTINUE
!
   20 CONTINUE
!
      RETURN
!
!     End of DLAQP2
!
      END
      SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, &
                         VN2, AUXV, F, LDF )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
!     ..
!     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), &
                         VN1( * ), VN2( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQPS computes a step of QR factorization with column pivoting
!  of a real M-by-N matrix A by using Blas-3.  It tries to factorize
!  NB columns from A starting from the row OFFSET+1, and updates all
!  of the matrix with Blas-3 xGEMM.
!
!  In some cases, due to catastrophic cancellations, it cannot
!  factorize NB columns.  Hence, the actual number of factorized
!  columns is returned in KB.
!
!  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A. N >= 0
!
!  OFFSET  (input) INTEGER
!          The number of rows of A that have been factorized in
!          previous steps.
!
!  NB      (input) INTEGER
!          The number of columns to factorize.
!
!  KB      (output) INTEGER
!          The number of columns actually factorized.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, block A(OFFSET+1:M,1:KB) is the triangular
!          factor obtained and block A(1:OFFSET,1:N) has been
!          accordingly pivoted, but no factorized.
!          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
!          been updated.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  JPVT    (input/output) INTEGER array, dimension (N)
!          JPVT(I) = K <==> Column K of the full matrix A has been
!          permuted into position I in AP.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (KB)
!          The scalar factors of the elementary reflectors.
!
!  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
!          The vector with the partial column norms.
!
!  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
!          The vector with the exact column norms.
!
!  AUXV    (input/output) DOUBLE PRECISION array, dimension (NB)
!          Auxiliar vector.
!
!  F       (input/output) DOUBLE PRECISION array, dimension (LDF,NB)
!          Matrix F' = L*Y'*A.
!
!  LDF     (input) INTEGER
!          The leading dimension of the array F. LDF >= max(1,N).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
!    X. Sun, Computer Science Dept., Duke University, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
      DOUBLE PRECISION   AKK, TEMP, TEMP2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DLARFG, DSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, NINT, SQRT
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DNRM2
      EXTERNAL           IDAMAX, DNRM2
!     ..
!     .. Executable Statements ..
!
      LASTRK = MIN( M, N+OFFSET )
      LSTICC = 0
      K = 0
!
!     Beginning of while loop.
!
   10 CONTINUE
      IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
         K = K + 1
         RK = OFFSET + K
!
!        Determine ith pivot column and swap if necessary
!
         PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
         IF( PVT.NE.K ) THEN
            CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
            CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( K )
            JPVT( K ) = ITEMP
            VN1( PVT ) = VN1( K )
            VN2( PVT ) = VN2( K )
         END IF
!
!        Apply previous Householder reflectors to column K:
!        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'.
!
         IF( K.GT.1 ) THEN
            CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), &
                        LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 )
         END IF
!
!        Generate elementary reflector H(k).
!
         IF( RK.LT.M ) THEN
            CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
         ELSE
            CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
         END IF
!
         AKK = A( RK, K )
         A( RK, K ) = ONE
!
!        Compute Kth column of F:
!
!        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K).
!
         IF( K.LT.N ) THEN
            CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), &
                        A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO, &
                        F( K+1, K ), 1 )
         END IF
!
!        Padding F(1:K,K) with zeros.
!
         DO 20 J = 1, K
            F( J, K ) = ZERO
   20    CONTINUE
!
!        Incremental updating of F:
!        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
!                    *A(RK:M,K).
!
         IF( K.GT.1 ) THEN
            CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ), &
                        LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
!
            CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF, &
                        AUXV( 1 ), 1, ONE, F( 1, K ), 1 )
         END IF
!
!        Update the current row of A:
!        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'.
!
         IF( K.LT.N ) THEN
            CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, &
                        A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA )
         END IF
!
!        Update partial column norms.
!
         IF( RK.LT.LASTRK ) THEN
            DO 30 J = K + 1, N
               IF( VN1( J ).NE.ZERO ) THEN
                  TEMP = ABS( A( RK, J ) ) / VN1( J )
                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
                  TEMP2 = ONE + 0.05D0*TEMP*( VN1( J ) / VN2( J ) )**2
                  IF( TEMP2.EQ.ONE ) THEN
                     VN2( J ) = DBLE( LSTICC )
                     LSTICC = J
                  ELSE
                     VN1( J ) = VN1( J )*SQRT( TEMP )
                  END IF
               END IF
   30       CONTINUE
         END IF
!
         A( RK, K ) = AKK
!
!        End of while loop.
!
         GO TO 10
      END IF
      KB = K
      RK = OFFSET + KB
!
!     Apply the block reflector to the rest of the matrix:
!     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
!                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
!
      IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
         CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, &
                     A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, &
                     A( RK+1, KB+1 ), LDA )
      END IF
!
!     Recomputation of difficult columns.
!
   40 CONTINUE
      IF( LSTICC.GT.0 ) THEN
         ITEMP = NINT( VN2( LSTICC ) )
         VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 )
         VN2( LSTICC ) = VN1( LSTICC )
         LSTICC = ITEMP
         GO TO 40
      END IF
!
      RETURN
!
!     End of DLAQPS
!
      END
      SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, UPLO
      INTEGER            KD, LDAB, N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQSB equilibrates a symmetric band matrix A using the scaling
!  factors in the vector S.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of super-diagonals of the matrix A if UPLO = 'U',
!          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, if INFO = 0, the triangular factor U or L from the
!          Cholesky factorization A = U'*U or A = L*L' of the band
!          matrix A, in the same storage format as A.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  S       (output) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A.
!
!  SCOND   (input) DOUBLE PRECISION
!          Ratio of the smallest S(i) to the largest S(i).
!
!  AMAX    (input) DOUBLE PRECISION
!          Absolute value of largest matrix entry.
!
!  EQUED   (output) CHARACTER*1
!          Specifies whether or not equilibration was done.
!          = 'N':  No equilibration.
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!
!  Internal Parameters
!  ===================
!
!  THRESH is a threshold value used to decide if scaling should be done
!  based on the ratio of the scaling factors.  If SCOND < THRESH,
!  scaling is done.
!
!  LARGE and SMALL are threshold values used to decide if scaling should
!  be done based on the absolute size of the largest matrix element.
!  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, THRESH
      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   CJ, LARGE, SMALL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
!
!     Initialize LARGE and SMALL.
!
      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      LARGE = ONE / SMALL
!
      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
!
!        No equilibration
!
         EQUED = 'N'
      ELSE
!
!        Replace A by diag(S) * A * diag(S).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
!
!           Upper triangle of A is stored in band format.
!
            DO 20 J = 1, N
               CJ = S( J )
               DO 10 I = MAX( 1, J-KD ), J
                  AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
   10          CONTINUE
   20       CONTINUE
         ELSE
!
!           Lower triangle of A is stored.
!
            DO 40 J = 1, N
               CJ = S( J )
               DO 30 I = J, MIN( N, J+KD )
                  AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         EQUED = 'Y'
      END IF
!
      RETURN
!
!     End of DLAQSB
!
      END
      SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, UPLO
      INTEGER            N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQSP equilibrates a symmetric matrix A using the scaling factors
!  in the vector S.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
!          the same storage format as A.
!
!  S       (input) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A.
!
!  SCOND   (input) DOUBLE PRECISION
!          Ratio of the smallest S(i) to the largest S(i).
!
!  AMAX    (input) DOUBLE PRECISION
!          Absolute value of largest matrix entry.
!
!  EQUED   (output) CHARACTER*1
!          Specifies whether or not equilibration was done.
!          = 'N':  No equilibration.
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!
!  Internal Parameters
!  ===================
!
!  THRESH is a threshold value used to decide if scaling should be done
!  based on the ratio of the scaling factors.  If SCOND < THRESH,
!  scaling is done.
!
!  LARGE and SMALL are threshold values used to decide if scaling should
!  be done based on the absolute size of the largest matrix element.
!  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, THRESH
      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, JC
      DOUBLE PRECISION   CJ, LARGE, SMALL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
!
!     Initialize LARGE and SMALL.
!
      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      LARGE = ONE / SMALL
!
      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
!
!        No equilibration
!
         EQUED = 'N'
      ELSE
!
!        Replace A by diag(S) * A * diag(S).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
!
!           Upper triangle of A is stored.
!
            JC = 1
            DO 20 J = 1, N
               CJ = S( J )
               DO 10 I = 1, J
                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
   10          CONTINUE
               JC = JC + J
   20       CONTINUE
         ELSE
!
!           Lower triangle of A is stored.
!
            JC = 1
            DO 40 J = 1, N
               CJ = S( J )
               DO 30 I = J, N
                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
   30          CONTINUE
               JC = JC + N - J + 1
   40       CONTINUE
         END IF
         EQUED = 'Y'
      END IF
!
      RETURN
!
!     End of DLAQSP
!
      END
      SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, UPLO
      INTEGER            LDA, N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQSY equilibrates a symmetric matrix A using the scaling factors
!  in the vector S.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n by n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n by n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if EQUED = 'Y', the equilibrated matrix:
!          diag(S) * A * diag(S).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(N,1).
!
!  S       (input) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A.
!
!  SCOND   (input) DOUBLE PRECISION
!          Ratio of the smallest S(i) to the largest S(i).
!
!  AMAX    (input) DOUBLE PRECISION
!          Absolute value of largest matrix entry.
!
!  EQUED   (output) CHARACTER*1
!          Specifies whether or not equilibration was done.
!          = 'N':  No equilibration.
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!
!  Internal Parameters
!  ===================
!
!  THRESH is a threshold value used to decide if scaling should be done
!  based on the ratio of the scaling factors.  If SCOND < THRESH,
!  scaling is done.
!
!  LARGE and SMALL are threshold values used to decide if scaling should
!  be done based on the absolute size of the largest matrix element.
!  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, THRESH
      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   CJ, LARGE, SMALL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
!
!     Initialize LARGE and SMALL.
!
      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      LARGE = ONE / SMALL
!
      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
!
!        No equilibration
!
         EQUED = 'N'
      ELSE
!
!        Replace A by diag(S) * A * diag(S).
!
         IF( LSAME( UPLO, 'U' ) ) THEN
!
!           Upper triangle of A is stored.
!
            DO 20 J = 1, N
               CJ = S( J )
               DO 10 I = 1, J
                  A( I, J ) = CJ*S( I )*A( I, J )
   10          CONTINUE
   20       CONTINUE
         ELSE
!
!           Lower triangle of A is stored.
!
            DO 40 J = 1, N
               CJ = S( J )
               DO 30 I = J, N
                  A( I, J ) = CJ*S( I )*A( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         EQUED = 'Y'
      END IF
!
      RETURN
!
!     End of DLAQSY
!
      END
      SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, &
                         INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            LREAL, LTRAN
      INTEGER            INFO, LDT, N
      DOUBLE PRECISION   SCALE, W
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( * ), T( LDT, * ), WORK( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAQTR solves the real quasi-triangular system
!
!               op(T)*p = scale*c,               if LREAL = .TRUE.
!
!  or the complex quasi-triangular systems
!
!             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.
!
!  in real arithmetic, where T is upper quasi-triangular.
!  If LREAL = .FALSE., then the first diagonal block of T must be
!  1 by 1, B is the specially structured matrix
!
!                 B = [ b(1) b(2) ... b(n) ]
!                     [       w            ]
!                     [           w        ]
!                     [              .     ]
!                     [                 w  ]
!
!  op(A) = A or A', A' denotes the conjugate transpose of
!  matrix A.
!
!  On input, X = [ c ].  On output, X = [ p ].
!                [ d ]                  [ q ]
!
!  This subroutine is designed for the condition number estimation
!  in routine DTRSNA.
!
!  Arguments
!  =========
!
!  LTRAN   (input) LOGICAL
!          On entry, LTRAN specifies the option of conjugate transpose:
!             = .FALSE.,    op(T+i*B) = T+i*B,
!             = .TRUE.,     op(T+i*B) = (T+i*B)'.
!
!  LREAL   (input) LOGICAL
!          On entry, LREAL specifies the input matrix structure:
!             = .FALSE.,    the input is complex
!             = .TRUE.,     the input is real
!
!  N       (input) INTEGER
!          On entry, N specifies the order of T+i*B. N >= 0.
!
!  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
!          On entry, T contains a matrix in Schur canonical form.
!          If LREAL = .FALSE., then the first diagonal block of T mu
!          be 1 by 1.
!
!  LDT     (input) INTEGER
!          The leading dimension of the matrix T. LDT >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (N)
!          On entry, B contains the elements to form the matrix
!          B as described above.
!          If LREAL = .TRUE., B is not referenced.
!
!  W       (input) DOUBLE PRECISION
!          On entry, W is the diagonal element of the matrix B.
!          If LREAL = .TRUE., W is not referenced.
!
!  SCALE   (output) DOUBLE PRECISION
!          On exit, SCALE is the scale factor.
!
!  X       (input/output) DOUBLE PRECISION array, dimension (2*N)
!          On entry, X contains the right hand side of the system.
!          On exit, X is overwritten by the solution.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          On exit, INFO is set to
!             0: successful exit.
!               1: the some diagonal 1 by 1 block has been perturbed by
!                  a small number SMIN to keep nonsingularity.
!               2: the some diagonal 2 by 2 block has been perturbed by
!                  a small number in DLALN2 to keep nonsingularity.
!          NOTE: In the interests of speed, this routine does not
!                check the inputs for errors.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      INTEGER            I, IERR, J, J1, J2, JNEXT, K, N1, N2
      DOUBLE PRECISION   BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW, &
                         SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   D( 2, 2 ), V( 2, 2 )
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH, DLANGE
      EXTERNAL           IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DLADIV, DLALN2, DSCAL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Do not test the input parameters for errors
!
      NOTRAN = .NOT.LTRAN
      INFO = 0
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Set constants to control overflow
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
!
      XNORM = DLANGE( 'M', N, N, T, LDT, D )
      IF( .NOT.LREAL ) &
         XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) )
      SMIN = MAX( SMLNUM, EPS*XNORM )
!
!     Compute 1-norm of each column of strictly upper triangular
!     part of T to control overflow in triangular solver.
!
      WORK( 1 ) = ZERO
      DO 10 J = 2, N
         WORK( J ) = DASUM( J-1, T( 1, J ), 1 )
   10 CONTINUE
!
      IF( .NOT.LREAL ) THEN
         DO 20 I = 2, N
            WORK( I ) = WORK( I ) + ABS( B( I ) )
   20    CONTINUE
      END IF
!
      N2 = 2*N
      N1 = N
      IF( .NOT.LREAL ) &
         N1 = N2
      K = IDAMAX( N1, X, 1 )
      XMAX = ABS( X( K ) )
      SCALE = ONE
!
      IF( XMAX.GT.BIGNUM ) THEN
         SCALE = BIGNUM / XMAX
         CALL DSCAL( N1, SCALE, X, 1 )
         XMAX = BIGNUM
      END IF
!
      IF( LREAL ) THEN
!
         IF( NOTRAN ) THEN
!
!           Solve T*p = scale*c
!
            JNEXT = N
            DO 30 J = N, 1, -1
               IF( J.GT.JNEXT ) &
                  GO TO 30
               J1 = J
               J2 = J
               JNEXT = J - 1
               IF( J.GT.1 ) THEN
                  IF( T( J, J-1 ).NE.ZERO ) THEN
                     J1 = J - 1
                     JNEXT = J - 2
                  END IF
               END IF
!
               IF( J1.EQ.J2 ) THEN
!
!                 Meet 1 by 1 diagonal block
!
!                 Scale to avoid overflow when computing
!                     x(j) = b(j)/T(j,j)
!
                  XJ = ABS( X( J1 ) )
                  TJJ = ABS( T( J1, J1 ) )
                  TMP = T( J1, J1 )
                  IF( TJJ.LT.SMIN ) THEN
                     TMP = SMIN
                     TJJ = SMIN
                     INFO = 1
                  END IF
!
                  IF( XJ.EQ.ZERO ) &
                     GO TO 30
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.BIGNUM*TJJ ) THEN
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J1 ) = X( J1 ) / TMP
                  XJ = ABS( X( J1 ) )
!
!                 Scale x if necessary to avoid overflow when adding a
!                 multiple of column j1 of T.
!
                  IF( XJ.GT.ONE ) THEN
                     REC = ONE / XJ
                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                     END IF
                  END IF
                  IF( J1.GT.1 ) THEN
                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
                     K = IDAMAX( J1-1, X, 1 )
                     XMAX = ABS( X( K ) )
                  END IF
!
               ELSE
!
!                 Meet 2 by 2 diagonal block
!
!                 Call 2 by 2 linear system solve, to take
!                 care of possible overflow by scaling factor.
!
                  D( 1, 1 ) = X( J1 )
                  D( 2, 1 ) = X( J2 )
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ), &
                               LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, &
                               SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 2
!
                  IF( SCALOC.NE.ONE ) THEN
                     CALL DSCAL( N, SCALOC, X, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  X( J1 ) = V( 1, 1 )
                  X( J2 ) = V( 2, 1 )
!
!                 Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
!                 to avoid overflow in updating right-hand side.
!
                  XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
                  IF( XJ.GT.ONE ) THEN
                     REC = ONE / XJ
                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. &
                         ( BIGNUM-XMAX )*REC ) THEN
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                     END IF
                  END IF
!
!                 Update right-hand side
!
                  IF( J1.GT.1 ) THEN
                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
                     CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
                     K = IDAMAX( J1-1, X, 1 )
                     XMAX = ABS( X( K ) )
                  END IF
!
               END IF
!
   30       CONTINUE
!
         ELSE
!
!           Solve T'*p = scale*c
!
            JNEXT = 1
            DO 40 J = 1, N
               IF( J.LT.JNEXT ) &
                  GO TO 40
               J1 = J
               J2 = J
               JNEXT = J + 1
               IF( J.LT.N ) THEN
                  IF( T( J+1, J ).NE.ZERO ) THEN
                     J2 = J + 1
                     JNEXT = J + 2
                  END IF
               END IF
!
               IF( J1.EQ.J2 ) THEN
!
!                 1 by 1 diagonal block
!
!                 Scale if necessary to avoid overflow in forming the
!                 right-hand side element by inner product.
!
                  XJ = ABS( X( J1 ) )
                  IF( XMAX.GT.ONE ) THEN
                     REC = ONE / XMAX
                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
!
                  X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
!
                  XJ = ABS( X( J1 ) )
                  TJJ = ABS( T( J1, J1 ) )
                  TMP = T( J1, J1 )
                  IF( TJJ.LT.SMIN ) THEN
                     TMP = SMIN
                     TJJ = SMIN
                     INFO = 1
                  END IF
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.BIGNUM*TJJ ) THEN
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J1 ) = X( J1 ) / TMP
                  XMAX = MAX( XMAX, ABS( X( J1 ) ) )
!
               ELSE
!
!                 2 by 2 diagonal block
!
!                 Scale if necessary to avoid overflow in forming the
!                 right-hand side elements by inner product.
!
                  XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
                  IF( XMAX.GT.ONE ) THEN
                     REC = ONE / XMAX
                     IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )* &
                         REC ) THEN
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
!
                  D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, &
                              1 )
                  D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, &
                              1 )
!
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ), &
                               LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2, &
                               SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 2
!
                  IF( SCALOC.NE.ONE ) THEN
                     CALL DSCAL( N, SCALOC, X, 1 )
                     SCALE = SCALE*SCALOC
                  END IF
                  X( J1 ) = V( 1, 1 )
                  X( J2 ) = V( 2, 1 )
                  XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
!
               END IF
   40       CONTINUE
         END IF
!
      ELSE
!
         SMINW = MAX( EPS*ABS( W ), SMIN )
         IF( NOTRAN ) THEN
!
!           Solve (T + iB)*(p+iq) = c+id
!
            JNEXT = N
            DO 70 J = N, 1, -1
               IF( J.GT.JNEXT ) &
                  GO TO 70
               J1 = J
               J2 = J
               JNEXT = J - 1
               IF( J.GT.1 ) THEN
                  IF( T( J, J-1 ).NE.ZERO ) THEN
                     J1 = J - 1
                     JNEXT = J - 2
                  END IF
               END IF
!
               IF( J1.EQ.J2 ) THEN
!
!                 1 by 1 diagonal block
!
!                 Scale if necessary to avoid overflow in division
!
                  Z = W
                  IF( J1.EQ.1 ) &
                     Z = B( 1 )
                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
                  TMP = T( J1, J1 )
                  IF( TJJ.LT.SMINW ) THEN
                     TMP = SMINW
                     TJJ = SMINW
                     INFO = 1
                  END IF
!
                  IF( XJ.EQ.ZERO ) &
                     GO TO 70
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.BIGNUM*TJJ ) THEN
                        REC = ONE / XJ
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
                  X( J1 ) = SR
                  X( N+J1 ) = SI
                  XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
!
!                 Scale x if necessary to avoid overflow when adding a
!                 multiple of column j1 of T.
!
                  IF( XJ.GT.ONE ) THEN
                     REC = ONE / XJ
                     IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                     END IF
                  END IF
!
                  IF( J1.GT.1 ) THEN
                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
                     CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, &
                                 X( N+1 ), 1 )
!
                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
!
                     XMAX = ZERO
                     DO 50 K = 1, J1 - 1
                        XMAX = MAX( XMAX, ABS( X( K ) )+ &
                               ABS( X( K+N ) ) )
   50                CONTINUE
                  END IF
!
               ELSE
!
!                 Meet 2 by 2 diagonal block
!
                  D( 1, 1 ) = X( J1 )
                  D( 2, 1 ) = X( J2 )
                  D( 1, 2 ) = X( N+J1 )
                  D( 2, 2 ) = X( N+J2 )
                  CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ), &
                               LDT, ONE, ONE, D, 2, ZERO, -W, V, 2, &
                               SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 2
!
                  IF( SCALOC.NE.ONE ) THEN
                     CALL DSCAL( 2*N, SCALOC, X, 1 )
                     SCALE = SCALOC*SCALE
                  END IF
                  X( J1 ) = V( 1, 1 )
                  X( J2 ) = V( 2, 1 )
                  X( N+J1 ) = V( 1, 2 )
                  X( N+J2 ) = V( 2, 2 )
!
!                 Scale X(J1), .... to avoid overflow in
!                 updating right hand side.
!
                  XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ), &
                       ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
                  IF( XJ.GT.ONE ) THEN
                     REC = ONE / XJ
                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. &
                         ( BIGNUM-XMAX )*REC ) THEN
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                     END IF
                  END IF
!
!                 Update the right-hand side.
!
                  IF( J1.GT.1 ) THEN
                     CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
                     CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
!
                     CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1, &
                                 X( N+1 ), 1 )
                     CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1, &
                                 X( N+1 ), 1 )
!
                     X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) + &
                              B( J2 )*X( N+J2 )
                     X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) - &
                                B( J2 )*X( J2 )
!
                     XMAX = ZERO
                     DO 60 K = 1, J1 - 1
                        XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ), &
                               XMAX )
   60                CONTINUE
                  END IF
!
               END IF
   70       CONTINUE
!
         ELSE
!
!           Solve (T + iB)'*(p+iq) = c+id
!
            JNEXT = 1
            DO 80 J = 1, N
               IF( J.LT.JNEXT ) &
                  GO TO 80
               J1 = J
               J2 = J
               JNEXT = J + 1
               IF( J.LT.N ) THEN
                  IF( T( J+1, J ).NE.ZERO ) THEN
                     J2 = J + 1
                     JNEXT = J + 2
                  END IF
               END IF
!
               IF( J1.EQ.J2 ) THEN
!
!                 1 by 1 diagonal block
!
!                 Scale if necessary to avoid overflow in forming the
!                 right-hand side element by inner product.
!
                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
                  IF( XMAX.GT.ONE ) THEN
                     REC = ONE / XMAX
                     IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
!
                  X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
                  X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, &
                              X( N+1 ), 1 )
                  IF( J1.GT.1 ) THEN
                     X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
                     X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
                  END IF
                  XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
!
                  Z = W
                  IF( J1.EQ.1 ) &
                     Z = B( 1 )
!
!                 Scale if necessary to avoid overflow in
!                 complex division
!
                  TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
                  TMP = T( J1, J1 )
                  IF( TJJ.LT.SMINW ) THEN
                     TMP = SMINW
                     TJJ = SMINW
                     INFO = 1
                  END IF
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.BIGNUM*TJJ ) THEN
                        REC = ONE / XJ
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
                  X( J1 ) = SR
                  X( J1+N ) = SI
                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
!
               ELSE
!
!                 2 by 2 diagonal block
!
!                 Scale if necessary to avoid overflow in forming the
!                 right-hand side element by inner product.
!
                  XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), &
                       ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
                  IF( XMAX.GT.ONE ) THEN
                     REC = ONE / XMAX
                     IF( MAX( WORK( J1 ), WORK( J2 ) ).GT. &
                         ( BIGNUM-XJ ) / XMAX ) THEN
                        CALL DSCAL( N2, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
!
                  D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, &
                              1 )
                  D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X, &
                              1 )
                  D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1, &
                              X( N+1 ), 1 )
                  D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1, &
                              X( N+1 ), 1 )
                  D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
                  D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
                  D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
                  D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
!
                  CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ), &
                               LDT, ONE, ONE, D, 2, ZERO, W, V, 2, &
                               SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 2
!
                  IF( SCALOC.NE.ONE ) THEN
                     CALL DSCAL( N2, SCALOC, X, 1 )
                     SCALE = SCALOC*SCALE
                  END IF
                  X( J1 ) = V( 1, 1 )
                  X( J2 ) = V( 2, 1 )
                  X( N+J1 ) = V( 1, 2 )
                  X( N+J2 ) = V( 2, 2 )
                  XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ), &
                         ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
!
               END IF
!
   80       CONTINUE
!
         END IF
!
      END IF
!
      RETURN
!
!     End of DLAQTR
!
      END
      SUBROUTINE DLAR1V( N, B1, BN, SIGMA, D, L, LD, LLD, GERSCH, Z, &
                         ZTZ, MINGMA, R, ISUPPZ, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            B1, BN, N, R
      DOUBLE PRECISION   MINGMA, SIGMA, ZTZ
!     ..
!     .. Array Arguments ..
      INTEGER            ISUPPZ( * )
      DOUBLE PRECISION   D( * ), GERSCH( * ), L( * ), LD( * ), LLD( * ), &
                         WORK( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAR1V computes the (scaled) r-th column of the inverse of
!  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
!  L D L^T - sigma I. The following steps accomplish this computation :
!  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
!  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
!  (c) Computation of the diagonal elements of the inverse of
!      L D L^T - sigma I by combining the above transforms, and choosing
!      r as the index where the diagonal of the inverse is (one of the)
!      largest in magnitude.
!  (d) Computation of the (scaled) r-th column of the inverse using the
!      twisted factorization obtained by combining the top part of the
!      the stationary and the bottom part of the progressive transform.
!
!  Arguments
!  =========
!
!  N        (input) INTEGER
!           The order of the matrix L D L^T.
!
!  B1       (input) INTEGER
!           First index of the submatrix of L D L^T.
!
!  BN       (input) INTEGER
!           Last index of the submatrix of L D L^T.
!
!  SIGMA    (input) DOUBLE PRECISION
!           The shift. Initially, when R = 0, SIGMA should be a good
!           approximation to an eigenvalue of L D L^T.
!
!  L        (input) DOUBLE PRECISION array, dimension (N-1)
!           The (n-1) subdiagonal elements of the unit bidiagonal matrix
!           L, in elements 1 to N-1.
!
!  D        (input) DOUBLE PRECISION array, dimension (N)
!           The n diagonal elements of the diagonal matrix D.
!
!  LD       (input) DOUBLE PRECISION array, dimension (N-1)
!           The n-1 elements L(i)*D(i).
!
!  LLD      (input) DOUBLE PRECISION array, dimension (N-1)
!           The n-1 elements L(i)*L(i)*D(i).
!
!  GERSCH   (input) DOUBLE PRECISION array, dimension (2*N)
!           The n Gerschgorin intervals. These are used to restrict
!           the initial search for R, when R is input as 0.
!
!  Z        (output) DOUBLE PRECISION array, dimension (N)
!           The (scaled) r-th column of the inverse. Z(R) is returned
!           to be 1.
!
!  ZTZ      (output) DOUBLE PRECISION
!           The square of the norm of Z.
!
!  MINGMA   (output) DOUBLE PRECISION
!           The reciprocal of the largest (in magnitude) diagonal
!           element of the inverse of L D L^T - sigma I.
!
!  R        (input/output) INTEGER
!           Initially, R should be input to be 0 and is then output as
!           the index where the diagonal element of the inverse is
!           largest in magnitude. In later iterations, this same value
!           of R should be input.
!
!  ISUPPZ   (output) INTEGER array, dimension (2)
!           The support of the vector in Z, i.e., the vector Z is
!           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
!
!  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            BLKSIZ
      PARAMETER          ( BLKSIZ = 32 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            SAWNAN
      INTEGER            FROM, I, INDP, INDS, INDUMN, J, R1, R2, TO
      DOUBLE PRECISION   DMINUS, DPLUS, EPS, S, TMP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      EPS = DLAMCH( 'Precision' )
      IF( R.EQ.0 ) THEN
!
!        Eliminate the top and bottom indices from the possible values
!        of R where the desired eigenvector is largest in magnitude.
!
         R1 = B1
         DO 10 I = B1, BN
            IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) ) &
                 THEN
               R1 = I
               GO TO 20
            END IF
   10    CONTINUE
   20    CONTINUE
         R2 = BN
         DO 30 I = BN, B1, -1
            IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) ) &
                 THEN
               R2 = I
               GO TO 40
            END IF
   30    CONTINUE
   40    CONTINUE
      ELSE
         R1 = R
         R2 = R
      END IF
!
      INDUMN = N
      INDS = 2*N + 1
      INDP = 3*N + 1
      SAWNAN = .FALSE.
!
!     Compute the stationary transform (using the differential form)
!     untill the index R2
!
      IF( B1.EQ.1 ) THEN
         WORK( INDS ) = ZERO
      ELSE
         WORK( INDS ) = LLD( B1-1 )
      END IF
      S = WORK( INDS ) - SIGMA
      DO 50 I = B1, R2 - 1
         DPLUS = D( I ) + S
         WORK( I ) = LD( I ) / DPLUS
         WORK( INDS+I ) = S*WORK( I )*L( I )
         S = WORK( INDS+I ) - SIGMA
   50 CONTINUE
!
      IF( .NOT.( S.GT.ZERO .OR. S.LT.ONE ) ) THEN
!
!        Run a slower version of the above loop if a NaN is detected
!
         SAWNAN = .TRUE.
         J = B1 + 1
   60    CONTINUE
         IF( WORK( INDS+J ).GT.ZERO .OR. WORK( INDS+J ).LT.ONE ) THEN
            J = J + 1
            GO TO 60
         END IF
         WORK( INDS+J ) = LLD( J )
         S = WORK( INDS+J ) - SIGMA
         DO 70 I = J + 1, R2 - 1
            DPLUS = D( I ) + S
            WORK( I ) = LD( I ) / DPLUS
            IF( WORK( I ).EQ.ZERO ) THEN
               WORK( INDS+I ) = LLD( I )
            ELSE
               WORK( INDS+I ) = S*WORK( I )*L( I )
            END IF
            S = WORK( INDS+I ) - SIGMA
   70    CONTINUE
      END IF
      WORK( INDP+BN-1 ) = D( BN ) - SIGMA
      DO 80 I = BN - 1, R1, -1
         DMINUS = LLD( I ) + WORK( INDP+I )
         TMP = D( I ) / DMINUS
         WORK( INDUMN+I ) = L( I )*TMP
         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
   80 CONTINUE
      TMP = WORK( INDP+R1-1 )
      IF( .NOT.( TMP.GT.ZERO .OR. TMP.LT.ONE ) ) THEN
!
!        Run a slower version of the above loop if a NaN is detected
!
         SAWNAN = .TRUE.
         J = BN - 3
   90    CONTINUE
         IF( WORK( INDP+J ).GT.ZERO .OR. WORK( INDP+J ).LT.ONE ) THEN
            J = J - 1
            GO TO 90
         END IF
         WORK( INDP+J ) = D( J+1 ) - SIGMA
         DO 100 I = J, R1, -1
            DMINUS = LLD( I ) + WORK( INDP+I )
            TMP = D( I ) / DMINUS
            WORK( INDUMN+I ) = L( I )*TMP
            IF( TMP.EQ.ZERO ) THEN
               WORK( INDP+I-1 ) = D( I ) - SIGMA
            ELSE
               WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
            END IF
  100    CONTINUE
      END IF
!
!     Find the index (from R1 to R2) of the largest (in magnitude)
!     diagonal element of the inverse
!
      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
      IF( MINGMA.EQ.ZERO ) &
         MINGMA = EPS*WORK( INDS+R1-1 )
      R = R1
      DO 110 I = R1, R2 - 1
         TMP = WORK( INDS+I ) + WORK( INDP+I )
         IF( TMP.EQ.ZERO ) &
            TMP = EPS*WORK( INDS+I )
         IF( ABS( TMP ).LT.ABS( MINGMA ) ) THEN
            MINGMA = TMP
            R = I + 1
         END IF
  110 CONTINUE
!
!     Compute the (scaled) r-th column of the inverse
!
      ISUPPZ( 1 ) = B1
      ISUPPZ( 2 ) = BN
      Z( R ) = ONE
      ZTZ = ONE
      IF( .NOT.SAWNAN ) THEN
         FROM = R - 1
         TO = MAX( R-BLKSIZ, B1 )
  120    CONTINUE
         IF( FROM.GE.B1 ) THEN
            DO 130 I = FROM, TO, -1
               Z( I ) = -( WORK( I )*Z( I+1 ) )
               ZTZ = ZTZ + Z( I )*Z( I )
  130       CONTINUE
            IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO+1 ) ).LE.EPS ) &
                 THEN
               ISUPPZ( 1 ) = TO + 2
            ELSE
               FROM = TO - 1
               TO = MAX( TO-BLKSIZ, B1 )
               GO TO 120
            END IF
         END IF
         FROM = R + 1
         TO = MIN( R+BLKSIZ, BN )
  140    CONTINUE
         IF( FROM.LE.BN ) THEN
            DO 150 I = FROM, TO
               Z( I ) = -( WORK( INDUMN+I-1 )*Z( I-1 ) )
               ZTZ = ZTZ + Z( I )*Z( I )
  150       CONTINUE
            IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO-1 ) ).LE.EPS ) &
                 THEN
               ISUPPZ( 2 ) = TO - 2
            ELSE
               FROM = TO + 1
               TO = MIN( TO+BLKSIZ, BN )
               GO TO 140
            END IF
         END IF
      ELSE
         DO 160 I = R - 1, B1, -1
            IF( Z( I+1 ).EQ.ZERO ) THEN
               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
            ELSE IF( ABS( Z( I+1 ) ).LE.EPS .AND. ABS( Z( I+2 ) ).LE. &
                     EPS ) THEN
               ISUPPZ( 1 ) = I + 3
               GO TO 170
            ELSE
               Z( I ) = -( WORK( I )*Z( I+1 ) )
            END IF
            ZTZ = ZTZ + Z( I )*Z( I )
  160    CONTINUE
  170    CONTINUE
         DO 180 I = R, BN - 1
            IF( Z( I ).EQ.ZERO ) THEN
               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
            ELSE IF( ABS( Z( I ) ).LE.EPS .AND. ABS( Z( I-1 ) ).LE.EPS ) &
                      THEN
               ISUPPZ( 2 ) = I - 2
               GO TO 190
            ELSE
               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
            END IF
            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
  180    CONTINUE
  190    CONTINUE
      END IF
      DO 200 I = B1, ISUPPZ( 1 ) - 3
         Z( I ) = ZERO
  200 CONTINUE
      DO 210 I = ISUPPZ( 2 ) + 3, BN
         Z( I ) = ZERO
  210 CONTINUE
!
      RETURN
!
!     End of DLAR1V
!
      END
      SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCC, INCX, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), S( * ), X( * ), Y( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLAR2V applies a vector of real plane rotations from both sides to
!  a sequence of 2-by-2 real symmetric matrices, defined by the elements
!  of the vectors x, y and z. For i = 1,2,...,n
!
!     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
!     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of plane rotations to be applied.
!
!  X       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          The vector x.
!
!  Y       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          The vector y.
!
!  Z       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          The vector z.
!
!  INCX    (input) INTEGER
!          The increment between elements of X, Y and Z. INCX > 0.
!
!  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!          The cosines of the plane rotations.
!
!  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!          The sines of the plane rotations.
!
!  INCC    (input) INTEGER
!          The increment between elements of C and S. INCC > 0.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IC, IX
      DOUBLE PRECISION   CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
!     ..
!     .. Executable Statements ..
!
      IX = 1
      IC = 1
      DO 10 I = 1, N
         XI = X( IX )
         YI = Y( IX )
         ZI = Z( IX )
         CI = C( IC )
         SI = S( IC )
         T1 = SI*ZI
         T2 = CI*ZI
         T3 = T2 - SI*XI
         T4 = T2 + SI*YI
         T5 = CI*XI + T1
         T6 = CI*YI - T1
         X( IX ) = CI*T5 + SI*T4
         Y( IX ) = CI*T6 - SI*T3
         Z( IX ) = CI*T4 - SI*T5
         IX = IX + INCX
         IC = IC + INCC
   10 CONTINUE
!
!     End of DLAR2V
!
      RETURN
      END
      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      DOUBLE PRECISION   TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARF applies a real elementary reflector H to a real m by n matrix
!  C, from either the left or the right. H is represented in the form
!
!        H = I - tau * v * v'
!
!  where tau is a real scalar and v is a real vector.
!
!  If tau = 0, then H is taken to be the unit matrix.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': form  H * C
!          = 'R': form  C * H
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  V       (input) DOUBLE PRECISION array, dimension
!                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
!                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
!          The vector v in the representation of H. V is not used if
!          TAU = 0.
!
!  INCV    (input) INTEGER
!          The increment between elements of v. INCV <> 0.
!
!  TAU     (input) DOUBLE PRECISION
!          The value tau in the representation of H.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!          or C * H if SIDE = 'R'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                         (N) if SIDE = 'L'
!                      or (M) if SIDE = 'R'
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        Form  H * C
!
         IF( TAU.NE.ZERO ) THEN
!
!           w := C' * v
!
            CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, &
                        WORK, 1 )
!
!           C := C - v * w'
!
            CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
         END IF
      ELSE
!
!        Form  C * H
!
         IF( TAU.NE.ZERO ) THEN
!
!           w := C * v
!
            CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, &
                        ZERO, WORK, 1 )
!
!           C := C - w * v'
!
            CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
         END IF
      END IF
      RETURN
!
!     End of DLARF
!
      END
      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, &
                         T, LDT, C, LDC, WORK, LDWORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ), &
                         WORK( LDWORK, * )
!     ..
!
!  Purpose
!  =======
!
!  DLARFB applies a real block reflector H or its transpose H' to a
!  real m by n matrix C, from either the left or the right.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply H or H' from the Left
!          = 'R': apply H or H' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply H (No transpose)
!          = 'T': apply H' (Transpose)
!
!  DIRECT  (input) CHARACTER*1
!          Indicates how H is formed from a product of elementary
!          reflectors
!          = 'F': H = H(1) H(2) . . . H(k) (Forward)
!          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!
!  STOREV  (input) CHARACTER*1
!          Indicates how the vectors which define the elementary
!          reflectors are stored:
!          = 'C': Columnwise
!          = 'R': Rowwise
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  K       (input) INTEGER
!          The order of the matrix T (= the number of elementary
!          reflectors whose product defines the block reflector).
!
!  V       (input) DOUBLE PRECISION array, dimension
!                                (LDV,K) if STOREV = 'C'
!                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
!                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
!          The matrix V. See further details.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V.
!          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
!          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
!          if STOREV = 'R', LDV >= K.
!
!  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
!          The triangular k by k matrix T in the representation of the
!          block reflector.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= K.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDA >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
!
!  LDWORK  (input) INTEGER
!          The leading dimension of the array WORK.
!          If SIDE = 'L', LDWORK >= max(1,N);
!          if SIDE = 'R', LDWORK >= max(1,M).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DTRMM
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( M.LE.0 .OR. N.LE.0 ) &
         RETURN
!
      IF( LSAME( TRANS, 'N' ) ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
      IF( LSAME( STOREV, 'C' ) ) THEN
!
         IF( LSAME( DIRECT, 'F' ) ) THEN
!
!           Let  V =  ( V1 )    (first K rows)
!                     ( V2 )
!           where  V1  is unit lower triangular.
!
            IF( LSAME( SIDE, 'L' ) ) THEN
!
!              Form  H * C  or  H' * C  where  C = ( C1 )
!                                                  ( C2 )
!
!              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
!
!              W := C1'
!
               DO 10 J = 1, K
                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10          CONTINUE
!
!              W := W * V1
!
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, &
                           K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
!
!                 W := W + C2'*V2
!
                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, &
                              ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, &
                              ONE, WORK, LDWORK )
               END IF
!
!              W := W * T'  or  W * T
!
               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - V * W'
!
               IF( M.GT.K ) THEN
!
!                 C2 := C2 - V2 * W'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, &
                              -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, &
                              C( K+1, 1 ), LDC )
               END IF
!
!              W := W * V1'
!
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, &
                           ONE, V, LDV, WORK, LDWORK )
!
!              C1 := C1 - W'
!
               DO 30 J = 1, K
                  DO 20 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
   20             CONTINUE
   30          CONTINUE
!
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!              Form  C * H  or  C * H'  where  C = ( C1  C2 )
!
!              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
!
!              W := C1
!
               DO 40 J = 1, K
                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40          CONTINUE
!
!              W := W * V1
!
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, &
                           K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
!
!                 W := W + C2 * V2
!
                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, &
                              ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, &
                              ONE, WORK, LDWORK )
               END IF
!
!              W := W * T  or  W * T'
!
               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - W * V'
!
               IF( N.GT.K ) THEN
!
!                 C2 := C2 - W * V2'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, &
                              -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, &
                              C( 1, K+1 ), LDC )
               END IF
!
!              W := W * V1'
!
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, &
                           ONE, V, LDV, WORK, LDWORK )
!
!              C1 := C1 - W
!
               DO 60 J = 1, K
                  DO 50 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
   50             CONTINUE
   60          CONTINUE
            END IF
!
         ELSE
!
!           Let  V =  ( V1 )
!                     ( V2 )    (last K rows)
!           where  V2  is unit upper triangular.
!
            IF( LSAME( SIDE, 'L' ) ) THEN
!
!              Form  H * C  or  H' * C  where  C = ( C1 )
!                                                  ( C2 )
!
!              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
!
!              W := C2'
!
               DO 70 J = 1, K
                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
   70          CONTINUE
!
!              W := W * V2
!
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, &
                           K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
!
!                 W := W + C1'*V1
!
                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, &
                              ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
!
!              W := W * T'  or  W * T
!
               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - V * W'
!
               IF( M.GT.K ) THEN
!
!                 C1 := C1 - V1 * W'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, &
                              -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
!
!              W := W * V2'
!
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, &
                           ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
!
!              C2 := C2 - W'
!
               DO 90 J = 1, K
                  DO 80 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
   80             CONTINUE
   90          CONTINUE
!
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!              Form  C * H  or  C * H'  where  C = ( C1  C2 )
!
!              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
!
!              W := C2
!
               DO 100 J = 1, K
                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  100          CONTINUE
!
!              W := W * V2
!
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, &
                           K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
!
!                 W := W + C1 * V1
!
                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, &
                              ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
!
!              W := W * T  or  W * T'
!
               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - W * V'
!
               IF( N.GT.K ) THEN
!
!                 C1 := C1 - W * V1'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, &
                              -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
!
!              W := W * V2'
!
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, &
                           ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
!
!              C2 := C2 - W
!
               DO 120 J = 1, K
                  DO 110 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  110             CONTINUE
  120          CONTINUE
            END IF
         END IF
!
      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
!
         IF( LSAME( DIRECT, 'F' ) ) THEN
!
!           Let  V =  ( V1  V2 )    (V1: first K columns)
!           where  V1  is unit upper triangular.
!
            IF( LSAME( SIDE, 'L' ) ) THEN
!
!              Form  H * C  or  H' * C  where  C = ( C1 )
!                                                  ( C2 )
!
!              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
!
!              W := C1'
!
               DO 130 J = 1, K
                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  130          CONTINUE
!
!              W := W * V1'
!
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, &
                           ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
!
!                 W := W + C2'*V2'
!
                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, &
                              C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, &
                              WORK, LDWORK )
               END IF
!
!              W := W * T'  or  W * T
!
               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - V' * W'
!
               IF( M.GT.K ) THEN
!
!                 C2 := C2 - V2' * W'
!
                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, &
                              V( 1, K+1 ), LDV, WORK, LDWORK, ONE, &
                              C( K+1, 1 ), LDC )
               END IF
!
!              W := W * V1
!
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, &
                           K, ONE, V, LDV, WORK, LDWORK )
!
!              C1 := C1 - W'
!
               DO 150 J = 1, K
                  DO 140 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
  140             CONTINUE
  150          CONTINUE
!
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!              Form  C * H  or  C * H'  where  C = ( C1  C2 )
!
!              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
!
!              W := C1
!
               DO 160 J = 1, K
                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  160          CONTINUE
!
!              W := W * V1'
!
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, &
                           ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
!
!                 W := W + C2 * V2'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, &
                              ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, &
                              ONE, WORK, LDWORK )
               END IF
!
!              W := W * T  or  W * T'
!
               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - W * V
!
               IF( N.GT.K ) THEN
!
!                 C2 := C2 - W * V2
!
                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, &
                              -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, &
                              C( 1, K+1 ), LDC )
               END IF
!
!              W := W * V1
!
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, &
                           K, ONE, V, LDV, WORK, LDWORK )
!
!              C1 := C1 - W
!
               DO 180 J = 1, K
                  DO 170 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
  170             CONTINUE
  180          CONTINUE
!
            END IF
!
         ELSE
!
!           Let  V =  ( V1  V2 )    (V2: last K columns)
!           where  V2  is unit lower triangular.
!
            IF( LSAME( SIDE, 'L' ) ) THEN
!
!              Form  H * C  or  H' * C  where  C = ( C1 )
!                                                  ( C2 )
!
!              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
!
!              W := C2'
!
               DO 190 J = 1, K
                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  190          CONTINUE
!
!              W := W * V2'
!
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, &
                           ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
!
!                 W := W + C1'*V1'
!
                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, &
                              C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
!
!              W := W * T'  or  W * T
!
               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - V' * W'
!
               IF( M.GT.K ) THEN
!
!                 C1 := C1 - V1' * W'
!
                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, &
                              V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
!
!              W := W * V2
!
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, &
                           K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
!
!              C2 := C2 - W'
!
               DO 210 J = 1, K
                  DO 200 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
  200             CONTINUE
  210          CONTINUE
!
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!              Form  C * H  or  C * H'  where  C = ( C1  C2 )
!
!              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
!
!              W := C2
!
               DO 220 J = 1, K
                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  220          CONTINUE
!
!              W := W * V2'
!
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, &
                           ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
!
!                 W := W + C1 * V1'
!
                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, &
                              ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
!
!              W := W * T  or  W * T'
!
               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, &
                           ONE, T, LDT, WORK, LDWORK )
!
!              C := C - W * V
!
               IF( N.GT.K ) THEN
!
!                 C1 := C1 - W * V1
!
                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, &
                              -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
!
!              W := W * V2
!
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, &
                           K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
!
!              C1 := C1 - W
!
               DO 240 J = 1, K
                  DO 230 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  230             CONTINUE
  240          CONTINUE
!
            END IF
!
         END IF
      END IF
!
      RETURN
!
!     End of DLARFB
!
      END
      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   ALPHA, TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARFG generates a real elementary reflector H of order n, such
!  that
!
!        H * ( alpha ) = ( beta ),   H' * H = I.
!            (   x   )   (   0  )
!
!  where alpha and beta are scalars, and x is an (n-1)-element real
!  vector. H is represented in the form
!
!        H = I - tau * ( 1 ) * ( 1 v' ) ,
!                      ( v )
!
!  where tau is a real scalar and v is a real (n-1)-element
!  vector.
!
!  If the elements of x are all zero, then tau = 0 and H is taken to be
!  the unit matrix.
!
!  Otherwise  1 <= tau <= 2.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the elementary reflector.
!
!  ALPHA   (input/output) DOUBLE PRECISION
!          On entry, the value alpha.
!          On exit, it is overwritten with the value beta.
!
!  X       (input/output) DOUBLE PRECISION array, dimension
!                         (1+(N-2)*abs(INCX))
!          On entry, the vector x.
!          On exit, it is overwritten with the vector v.
!
!  INCX    (input) INTEGER
!          The increment between elements of X. INCX > 0.
!
!  TAU     (output) DOUBLE PRECISION
!          The value tau.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J, KNT
      DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
      EXTERNAL           DLAMCH, DLAPY2, DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL
!     ..
!     .. Executable Statements ..
!
      IF( N.LE.1 ) THEN
         TAU = ZERO
         RETURN
      END IF
!
      XNORM = DNRM2( N-1, X, INCX )
!
      IF( XNORM.EQ.ZERO ) THEN
!
!        H  =  I
!
         TAU = ZERO
      ELSE
!
!        general case
!
         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
         IF( ABS( BETA ).LT.SAFMIN ) THEN
!
!           XNORM, BETA may be inaccurate; scale X and recompute them
!
            RSAFMN = ONE / SAFMIN
            KNT = 0
   10       CONTINUE
            KNT = KNT + 1
            CALL DSCAL( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHA = ALPHA*RSAFMN
            IF( ABS( BETA ).LT.SAFMIN ) &
               GO TO 10
!
!           New BETA is at most 1, at least SAFMIN
!
            XNORM = DNRM2( N-1, X, INCX )
            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
!
!           If ALPHA is subnormal, it may lose relative accuracy
!
            ALPHA = BETA
            DO 20 J = 1, KNT
               ALPHA = ALPHA*SAFMIN
   20       CONTINUE
         ELSE
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
            ALPHA = BETA
         END IF
      END IF
!
      RETURN
!
!     End of DLARFG
!
      END
      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
!     ..
!
!  Purpose
!  =======
!
!  DLARFT forms the triangular factor T of a real block reflector H
!  of order n, which is defined as a product of k elementary reflectors.
!
!  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!
!  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!
!  If STOREV = 'C', the vector which defines the elementary reflector
!  H(i) is stored in the i-th column of the array V, and
!
!     H  =  I - V * T * V'
!
!  If STOREV = 'R', the vector which defines the elementary reflector
!  H(i) is stored in the i-th row of the array V, and
!
!     H  =  I - V' * T * V
!
!  Arguments
!  =========
!
!  DIRECT  (input) CHARACTER*1
!          Specifies the order in which the elementary reflectors are
!          multiplied to form the block reflector:
!          = 'F': H = H(1) H(2) . . . H(k) (Forward)
!          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!
!  STOREV  (input) CHARACTER*1
!          Specifies how the vectors which define the elementary
!          reflectors are stored (see also Further Details):
!          = 'C': columnwise
!          = 'R': rowwise
!
!  N       (input) INTEGER
!          The order of the block reflector H. N >= 0.
!
!  K       (input) INTEGER
!          The order of the triangular factor T (= the number of
!          elementary reflectors). K >= 1.
!
!  V       (input/output) DOUBLE PRECISION array, dimension
!                               (LDV,K) if STOREV = 'C'
!                               (LDV,N) if STOREV = 'R'
!          The matrix V. See further details.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V.
!          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i).
!
!  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
!          The k by k triangular factor T of the block reflector.
!          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
!          lower triangular. The rest of the array is not used.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= K.
!
!  Further Details
!  ===============
!
!  The shape of the matrix V and the storage of the vectors which define
!  the H(i) is best illustrated by the following example with n = 5 and
!  k = 3. The elements equal to 1 are not stored; the corresponding
!  array elements are modified but restored on exit. The rest of the
!  array is not used.
!
!  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
!
!               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
!                   ( v1  1    )                     (     1 v2 v2 v2 )
!                   ( v1 v2  1 )                     (        1 v3 v3 )
!                   ( v1 v2 v3 )
!                   ( v1 v2 v3 )
!
!  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!
!               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
!                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
!                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
!                   (     1 v3 )
!                   (        1 )
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   VII
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DTRMV
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( LSAME( DIRECT, 'F' ) ) THEN
         DO 20 I = 1, K
            IF( TAU( I ).EQ.ZERO ) THEN
!
!              H(i)  =  I
!
               DO 10 J = 1, I
                  T( J, I ) = ZERO
   10          CONTINUE
            ELSE
!
!              general case
!
               VII = V( I, I )
               V( I, I ) = ONE
               IF( LSAME( STOREV, 'C' ) ) THEN
!
!                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
!
                  CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), &
                              V( I, 1 ), LDV, V( I, I ), 1, ZERO, &
                              T( 1, I ), 1 )
               ELSE
!
!                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
!
                  CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), &
                              V( 1, I ), LDV, V( I, I ), LDV, ZERO, &
                              T( 1, I ), 1 )
               END IF
               V( I, I ) = VII
!
!              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
!
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, &
                           LDT, T( 1, I ), 1 )
               T( I, I ) = TAU( I )
            END IF
   20    CONTINUE
      ELSE
         DO 40 I = K, 1, -1
            IF( TAU( I ).EQ.ZERO ) THEN
!
!              H(i)  =  I
!
               DO 30 J = I, K
                  T( J, I ) = ZERO
   30          CONTINUE
            ELSE
!
!              general case
!
               IF( I.LT.K ) THEN
                  IF( LSAME( STOREV, 'C' ) ) THEN
                     VII = V( N-K+I, I )
                     V( N-K+I, I ) = ONE
!
!                    T(i+1:k,i) :=
!                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
!
                     CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), &
                                 V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, &
                                 T( I+1, I ), 1 )
                     V( N-K+I, I ) = VII
                  ELSE
                     VII = V( I, N-K+I )
                     V( I, N-K+I ) = ONE
!
!                    T(i+1:k,i) :=
!                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
!
                     CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), &
                                 V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, &
                                 T( I+1, I ), 1 )
                     V( I, N-K+I ) = VII
                  END IF
!
!                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
!
                  CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, &
                              T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
               END IF
               T( I, I ) = TAU( I )
            END IF
   40    CONTINUE
      END IF
      RETURN
!
!     End of DLARFT
!
      END
      SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            LDC, M, N
      DOUBLE PRECISION   TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARFX applies a real elementary reflector H to a real m by n
!  matrix C, from either the left or the right. H is represented in the
!  form
!
!        H = I - tau * v * v'
!
!  where tau is a real scalar and v is a real vector.
!
!  If tau = 0, then H is taken to be the unit matrix
!
!  This version uses inline code if H has order < 11.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': form  H * C
!          = 'R': form  C * H
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  V       (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'
!                                     or (N) if SIDE = 'R'
!          The vector v in the representation of H.
!
!  TAU     (input) DOUBLE PRECISION
!          The value tau in the representation of H.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!          or C * H if SIDE = 'R'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDA >= (1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                      (N) if SIDE = 'L'
!                      or (M) if SIDE = 'R'
!          WORK is not referenced if H has order < 11.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J
      DOUBLE PRECISION   SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, &
                         V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER
!     ..
!     .. Executable Statements ..
!
      IF( TAU.EQ.ZERO ) &
         RETURN
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        Form  H * C, where H has order m.
!
         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, &
                 170, 190 )M
!
!        Code for general M
!
!        w := C'*v
!
         CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, &
                     1 )
!
!        C := C - tau * v * w'
!
         CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
         GO TO 410
   10    CONTINUE
!
!        Special code for 1 x 1 Householder
!
         T1 = ONE - TAU*V( 1 )*V( 1 )
         DO 20 J = 1, N
            C( 1, J ) = T1*C( 1, J )
   20    CONTINUE
         GO TO 410
   30    CONTINUE
!
!        Special code for 2 x 2 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         DO 40 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
   40    CONTINUE
         GO TO 410
   50    CONTINUE
!
!        Special code for 3 x 3 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         DO 60 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
   60    CONTINUE
         GO TO 410
   70    CONTINUE
!
!        Special code for 4 x 4 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         DO 80 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
   80    CONTINUE
         GO TO 410
   90    CONTINUE
!
!        Special code for 5 x 5 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         DO 100 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
  100    CONTINUE
         GO TO 410
  110    CONTINUE
!
!        Special code for 6 x 6 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         DO 120 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
            C( 6, J ) = C( 6, J ) - SUM*T6
  120    CONTINUE
         GO TO 410
  130    CONTINUE
!
!        Special code for 7 x 7 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         DO 140 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + &
                  V7*C( 7, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
            C( 6, J ) = C( 6, J ) - SUM*T6
            C( 7, J ) = C( 7, J ) - SUM*T7
  140    CONTINUE
         GO TO 410
  150    CONTINUE
!
!        Special code for 8 x 8 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         DO 160 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + &
                  V7*C( 7, J ) + V8*C( 8, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
            C( 6, J ) = C( 6, J ) - SUM*T6
            C( 7, J ) = C( 7, J ) - SUM*T7
            C( 8, J ) = C( 8, J ) - SUM*T8
  160    CONTINUE
         GO TO 410
  170    CONTINUE
!
!        Special code for 9 x 9 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         DO 180 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + &
                  V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
            C( 6, J ) = C( 6, J ) - SUM*T6
            C( 7, J ) = C( 7, J ) - SUM*T7
            C( 8, J ) = C( 8, J ) - SUM*T8
            C( 9, J ) = C( 9, J ) - SUM*T9
  180    CONTINUE
         GO TO 410
  190    CONTINUE
!
!        Special code for 10 x 10 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         V10 = V( 10 )
         T10 = TAU*V10
         DO 200 J = 1, N
            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + &
                  V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + &
                  V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + &
                  V10*C( 10, J )
            C( 1, J ) = C( 1, J ) - SUM*T1
            C( 2, J ) = C( 2, J ) - SUM*T2
            C( 3, J ) = C( 3, J ) - SUM*T3
            C( 4, J ) = C( 4, J ) - SUM*T4
            C( 5, J ) = C( 5, J ) - SUM*T5
            C( 6, J ) = C( 6, J ) - SUM*T6
            C( 7, J ) = C( 7, J ) - SUM*T7
            C( 8, J ) = C( 8, J ) - SUM*T8
            C( 9, J ) = C( 9, J ) - SUM*T9
            C( 10, J ) = C( 10, J ) - SUM*T10
  200    CONTINUE
         GO TO 410
      ELSE
!
!        Form  C * H, where H has order n.
!
         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, &
                 370, 390 )N
!
!        Code for general N
!
!        w := C * v
!
         CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, &
                     WORK, 1 )
!
!        C := C - tau * w * v'
!
         CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
         GO TO 410
  210    CONTINUE
!
!        Special code for 1 x 1 Householder
!
         T1 = ONE - TAU*V( 1 )*V( 1 )
         DO 220 J = 1, M
            C( J, 1 ) = T1*C( J, 1 )
  220    CONTINUE
         GO TO 410
  230    CONTINUE
!
!        Special code for 2 x 2 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         DO 240 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
  240    CONTINUE
         GO TO 410
  250    CONTINUE
!
!        Special code for 3 x 3 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         DO 260 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
  260    CONTINUE
         GO TO 410
  270    CONTINUE
!
!        Special code for 4 x 4 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         DO 280 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
  280    CONTINUE
         GO TO 410
  290    CONTINUE
!
!        Special code for 5 x 5 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         DO 300 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
  300    CONTINUE
         GO TO 410
  310    CONTINUE
!
!        Special code for 6 x 6 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         DO 320 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
            C( J, 6 ) = C( J, 6 ) - SUM*T6
  320    CONTINUE
         GO TO 410
  330    CONTINUE
!
!        Special code for 7 x 7 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         DO 340 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + &
                  V7*C( J, 7 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
            C( J, 6 ) = C( J, 6 ) - SUM*T6
            C( J, 7 ) = C( J, 7 ) - SUM*T7
  340    CONTINUE
         GO TO 410
  350    CONTINUE
!
!        Special code for 8 x 8 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         DO 360 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + &
                  V7*C( J, 7 ) + V8*C( J, 8 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
            C( J, 6 ) = C( J, 6 ) - SUM*T6
            C( J, 7 ) = C( J, 7 ) - SUM*T7
            C( J, 8 ) = C( J, 8 ) - SUM*T8
  360    CONTINUE
         GO TO 410
  370    CONTINUE
!
!        Special code for 9 x 9 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         DO 380 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + &
                  V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
            C( J, 6 ) = C( J, 6 ) - SUM*T6
            C( J, 7 ) = C( J, 7 ) - SUM*T7
            C( J, 8 ) = C( J, 8 ) - SUM*T8
            C( J, 9 ) = C( J, 9 ) - SUM*T9
  380    CONTINUE
         GO TO 410
  390    CONTINUE
!
!        Special code for 10 x 10 Householder
!
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         V10 = V( 10 )
         T10 = TAU*V10
         DO 400 J = 1, M
            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + &
                  V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + &
                  V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + &
                  V10*C( J, 10 )
            C( J, 1 ) = C( J, 1 ) - SUM*T1
            C( J, 2 ) = C( J, 2 ) - SUM*T2
            C( J, 3 ) = C( J, 3 ) - SUM*T3
            C( J, 4 ) = C( J, 4 ) - SUM*T4
            C( J, 5 ) = C( J, 5 ) - SUM*T5
            C( J, 6 ) = C( J, 6 ) - SUM*T6
            C( J, 7 ) = C( J, 7 ) - SUM*T7
            C( J, 8 ) = C( J, 8 ) - SUM*T8
            C( J, 9 ) = C( J, 9 ) - SUM*T9
            C( J, 10 ) = C( J, 10 ) - SUM*T10
  400    CONTINUE
         GO TO 410
      END IF
  410 CONTINUE
      RETURN
!
!     End of DLARFX
!
      END
      SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCC, INCX, INCY, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARGV generates a vector of real plane rotations, determined by
!  elements of the real vectors x and y. For i = 1,2,...,n
!
!     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
!     ( -s(i)  c(i) ) ( y(i) ) = (   0  )
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of plane rotations to be generated.
!
!  X       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          On entry, the vector x.
!          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
!
!  INCX    (input) INTEGER
!          The increment between elements of X. INCX > 0.
!
!  Y       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCY)
!          On entry, the vector y.
!          On exit, the sines of the plane rotations.
!
!  INCY    (input) INTEGER
!          The increment between elements of Y. INCY > 0.
!
!  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!          The cosines of the plane rotations.
!
!  INCC    (input) INTEGER
!          The increment between elements of C. INCC > 0.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IC, IX, IY
      DOUBLE PRECISION   F, G, T, TT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
      IX = 1
      IY = 1
      IC = 1
      DO 10 I = 1, N
         F = X( IX )
         G = Y( IY )
         IF( G.EQ.ZERO ) THEN
            C( IC ) = ONE
         ELSE IF( F.EQ.ZERO ) THEN
            C( IC ) = ZERO
            Y( IY ) = ONE
            X( IX ) = G
         ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
            T = G / F
            TT = SQRT( ONE+T*T )
            C( IC ) = ONE / TT
            Y( IY ) = T*C( IC )
            X( IX ) = F*TT
         ELSE
            T = F / G
            TT = SQRT( ONE+T*T )
            Y( IY ) = ONE / TT
            C( IC ) = T*Y( IY )
            X( IX ) = G*TT
         END IF
         IC = IC + INCC
         IY = IY + INCY
         IX = IX + INCX
   10 CONTINUE
      RETURN
!
!     End of DLARGV
!
      END
      SUBROUTINE DLARNV( IDIST, ISEED, N, X )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            IDIST, N
!     ..
!     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARNV returns a vector of n random real numbers from a uniform or
!  normal distribution.
!
!  Arguments
!  =========
!
!  IDIST   (input) INTEGER
!          Specifies the distribution of the random numbers:
!          = 1:  uniform (0,1)
!          = 2:  uniform (-1,1)
!          = 3:  normal (0,1)
!
!  ISEED   (input/output) INTEGER array, dimension (4)
!          On entry, the seed of the random number generator; the array
!          elements must be between 0 and 4095, and ISEED(4) must be
!          odd.
!          On exit, the seed is updated.
!
!  N       (input) INTEGER
!          The number of random numbers to be generated.
!
!  X       (output) DOUBLE PRECISION array, dimension (N)
!          The generated random numbers.
!
!  Further Details
!  ===============
!
!  This routine calls the auxiliary routine DLARUV to generate random
!  real numbers from a uniform (0,1) distribution, in batches of up to
!  128 using vectorisable code. The Box-Muller method is used to
!  transform numbers from a uniform to a normal distribution.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
      INTEGER            LV
      PARAMETER          ( LV = 128 )
      DOUBLE PRECISION   TWOPI
      PARAMETER          ( TWOPI = 6.2831853071795864769252867663D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IL, IL2, IV
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   U( LV )
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          COS, LOG, MIN, SQRT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARUV
!     ..
!     .. Executable Statements ..
!
      DO 40 IV = 1, N, LV / 2
         IL = MIN( LV / 2, N-IV+1 )
         IF( IDIST.EQ.3 ) THEN
            IL2 = 2*IL
         ELSE
            IL2 = IL
         END IF
!
!        Call DLARUV to generate IL2 numbers from a uniform (0,1)
!        distribution (IL2 <= LV)
!
         CALL DLARUV( ISEED, IL2, U )
!
         IF( IDIST.EQ.1 ) THEN
!
!           Copy generated numbers
!
            DO 10 I = 1, IL
               X( IV+I-1 ) = U( I )
   10       CONTINUE
         ELSE IF( IDIST.EQ.2 ) THEN
!
!           Convert generated numbers to uniform (-1,1) distribution
!
            DO 20 I = 1, IL
               X( IV+I-1 ) = TWO*U( I ) - ONE
   20       CONTINUE
         ELSE IF( IDIST.EQ.3 ) THEN
!
!           Convert generated numbers to normal (0,1) distribution
!
            DO 30 I = 1, IL
               X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* &
                             COS( TWOPI*U( 2*I ) )
   30       CONTINUE
         END IF
   40 CONTINUE
      RETURN
!
!     End of DLARNV
!
      END
      SUBROUTINE DLARRB( N, D, L, LD, LLD, IFIRST, ILAST, SIGMA, RELTOL, &
                         W, WGAP, WERR, WORK, IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N
      DOUBLE PRECISION   RELTOL, SIGMA
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), L( * ), LD( * ), LLD( * ), W( * ), &
                         WERR( * ), WGAP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  Given the relatively robust representation(RRR) L D L^T, DLARRB
!  does ``limited'' bisection to locate the eigenvalues of L D L^T,
!  W( IFIRST ) thru' W( ILAST ), to more accuracy. Intervals
!  [left, right] are maintained by storing their mid-points and
!  semi-widths in the arrays W and WERR respectively.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D.
!
!  L       (input) DOUBLE PRECISION array, dimension (N-1)
!          The n-1 subdiagonal elements of the unit bidiagonal matrix L.
!
!  LD      (input) DOUBLE PRECISION array, dimension (N-1)
!          The n-1 elements L(i)*D(i).
!
!  LLD     (input) DOUBLE PRECISION array, dimension (N-1)
!          The n-1 elements L(i)*L(i)*D(i).
!
!  IFIRST  (input) INTEGER
!          The index of the first eigenvalue in the cluster.
!
!  ILAST   (input) INTEGER
!          The index of the last eigenvalue in the cluster.
!
!  SIGMA   (input) DOUBLE PRECISION
!          The shift used to form L D L^T (see DLARRF).
!
!  RELTOL  (input) DOUBLE PRECISION
!          The relative tolerance.
!
!  W       (input/output) DOUBLE PRECISION array, dimension (N)
!          On input, W( IFIRST ) thru' W( ILAST ) are estimates of the
!          corresponding eigenvalues of L D L^T.
!          On output, these estimates are ``refined''.
!
!  WGAP    (input/output) DOUBLE PRECISION array, dimension (N)
!          The gaps between the eigenvalues of L D L^T. Very small
!          gaps are changed on output.
!
!  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
!          On input, WERR( IFIRST ) thru' WERR( ILAST ) are the errors
!          in the estimates W( IFIRST ) thru' W( ILAST ).
!          On output, these are the ``refined'' errors.
!
!****Reminder to Inder --- WORK is never used in this subroutine *****
!  WORK    (input) DOUBLE PRECISION array, dimension (???)
!          Workspace.
!
!  IWORK   (input) INTEGER array, dimension (2*N)
!          Workspace.
!
!****Reminder to Inder --- INFO is never set in this subroutine ******
!  INFO    (output) INTEGER
!          Error flag.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO, HALF
      PARAMETER          ( ZERO = 0.0D0, TWO = 2.0D0, HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            CNT, I, I1, I2, INITI1, INITI2, J, K, NCNVRG, &
                         NEIG, NINT, NRIGHT, OLNINT
      DOUBLE PRECISION   DELTA, EPS, GAP, LEFT, MID, PERT, RIGHT, S, &
                         THRESH, TMP, WIDTH
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      EPS = DLAMCH( 'Precision' )
      I1 = IFIRST
      I2 = IFIRST
      NEIG = ILAST - IFIRST + 1
      NCNVRG = 0
      THRESH = RELTOL
      DO 10 I = IFIRST, ILAST
         IWORK( I ) = 0
         PERT = EPS*( ABS( SIGMA )+ABS( W( I ) ) )
         WERR( I ) = WERR( I ) + PERT
         IF( WGAP( I ).LT.PERT ) &
            WGAP( I ) = PERT
   10 CONTINUE
      DO 20 I = I1, ILAST
         IF( I.EQ.1 ) THEN
            GAP = WGAP( I )
         ELSE IF( I.EQ.N ) THEN
            GAP = WGAP( I-1 )
         ELSE
            GAP = MIN( WGAP( I-1 ), WGAP( I ) )
         END IF
         IF( WERR( I ).LT.THRESH*GAP ) THEN
            NCNVRG = NCNVRG + 1
            IWORK( I ) = 1
            IF( I1.EQ.I ) &
               I1 = I1 + 1
         ELSE
            I2 = I
         END IF
   20 CONTINUE
!
!     Initialize the unconverged intervals.
!
      I = I1
      NINT = 0
      RIGHT = ZERO
   30 CONTINUE
      IF( I.LE.I2 ) THEN
         IF( IWORK( I ).EQ.0 ) THEN
            DELTA = EPS
            LEFT = W( I ) - WERR( I )
!
!           Do while( CNT(LEFT).GT.I-1 )
!
   40       CONTINUE
            IF( I.GT.I1 .AND. LEFT.LE.RIGHT ) THEN
               LEFT = RIGHT
               CNT = I - 1
            ELSE
               S = -LEFT
               CNT = 0
               DO 50 J = 1, N - 1
                  TMP = D( J ) + S
                  S = S*( LD( J ) / TMP )*L( J ) - LEFT
                  IF( TMP.LT.ZERO ) &
                     CNT = CNT + 1
   50          CONTINUE
               TMP = D( N ) + S
               IF( TMP.LT.ZERO ) &
                  CNT = CNT + 1
               IF( CNT.GT.I-1 ) THEN
                  DELTA = TWO*DELTA
                  LEFT = LEFT - ( ABS( SIGMA )+ABS( LEFT ) )*DELTA
                  GO TO 40
               END IF
            END IF
            DELTA = EPS
            RIGHT = W( I ) + WERR( I )
!
!           Do while( CNT(RIGHT).LT.I )
!
   60       CONTINUE
            S = -RIGHT
            CNT = 0
            DO 70 J = 1, N - 1
               TMP = D( J ) + S
               S = S*( LD( J ) / TMP )*L( J ) - RIGHT
               IF( TMP.LT.ZERO ) &
                  CNT = CNT + 1
   70       CONTINUE
            TMP = D( N ) + S
            IF( TMP.LT.ZERO ) &
               CNT = CNT + 1
            IF( CNT.LT.I ) THEN
               DELTA = TWO*DELTA
               RIGHT = RIGHT + ( ABS( SIGMA )+ABS( RIGHT ) )*DELTA
               GO TO 60
            END IF
            WERR( I ) = LEFT
            W( I ) = RIGHT
            IWORK( N+I ) = CNT
            NINT = NINT + 1
            I = CNT + 1
         ELSE
            I = I + 1
         END IF
         GO TO 30
      END IF
!
!     While( NCNVRG.LT.NEIG )
!
      INITI1 = I1
      INITI2 = I2
   80 CONTINUE
      IF( NCNVRG.LT.NEIG ) THEN
         OLNINT = NINT
         I = I1
         DO 100 K = 1, OLNINT
            NRIGHT = IWORK( N+I )
            IF( IWORK( I ).EQ.0 ) THEN
               MID = HALF*( WERR( I )+W( I ) )
               S = -MID
               CNT = 0
               DO 90 J = 1, N - 1
                  TMP = D( J ) + S
                  S = S*( LD( J ) / TMP )*L( J ) - MID
                  IF( TMP.LT.ZERO ) &
                     CNT = CNT + 1
   90          CONTINUE
               TMP = D( N ) + S
               IF( TMP.LT.ZERO ) &
                  CNT = CNT + 1
               CNT = MAX( I-1, MIN( NRIGHT, CNT ) )
               IF( I.EQ.NRIGHT ) THEN
                  IF( I.EQ.IFIRST ) THEN
                     GAP = WERR( I+1 ) - W( I )
                  ELSE IF( I.EQ.ILAST ) THEN
                     GAP = WERR( I ) - W( I-1 )
                  ELSE
                     GAP = MIN( WERR( I+1 )-W( I ), WERR( I )-W( I-1 ) )
                  END IF
                  WIDTH = W( I ) - MID
                  IF( WIDTH.LT.THRESH*GAP ) THEN
                     NCNVRG = NCNVRG + 1
                     IWORK( I ) = 1
                     IF( I1.EQ.I ) THEN
                        I1 = I1 + 1
                        NINT = NINT - 1
                     END IF
                  END IF
               END IF
               IF( IWORK( I ).EQ.0 ) &
                  I2 = K
               IF( CNT.EQ.I-1 ) THEN
                  WERR( I ) = MID
               ELSE IF( CNT.EQ.NRIGHT ) THEN
                  W( I ) = MID
               ELSE
                  IWORK( N+I ) = CNT
                  NINT = NINT + 1
                  WERR( CNT+1 ) = MID
                  W( CNT+1 ) = W( I )
                  W( I ) = MID
                  I = CNT + 1
                  IWORK( N+I ) = NRIGHT
               END IF
            END IF
            I = NRIGHT + 1
  100    CONTINUE
         NINT = NINT - OLNINT + I2
         GO TO 80
      END IF
      DO 110 I = INITI1, INITI2
         W( I ) = HALF*( WERR( I )+W( I ) )
         WERR( I ) = W( I ) - WERR( I )
  110 CONTINUE
!
      RETURN
!
!     End of DLARRB
!
      END
      SUBROUTINE DLARRE( N, D, E, TOL, NSPLIT, ISPLIT, M, W, WOFF, &
                         GERSCH, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, M, N, NSPLIT
      DOUBLE PRECISION   TOL
!     ..
!     .. Array Arguments ..
      INTEGER            ISPLIT( * )
      DOUBLE PRECISION   D( * ), E( * ), GERSCH( * ), W( * ), WOFF( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  Given the tridiagonal matrix T, DLARRE sets "small" off-diagonal
!  elements to zero, and for each unreduced block T_i, it finds
!  (i) the numbers sigma_i
!  (ii) the base T_i - sigma_i I = L_i D_i L_i^T representations and
!  (iii) eigenvalues of each L_i D_i L_i^T.
!  The representations and eigenvalues found are then used by
!  DSTEGR to compute the eigenvectors of a symmetric tridiagonal
!  matrix. Currently, the base representations are limited to being
!  positive or negative definite, and the eigenvalues of the definite
!  matrices are found by the dqds algorithm (subroutine DLASQ2). As
!  an added benefit, DLARRE also outputs the n Gerschgorin
!  intervals for each L_i D_i L_i^T.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal
!          matrix T.
!          On exit, the n diagonal elements of the diagonal
!          matrices D_i.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix T; E(N) need not be set.
!          On exit, the subdiagonal elements of the unit bidiagonal
!          matrices L_i.
!
!  TOL     (input) DOUBLE PRECISION
!          The threshold for splitting. If on input |E(i)| < TOL, then
!          the matrix T is split into smaller blocks.
!
!  NSPLIT  (input) INTEGER
!          The number of blocks T splits into. 1 <= NSPLIT <= N.
!
!  ISPLIT  (output) INTEGER array, dimension (2*N)
!          The splitting points, at which T breaks up into submatrices.
!          The first submatrix consists of rows/columns 1 to ISPLIT(1),
!          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
!          etc., and the NSPLIT-th consists of rows/columns
!          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
!
!  M       (output) INTEGER
!          The total number of eigenvalues (of all the L_i D_i L_i^T)
!          found.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the eigenvalues. The
!          eigenvalues of each of the blocks, L_i D_i L_i^T, are
!          sorted in ascending order.
!
!  WOFF    (output) DOUBLE PRECISION array, dimension (N)
!          The NSPLIT base points sigma_i.
!
!  GERSCH  (output) DOUBLE PRECISION array, dimension (2*N)
!          The n Gerschgorin intervals.
!
!  WORK    (input) DOUBLE PRECISION array, dimension (4*N???)
!          Workspace.
!
!  INFO    (output) INTEGER
!          Output error code from DLASQ2
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR, FOURTH
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         FOUR = 4.0D0, FOURTH = ONE / FOUR )
!     ..
!     .. Local Scalars ..
      INTEGER            CNT, I, IBEGIN, IEND, IN, J, JBLK, MAXCNT
      DOUBLE PRECISION   DELTA, EPS, GL, GU, NRM, OFFD, S, SGNDEF, &
                         SIGMA, TAU, TMP1, WIDTH
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLASQ2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      EPS = DLAMCH( 'Precision' )
!
!     Compute Splitting Points
!
      NSPLIT = 1
      DO 10 I = 1, N - 1
         IF( ABS( E( I ) ).LE.TOL ) THEN
            ISPLIT( NSPLIT ) = I
            NSPLIT = NSPLIT + 1
         END IF
   10 CONTINUE
      ISPLIT( NSPLIT ) = N
!
      IBEGIN = 1
      DO 170 JBLK = 1, NSPLIT
         IEND = ISPLIT( JBLK )
         IF( IBEGIN.EQ.IEND ) THEN
            W( IBEGIN ) = D( IBEGIN )
            WOFF( JBLK ) = ZERO
            IBEGIN = IEND + 1
            GO TO 170
         END IF
         IN = IEND - IBEGIN + 1
!
!        Form the n Gerschgorin intervals
!
         GL = D( IBEGIN ) - ABS( E( IBEGIN ) )
         GU = D( IBEGIN ) + ABS( E( IBEGIN ) )
         GERSCH( 2*IBEGIN-1 ) = GL
         GERSCH( 2*IBEGIN ) = GU
         GERSCH( 2*IEND-1 ) = D( IEND ) - ABS( E( IEND-1 ) )
         GERSCH( 2*IEND ) = D( IEND ) + ABS( E( IEND-1 ) )
         GL = MIN( GERSCH( 2*IEND-1 ), GL )
         GU = MAX( GERSCH( 2*IEND ), GU )
         DO 20 I = IBEGIN + 1, IEND - 1
            OFFD = ABS( E( I-1 ) ) + ABS( E( I ) )
            GERSCH( 2*I-1 ) = D( I ) - OFFD
            GL = MIN( GERSCH( 2*I-1 ), GL )
            GERSCH( 2*I ) = D( I ) + OFFD
            GU = MAX( GERSCH( 2*I ), GU )
   20    CONTINUE
         NRM = MAX( ABS( GL ), ABS( GU ) )
!
!        Find the number SIGMA where the base representation
!        T - sigma I = L D L^T is to be formed.
!
         WIDTH = GU - GL
         DO 30 I = IBEGIN, IEND - 1
            WORK( I ) = E( I )*E( I )
   30    CONTINUE
         DO 50 J = 1, 2
            IF( J.EQ.1 ) THEN
               TAU = GL + FOURTH*WIDTH
            ELSE
               TAU = GU - FOURTH*WIDTH
            END IF
            TMP1 = D( IBEGIN ) - TAU
            IF( TMP1.LT.ZERO ) THEN
               CNT = 1
            ELSE
               CNT = 0
            END IF
            DO 40 I = IBEGIN + 1, IEND
               TMP1 = D( I ) - TAU - WORK( I-1 ) / TMP1
               IF( TMP1.LT.ZERO ) &
                  CNT = CNT + 1
   40       CONTINUE
            IF( CNT.EQ.0 ) THEN
               GL = TAU
            ELSE IF( CNT.EQ.IN ) THEN
               GU = TAU
            END IF
            IF( J.EQ.1 ) THEN
               MAXCNT = CNT
               SIGMA = GL
               SGNDEF = ONE
            ELSE
               IF( IN-CNT.GT.MAXCNT ) THEN
                  SIGMA = GU
                  SGNDEF = -ONE
               END IF
            END IF
   50    CONTINUE
!
!        Find the base L D L^T representation
!
         WORK( 3*IN ) = ONE
         DELTA = EPS
         TAU = SGNDEF*NRM
   60    CONTINUE
         SIGMA = SIGMA - DELTA*TAU
         WORK( 1 ) = D( IBEGIN ) - SIGMA
         J = IBEGIN
         DO 70 I = 1, IN - 1
            WORK( 2*IN+I ) = ONE / WORK( 2*I-1 )
            TMP1 = E( J )*WORK( 2*IN+I )
            WORK( 2*I+1 ) = ( D( J+1 )-SIGMA ) - TMP1*E( J )
            WORK( 2*I ) = TMP1
            J = J + 1
   70    CONTINUE
         DO 80 I = IN, 1, -1
            TMP1 = SGNDEF*WORK( 2*I-1 )
            IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT. &
                ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
               DELTA = TWO*DELTA
               GO TO 60
            END IF
            J = J - 1
   80    CONTINUE
!
         J = IBEGIN
         D( IBEGIN ) = WORK( 1 )
         WORK( 1 ) = ABS( WORK( 1 ) )
         DO 90 I = 1, IN - 1
            TMP1 = E( J )
            E( J ) = WORK( 2*I )
            WORK( 2*I ) = ABS( TMP1*WORK( 2*I ) )
            J = J + 1
            D( J ) = WORK( 2*I+1 )
            WORK( 2*I+1 ) = ABS( WORK( 2*I+1 ) )
   90    CONTINUE
!
         CALL DLASQ2( IN, WORK, INFO )
!
         TAU = SGNDEF*WORK( IN )
         WORK( 3*IN ) = ONE
         DELTA = TWO*EPS
  100    CONTINUE
         TAU = TAU*( ONE-DELTA )
!
         S = -TAU
         J = IBEGIN
         DO 110 I = 1, IN - 1
            WORK( I ) = D( J ) + S
            WORK( 2*IN+I ) = ONE / WORK( I )
!           WORK( N+I ) = ( E( I ) * D( I ) ) / WORK( I )
            WORK( IN+I ) = ( E( J )*D( J ) )*WORK( 2*IN+I )
            S = S*WORK( IN+I )*E( J ) - TAU
            J = J + 1
  110    CONTINUE
         WORK( IN ) = D( IEND ) + S
!
!        Checking to see if all the diagonal elements of the new
!        L D L^T representation have the same sign
!
         DO 120 I = IN, 1, -1
            TMP1 = SGNDEF*WORK( I )
            IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT. &
                ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
               DELTA = TWO*DELTA
               GO TO 100
            END IF
  120    CONTINUE
!
         SIGMA = SIGMA + TAU
         CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
         CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
         WOFF( JBLK ) = SIGMA
!
!        Update the n Gerschgorin intervals
!
         DO 130 I = IBEGIN, IEND
            GERSCH( 2*I-1 ) = GERSCH( 2*I-1 ) - SIGMA
            GERSCH( 2*I ) = GERSCH( 2*I ) - SIGMA
  130    CONTINUE
!
!        Compute the eigenvalues of L D L^T.
!
         J = IBEGIN
         DO 140 I = 1, IN - 1
            WORK( 2*I-1 ) = ABS( D( J ) )
            WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
            J = J + 1
  140    CONTINUE
         WORK( 2*IN-1 ) = ABS( D( IEND ) )
!
         CALL DLASQ2( IN, WORK, INFO )
!
         J = IBEGIN
         IF( SGNDEF.GT.ZERO ) THEN
            DO 150 I = 1, IN
               W( J ) = WORK( IN-I+1 )
               J = J + 1
  150       CONTINUE
         ELSE
            DO 160 I = 1, IN
               W( J ) = -WORK( I )
               J = J + 1
  160       CONTINUE
         END IF
         IBEGIN = IEND + 1
  170 CONTINUE
      M = N
!
      RETURN
!
!     End of DLARRE
!
      END
      SUBROUTINE DLARRF( N, D, L, LD, LLD, IFIRST, ILAST, W, DPLUS, &
                         LPLUS, WORK, IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), DPLUS( * ), L( * ), LD( * ), LLD( * ), &
                         LPLUS( * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  Given the initial representation L D L^T and its cluster of close
!  eigenvalues (in a relative measure), W( IFIRST ), W( IFIRST+1 ), ...
!  W( ILAST ), DLARRF finds a new relatively robust representation
!  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
!  eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D.
!
!  L       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the unit bidiagonal
!          matrix L.
!
!  LD      (input) DOUBLE PRECISION array, dimension (N-1)
!          The n-1 elements L(i)*D(i).
!
!  LLD     (input) DOUBLE PRECISION array, dimension (N-1)
!          The n-1 elements L(i)*L(i)*D(i).
!
!  IFIRST  (input) INTEGER
!          The index of the first eigenvalue in the cluster.
!
!  ILAST   (input) INTEGER
!          The index of the last eigenvalue in the cluster.
!
!  W       (input/output) DOUBLE PRECISION array, dimension (N)
!          On input, the eigenvalues of L D L^T in ascending order.
!          W( IFIRST ) through W( ILAST ) form the cluster of relatively
!          close eigenalues.
!          On output, W( IFIRST ) thru' W( ILAST ) are estimates of the
!          corresponding eigenvalues of L(+) D(+) L(+)^T.
!
!  SIGMA   (input) DOUBLE PRECISION
!          The shift used to form L(+) D(+) L(+)^T.
!
!  DPLUS   (output) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D(+).
!
!  LPLUS   (output) DOUBLE PRECISION array, dimension (N)
!          The first (n-1) elements of LPLUS contain the subdiagonal
!          elements of the unit bidiagonal matrix L(+). LPLUS( N ) is
!          set to SIGMA.
!
!  WORK    (input) DOUBLE PRECISION array, dimension (???)
!          Workspace.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO
      PARAMETER          ( ZERO = 0.0D0, TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   DELTA, EPS, S, SIGMA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      EPS = DLAMCH( 'Precision' )
      IF( IFIRST.EQ.1 ) THEN
         SIGMA = W( IFIRST )
      ELSE IF( ILAST.EQ.N ) THEN
         SIGMA = W( ILAST )
      ELSE
         INFO = 1
         RETURN
      END IF
!
!     Compute the new relatively robust representation (RRR)
!
      DELTA = TWO*EPS
   10 CONTINUE
      IF( IFIRST.EQ.1 ) THEN
         SIGMA = SIGMA - ABS( SIGMA )*DELTA
      ELSE
         SIGMA = SIGMA + ABS( SIGMA )*DELTA
      END IF
      S = -SIGMA
      DO 20 I = 1, N - 1
         DPLUS( I ) = D( I ) + S
         LPLUS( I ) = LD( I ) / DPLUS( I )
         S = S*LPLUS( I )*L( I ) - SIGMA
   20 CONTINUE
      DPLUS( N ) = D( N ) + S
      IF( IFIRST.EQ.1 ) THEN
         DO 30 I = 1, N
            IF( DPLUS( I ).LT.ZERO ) THEN
               DELTA = TWO*DELTA
               GO TO 10
            END IF
   30    CONTINUE
      ELSE
         DO 40 I = 1, N
            IF( DPLUS( I ).GT.ZERO ) THEN
               DELTA = TWO*DELTA
               GO TO 10
            END IF
   40    CONTINUE
      END IF
      DO 50 I = IFIRST, ILAST
         W( I ) = W( I ) - SIGMA
   50 CONTINUE
      LPLUS( N ) = SIGMA
!
      RETURN
!
!     End of DLARRF
!
      END
      SUBROUTINE DLARRV( N, D, L, ISPLIT, M, W, IBLOCK, GERSCH, TOL, Z, &
                         LDZ, ISUPPZ, WORK, IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDZ, M, N
      DOUBLE PRECISION   TOL
!     ..
!     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), ISUPPZ( * ), &
                         IWORK( * )
      DOUBLE PRECISION   D( * ), GERSCH( * ), L( * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DLARRV computes the eigenvectors of the tridiagonal matrix
!  T = L D L^T given L, D and the eigenvalues of L D L^T.
!  The input eigenvalues should have high relative accuracy with
!  respect to the entries of L and D. The desired accuracy of the
!  output can be specified by the input parameter TOL.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the diagonal matrix D.
!          On exit, D may be overwritten.
!
!  L       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the unit
!          bidiagonal matrix L in elements 1 to N-1 of L. L(N) need
!          not be set. On exit, L is overwritten.
!
!  ISPLIT  (input) INTEGER array, dimension (N)
!          The splitting points, at which T breaks up into submatrices.
!          The first submatrix consists of rows/columns 1 to
!          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
!          through ISPLIT( 2 ), etc.
!
!  TOL     (input) DOUBLE PRECISION
!          The absolute error tolerance for the
!          eigenvalues/eigenvectors.
!          Errors in the input eigenvalues must be bounded by TOL.
!          The eigenvectors output have residual norms
!          bounded by TOL, and the dot products between different
!          eigenvectors are bounded by TOL. TOL must be at least
!          N*EPS*|T|, where EPS is the machine precision and |T| is
!          the 1-norm of the tridiagonal matrix.
!
!  M       (input) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (input) DOUBLE PRECISION array, dimension (N)
!          The first M elements of W contain the eigenvalues for
!          which eigenvectors are to be computed.  The eigenvalues
!          should be grouped by split-off block and ordered from
!          smallest to largest within the block ( The output array
!          W from DLARRE is expected here ).
!          Errors in W must be bounded by TOL (see above).
!
!  IBLOCK  (input) INTEGER array, dimension (N)
!          The submatrix indices associated with the corresponding
!          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
!          the first submatrix from the top, =2 if W(i) belongs to
!          the second submatrix, etc.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix T
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
!          The support of the eigenvectors in Z, i.e., the indices
!          indicating the nonzero elements in Z. The i-th eigenvector
!          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!          ISUPPZ( 2*i ).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (13*N)
!
!  IWORK   (workspace) INTEGER array, dimension (6*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = 1, internal error in DLARRB
!                if INFO = 2, internal error in DSTEIN
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MGSSIZ
      PARAMETER          ( MGSSIZ = 20 )
      DOUBLE PRECISION   ZERO, ONE, FOUR
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            MGSCLS
      INTEGER            I, IBEGIN, IEND, IINDC1, IINDC2, IINDR, IINDWK, &
                         IINFO, IM, IN, INDERR, INDGAP, INDLD, INDLLD, &
                         INDWRK, ITER, ITMP1, ITMP2, J, JBLK, K, KTOT, &
                         LSBDPT, MAXITR, NCLUS, NDEPTH, NDONE, NEWCLS, &
                         NEWFRS, NEWFTT, NEWLST, NEWSIZ, NSPLIT, OLDCLS, &
                         OLDFST, OLDIEN, OLDLST, OLDNCL, P, Q
      DOUBLE PRECISION   EPS, GAP, LAMBDA, MGSTOL, MINGMA, MINRGP, &
                         NRMINV, RELGAP, RELTOL, RESID, RQCORR, SIGMA, &
                         TMP1, ZTZ
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMCH, DNRM2
      EXTERNAL           DDOT, DLAMCH, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLAR1V, DLARRB, DLARRF, DLASET, &
                         DSCAL, DSTEIN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
!     ..
!     .. Local Arrays ..
      INTEGER            TEMP( 1 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INDERR = N + 1
      INDLD = 2*N
      INDLLD = 3*N
      INDGAP = 4*N
      INDWRK = 5*N + 1
!
      IINDR = N
      IINDC1 = 2*N
      IINDC2 = 3*N
      IINDWK = 4*N + 1
!
      EPS = DLAMCH( 'Precision' )
!
      DO 10 I = 1, 2*N
         IWORK( I ) = 0
   10 CONTINUE
      DO 20 I = 1, M
         WORK( INDERR+I-1 ) = EPS*ABS( W( I ) )
   20 CONTINUE
      CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
      MGSTOL = 5.0D0*EPS
!
      NSPLIT = IBLOCK( M )
      IBEGIN = 1
      DO 170 JBLK = 1, NSPLIT
         IEND = ISPLIT( JBLK )
!
!        Find the eigenvectors of the submatrix indexed IBEGIN
!        through IEND.
!
         IF( IBEGIN.EQ.IEND ) THEN
            Z( IBEGIN, IBEGIN ) = ONE
            ISUPPZ( 2*IBEGIN-1 ) = IBEGIN
            ISUPPZ( 2*IBEGIN ) = IBEGIN
            IBEGIN = IEND + 1
            GO TO 170
         END IF
         OLDIEN = IBEGIN - 1
         IN = IEND - OLDIEN
         RELTOL = MIN( 1.0D-2, ONE / DBLE( IN ) )
         IM = IN
         CALL DCOPY( IM, W( IBEGIN ), 1, WORK, 1 )
         DO 30 I = 1, IN - 1
            WORK( INDGAP+I ) = WORK( I+1 ) - WORK( I )
   30    CONTINUE
         WORK( INDGAP+IN ) = MAX( ABS( WORK( IN ) ), EPS )
         NDONE = 0
!
         NDEPTH = 0
         LSBDPT = 1
         NCLUS = 1
         IWORK( IINDC1+1 ) = 1
         IWORK( IINDC1+2 ) = IN
!
!        While( NDONE.LT.IM ) do
!
   40    CONTINUE
         IF( NDONE.LT.IM ) THEN
            OLDNCL = NCLUS
            NCLUS = 0
            LSBDPT = 1 - LSBDPT
            DO 150 I = 1, OLDNCL
               IF( LSBDPT.EQ.0 ) THEN
                  OLDCLS = IINDC1
                  NEWCLS = IINDC2
               ELSE
                  OLDCLS = IINDC2
                  NEWCLS = IINDC1
               END IF
!
!              If NDEPTH > 1, retrieve the relatively robust
!              representation (RRR) and perform limited bisection
!              (if necessary) to get approximate eigenvalues.
!
               J = OLDCLS + 2*I
               OLDFST = IWORK( J-1 )
               OLDLST = IWORK( J )
               IF( NDEPTH.GT.0 ) THEN
                  J = OLDIEN + OLDFST
                  CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
                  CALL DCOPY( IN, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), 1 )
                  SIGMA = L( IEND )
               END IF
               K = IBEGIN
               DO 50 J = 1, IN - 1
                  WORK( INDLD+J ) = D( K )*L( K )
                  WORK( INDLLD+J ) = WORK( INDLD+J )*L( K )
                  K = K + 1
   50          CONTINUE
               IF( NDEPTH.GT.0 ) THEN
                  CALL DLARRB( IN, D( IBEGIN ), L( IBEGIN ), &
                               WORK( INDLD+1 ), WORK( INDLLD+1 ), &
                               OLDFST, OLDLST, SIGMA, RELTOL, WORK, &
                               WORK( INDGAP+1 ), WORK( INDERR ), &
                               WORK( INDWRK ), IWORK( IINDWK ), IINFO )
                  IF( IINFO.NE.0 ) THEN
                     INFO = 1
                     RETURN
                  END IF
               END IF
!
!              Classify eigenvalues of the current representation (RRR)
!              as (i) isolated, (ii) loosely clustered or (iii) tightly
!              clustered
!
               NEWFRS = OLDFST
               DO 140 J = OLDFST, OLDLST
                  IF( J.EQ.OLDLST .OR. WORK( INDGAP+J ).GE.RELTOL* &
                      ABS( WORK( J ) ) ) THEN
                     NEWLST = J
                  ELSE
!
!                    continue (to the next loop)
!
                     RELGAP = WORK( INDGAP+J ) / ABS( WORK( J ) )
                     IF( J.EQ.NEWFRS ) THEN
                        MINRGP = RELGAP
                     ELSE
                        MINRGP = MIN( MINRGP, RELGAP )
                     END IF
                     GO TO 140
                  END IF
                  NEWSIZ = NEWLST - NEWFRS + 1
                  MAXITR = 10
                  NEWFTT = OLDIEN + NEWFRS
                  IF( NEWSIZ.GT.1 ) THEN
                     MGSCLS = NEWSIZ.LE.MGSSIZ .AND. MINRGP.GE.MGSTOL
                     IF( .NOT.MGSCLS ) THEN
                        CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ), &
                                     WORK( INDLD+1 ), WORK( INDLLD+1 ), &
                                     NEWFRS, NEWLST, WORK, &
                                     Z( IBEGIN, NEWFTT ), &
                                     Z( IBEGIN, NEWFTT+1 ), &
                                     WORK( INDWRK ), IWORK( IINDWK ), &
                                     INFO )
                        IF( INFO.EQ.0 ) THEN
                           NCLUS = NCLUS + 1
                           K = NEWCLS + 2*NCLUS
                           IWORK( K-1 ) = NEWFRS
                           IWORK( K ) = NEWLST
                        ELSE
                           INFO = 0
                           IF( MINRGP.GE.MGSTOL ) THEN
                              MGSCLS = .TRUE.
                           ELSE
!
!                             Call DSTEIN to process this tight cluster.
!                             This happens only if MINRGP <= MGSTOL
!                             and DLARRF returns INFO = 1. The latter
!                             means that a new RRR to "break" the
!                             cluster could not be found.
!
                              WORK( INDWRK ) = D( IBEGIN )
                              DO 60 K = 1, IN - 1
                                 WORK( INDWRK+K ) = D( IBEGIN+K ) + &
                                                    WORK( INDLLD+K )
   60                         CONTINUE
                              DO 70 K = 1, NEWSIZ
                                 IWORK( IINDWK+K-1 ) = 1
   70                         CONTINUE
                              DO 80 K = NEWFRS, NEWLST
                                 ISUPPZ( 2*( IBEGIN+K )-3 ) = 1
                                 ISUPPZ( 2*( IBEGIN+K )-2 ) = IN
   80                         CONTINUE
                              TEMP( 1 ) = IN
                              CALL DSTEIN( IN, WORK( INDWRK ), &
                                           WORK( INDLD+1 ), NEWSIZ, &
                                           WORK( NEWFRS ), &
                                           IWORK( IINDWK ), TEMP( 1 ), &
                                           Z( IBEGIN, NEWFTT ), LDZ, &
                                           WORK( INDWRK+IN ), &
                                           IWORK( IINDWK+IN ), &
                                           IWORK( IINDWK+2*IN ), IINFO )
                              IF( IINFO.NE.0 ) THEN
                                 INFO = 2
                                 RETURN
                              END IF
                              NDONE = NDONE + NEWSIZ
                           END IF
                        END IF
                     END IF
                  ELSE
                     MGSCLS = .FALSE.
                  END IF
                  IF( NEWSIZ.EQ.1 .OR. MGSCLS ) THEN
                     KTOT = NEWFTT
                     DO 100 K = NEWFRS, NEWLST
                        ITER = 0
   90                   CONTINUE
                        LAMBDA = WORK( K )
                        CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ), &
                                     L( IBEGIN ), WORK( INDLD+1 ), &
                                     WORK( INDLLD+1 ), &
                                     GERSCH( 2*OLDIEN+1 ), &
                                     Z( IBEGIN, KTOT ), ZTZ, MINGMA, &
                                     IWORK( IINDR+KTOT ), &
                                     ISUPPZ( 2*KTOT-1 ), &
                                     WORK( INDWRK ) )
                        TMP1 = ONE / ZTZ
                        NRMINV = SQRT( TMP1 )
                        RESID = ABS( MINGMA )*NRMINV
                        RQCORR = MINGMA*TMP1
                        IF( K.EQ.IN ) THEN
                           GAP = WORK( INDGAP+K-1 )
                        ELSE IF( K.EQ.1 ) THEN
                           GAP = WORK( INDGAP+K )
                        ELSE
                           GAP = MIN( WORK( INDGAP+K-1 ), &
                                 WORK( INDGAP+K ) )
                        END IF
                        ITER = ITER + 1
                        IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT. &
                            FOUR*EPS*ABS( LAMBDA ) ) THEN
                           WORK( K ) = LAMBDA + RQCORR
                           IF( ITER.LT.MAXITR ) THEN
                              GO TO 90
                           END IF
                        END IF
                        IWORK( KTOT ) = 1
                        IF( NEWSIZ.EQ.1 ) &
                           NDONE = NDONE + 1
                        CALL DSCAL( IN, NRMINV, Z( IBEGIN, KTOT ), 1 )
                        KTOT = KTOT + 1
  100                CONTINUE
                     IF( NEWSIZ.GT.1 ) THEN
                        ITMP1 = ISUPPZ( 2*NEWFTT-1 )
                        ITMP2 = ISUPPZ( 2*NEWFTT )
                        KTOT = OLDIEN + NEWLST
                        DO 120 P = NEWFTT + 1, KTOT
                           DO 110 Q = NEWFTT, P - 1
                              TMP1 = -DDOT( IN, Z( IBEGIN, P ), 1, &
                                     Z( IBEGIN, Q ), 1 )
                              CALL DAXPY( IN, TMP1, Z( IBEGIN, Q ), 1, &
                                          Z( IBEGIN, P ), 1 )
  110                      CONTINUE
                           TMP1 = ONE / DNRM2( IN, Z( IBEGIN, P ), 1 )
                           CALL DSCAL( IN, TMP1, Z( IBEGIN, P ), 1 )
                           ITMP1 = MIN( ITMP1, ISUPPZ( 2*P-1 ) )
                           ITMP2 = MAX( ITMP2, ISUPPZ( 2*P ) )
  120                   CONTINUE
                        DO 130 P = NEWFTT, KTOT
                           ISUPPZ( 2*P-1 ) = ITMP1
                           ISUPPZ( 2*P ) = ITMP2
  130                   CONTINUE
                        NDONE = NDONE + NEWSIZ
                     END IF
                  END IF
                  NEWFRS = J + 1
  140          CONTINUE
  150       CONTINUE
            NDEPTH = NDEPTH + 1
            GO TO 40
         END IF
         J = 2*IBEGIN
         DO 160 I = IBEGIN, IEND
            ISUPPZ( J-1 ) = ISUPPZ( J-1 ) + OLDIEN
            ISUPPZ( J ) = ISUPPZ( J ) + OLDIEN
            J = J + 2
  160    CONTINUE
         IBEGIN = IEND + 1
  170 CONTINUE
!
      RETURN
!
!     End of DLARRV
!
      END
      SUBROUTINE DLARTG( F, G, CS, SN, R )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   CS, F, G, R, SN
!     ..
!
!  Purpose
!  =======
!
!  DLARTG generate a plane rotation so that
!
!     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
!     [ -SN  CS  ]     [ G ]     [ 0 ]
!
!  This is a slower, more accurate version of the BLAS1 routine DROTG,
!  with the following other differences:
!     F and G are unchanged on return.
!     If G=0, then CS=1 and SN=0.
!     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
!        floating point operations (saves work in DBDSQR when
!        there are zeros on the diagonal).
!
!  If F exceeds G in magnitude, CS will be positive.
!
!  Arguments
!  =========
!
!  F       (input) DOUBLE PRECISION
!          The first component of vector to be rotated.
!
!  G       (input) DOUBLE PRECISION
!          The second component of vector to be rotated.
!
!  CS      (output) DOUBLE PRECISION
!          The cosine of the rotation.
!
!  SN      (output) DOUBLE PRECISION
!          The sine of the rotation.
!
!  R       (output) DOUBLE PRECISION
!          The nonzero component of the rotated vector.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FIRST
      INTEGER            COUNT, I
      DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, SQRT
!     ..
!     .. Save statement ..
      SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         SAFMIN = DLAMCH( 'S' )
         EPS = DLAMCH( 'E' )
         SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / &
                  LOG( DLAMCH( 'B' ) ) / TWO )
         SAFMX2 = ONE / SAFMN2
      END IF
      IF( G.EQ.ZERO ) THEN
         CS = ONE
         SN = ZERO
         R = F
      ELSE IF( F.EQ.ZERO ) THEN
         CS = ZERO
         SN = ONE
         R = G
      ELSE
         F1 = F
         G1 = G
         SCALE = MAX( ABS( F1 ), ABS( G1 ) )
         IF( SCALE.GE.SAFMX2 ) THEN
            COUNT = 0
   10       CONTINUE
            COUNT = COUNT + 1
            F1 = F1*SAFMN2
            G1 = G1*SAFMN2
            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
            IF( SCALE.GE.SAFMX2 ) &
               GO TO 10
            R = SQRT( F1**2+G1**2 )
            CS = F1 / R
            SN = G1 / R
            DO 20 I = 1, COUNT
               R = R*SAFMX2
   20       CONTINUE
         ELSE IF( SCALE.LE.SAFMN2 ) THEN
            COUNT = 0
   30       CONTINUE
            COUNT = COUNT + 1
            F1 = F1*SAFMX2
            G1 = G1*SAFMX2
            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
            IF( SCALE.LE.SAFMN2 ) &
               GO TO 30
            R = SQRT( F1**2+G1**2 )
            CS = F1 / R
            SN = G1 / R
            DO 40 I = 1, COUNT
               R = R*SAFMN2
   40       CONTINUE
         ELSE
            R = SQRT( F1**2+G1**2 )
            CS = F1 / R
            SN = G1 / R
         END IF
         IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
            CS = -CS
            SN = -SN
            R = -R
         END IF
      END IF
      RETURN
!
!     End of DLARTG
!
      END
      SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCC, INCX, INCY, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( * ), S( * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARTV applies a vector of real plane rotations to elements of the
!  real vectors x and y. For i = 1,2,...,n
!
!     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )
!     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of plane rotations to be applied.
!
!  X       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCX)
!          The vector x.
!
!  INCX    (input) INTEGER
!          The increment between elements of X. INCX > 0.
!
!  Y       (input/output) DOUBLE PRECISION array,
!                         dimension (1+(N-1)*INCY)
!          The vector y.
!
!  INCY    (input) INTEGER
!          The increment between elements of Y. INCY > 0.
!
!  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!          The cosines of the plane rotations.
!
!  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!          The sines of the plane rotations.
!
!  INCC    (input) INTEGER
!          The increment between elements of C and S. INCC > 0.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IC, IX, IY
      DOUBLE PRECISION   XI, YI
!     ..
!     .. Executable Statements ..
!
      IX = 1
      IY = 1
      IC = 1
      DO 10 I = 1, N
         XI = X( IX )
         YI = Y( IY )
         X( IX ) = C( IC )*XI + S( IC )*YI
         Y( IY ) = C( IC )*YI - S( IC )*XI
         IX = IX + INCX
         IY = IY + INCY
         IC = IC + INCC
   10 CONTINUE
      RETURN
!
!     End of DLARTV
!
      END
      SUBROUTINE DLARUV( ISEED, N, X )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            N
!     ..
!     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   X( N )
!     ..
!
!  Purpose
!  =======
!
!  DLARUV returns a vector of n random real numbers from a uniform (0,1)
!  distribution (n <= 128).
!
!  This is an auxiliary routine called by DLARNV and ZLARNV.
!
!  Arguments
!  =========
!
!  ISEED   (input/output) INTEGER array, dimension (4)
!          On entry, the seed of the random number generator; the array
!          elements must be between 0 and 4095, and ISEED(4) must be
!          odd.
!          On exit, the seed is updated.
!
!  N       (input) INTEGER
!          The number of random numbers to be generated. N <= 128.
!
!  X       (output) DOUBLE PRECISION array, dimension (N)
!          The generated random numbers.
!
!  Further Details
!  ===============
!
!  This routine uses a multiplicative congruential method with modulus
!  2**48 and multiplier 33952834046453 (see G.S.Fishman,
!  'Multiplicative congruential random number generators with modulus
!  2**b: an exhaustive analysis for b = 32 and a partial analysis for
!  b = 48', Math. Comp. 189, pp 331-344, 1990).
!
!  48-bit integers are stored in 4 integer array elements with 12 bits
!  per element. Hence the routine is portable across machines with
!  integers of 32 bits or more.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      INTEGER            LV, IPW2
      DOUBLE PRECISION   R
      PARAMETER          ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
!     ..
!     .. Local Arrays ..
      INTEGER            MM( LV, 4 )
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MIN, MOD
!     ..
!     .. Data statements ..
      DATA               ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, &
                         2549 /
      DATA               ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, &
                         1145 /
      DATA               ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, &
                         2253 /
      DATA               ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, &
                         305 /
      DATA               ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, &
                         3301 /
      DATA               ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, &
                         1065 /
      DATA               ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, &
                         3133 /
      DATA               ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, &
                         2913 /
      DATA               ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, &
                         3285 /
      DATA               ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, &
                         1241 /
      DATA               ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, &
                         1197 /
      DATA               ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, &
                         3729 /
      DATA               ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, &
                         2501 /
      DATA               ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, &
                         1673 /
      DATA               ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, &
                         541 /
      DATA               ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, &
                         2753 /
      DATA               ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, &
                         949 /
      DATA               ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, &
                         2361 /
      DATA               ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, &
                         1165 /
      DATA               ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, &
                         4081 /
      DATA               ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, &
                         2725 /
      DATA               ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, &
                         3305 /
      DATA               ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, &
                         3069 /
      DATA               ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, &
                         3617 /
      DATA               ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, &
                         3733 /
      DATA               ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, &
                         409 /
      DATA               ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, &
                         2157 /
      DATA               ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, &
                         1361 /
      DATA               ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, &
                         3973 /
      DATA               ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, &
                         1865 /
      DATA               ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, &
                         2525 /
      DATA               ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, &
                         1409 /
      DATA               ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, &
                         3445 /
      DATA               ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, &
                         3577 /
      DATA               ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, &
                         77 /
      DATA               ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, &
                         3761 /
      DATA               ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, &
                         2149 /
      DATA               ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, &
                         1449 /
      DATA               ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, &
                         3005 /
      DATA               ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, &
                         225 /
      DATA               ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, &
                         85 /
      DATA               ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, &
                         3673 /
      DATA               ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, &
                         3117 /
      DATA               ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, &
                         3089 /
      DATA               ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, &
                         1349 /
      DATA               ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, &
                         2057 /
      DATA               ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, &
                         413 /
      DATA               ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, &
                         65 /
      DATA               ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, &
                         1845 /
      DATA               ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, &
                         697 /
      DATA               ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, &
                         3085 /
      DATA               ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, &
                         3441 /
      DATA               ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, &
                         1573 /
      DATA               ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, &
                         3689 /
      DATA               ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, &
                         2941 /
      DATA               ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, &
                         929 /
      DATA               ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, &
                         533 /
      DATA               ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, &
                         2841 /
      DATA               ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, &
                         4077 /
      DATA               ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, &
                         721 /
      DATA               ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, &
                         2821 /
      DATA               ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, &
                         2249 /
      DATA               ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, &
                         2397 /
      DATA               ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, &
                         2817 /
      DATA               ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, &
                         245 /
      DATA               ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, &
                         1913 /
      DATA               ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, &
                         1997 /
      DATA               ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, &
                         3121 /
      DATA               ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, &
                         997 /
      DATA               ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, &
                         1833 /
      DATA               ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, &
                         2877 /
      DATA               ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, &
                         1633 /
      DATA               ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, &
                         981 /
      DATA               ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, &
                         2009 /
      DATA               ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, &
                         941 /
      DATA               ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, &
                         2449 /
      DATA               ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, &
                         197 /
      DATA               ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, &
                         2441 /
      DATA               ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, &
                         285 /
      DATA               ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, &
                         1473 /
      DATA               ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, &
                         2741 /
      DATA               ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, &
                         3129 /
      DATA               ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, &
                         909 /
      DATA               ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, &
                         2801 /
      DATA               ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, &
                         421 /
      DATA               ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, &
                         4073 /
      DATA               ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, &
                         2813 /
      DATA               ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, &
                         2337 /
      DATA               ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, &
                         1429 /
      DATA               ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, &
                         1177 /
      DATA               ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, &
                         1901 /
      DATA               ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, &
                         81 /
      DATA               ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, &
                         1669 /
      DATA               ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, &
                         2633 /
      DATA               ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, &
                         2269 /
      DATA               ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, &
                         129 /
      DATA               ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, &
                         1141 /
      DATA               ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, &
                         249 /
      DATA               ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, &
                         3917 /
      DATA               ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, &
                         2481 /
      DATA               ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, &
                         3941 /
      DATA               ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, &
                         2217 /
      DATA               ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, &
                         2749 /
      DATA               ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, &
                         3041 /
      DATA               ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, &
                         1877 /
      DATA               ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, &
                         345 /
      DATA               ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, &
                         2861 /
      DATA               ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, &
                         1809 /
      DATA               ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, &
                         3141 /
      DATA               ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, &
                         2825 /
      DATA               ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, &
                         157 /
      DATA               ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, &
                         2881 /
      DATA               ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, &
                         3637 /
      DATA               ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, &
                         1465 /
      DATA               ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, &
                         2829 /
      DATA               ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, &
                         2161 /
      DATA               ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, &
                         3365 /
      DATA               ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, &
                         361 /
      DATA               ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, &
                         2685 /
      DATA               ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, &
                         3745 /
      DATA               ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, &
                         2325 /
      DATA               ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, &
                         3609 /
      DATA               ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, &
                         3821 /
      DATA               ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, &
                         3537 /
      DATA               ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, &
                         517 /
      DATA               ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, &
                         3017 /
      DATA               ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, &
                         2141 /
      DATA               ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, &
                         1537 /
!     ..
!     .. Executable Statements ..
!
      I1 = ISEED( 1 )
      I2 = ISEED( 2 )
      I3 = ISEED( 3 )
      I4 = ISEED( 4 )
!
      DO 10 I = 1, MIN( N, LV )
!
!        Multiply the seed by i-th power of the multiplier modulo 2**48
!
         IT4 = I4*MM( I, 4 )
         IT3 = IT4 / IPW2
         IT4 = IT4 - IPW2*IT3
         IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
         IT2 = IT3 / IPW2
         IT3 = IT3 - IPW2*IT2
         IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
         IT1 = IT2 / IPW2
         IT2 = IT2 - IPW2*IT1
         IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + &
               I4*MM( I, 1 )
         IT1 = MOD( IT1, IPW2 )
!
!        Convert 48-bit integer to a real number in the interval (0,1)
!
         X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* &
                  DBLE( IT4 ) ) ) )
   10 CONTINUE
!
!     Return final value of seed
!
      ISEED( 1 ) = IT1
      ISEED( 2 ) = IT2
      ISEED( 3 ) = IT3
      ISEED( 4 ) = IT4
      RETURN
!
!     End of DLARUV
!
      END
      SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, L, LDC, M, N
      DOUBLE PRECISION   TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLARZ applies a real elementary reflector H to a real M-by-N
!  matrix C, from either the left or the right. H is represented in the
!  form
!
!        H = I - tau * v * v'
!
!  where tau is a real scalar and v is a real vector.
!
!  If tau = 0, then H is taken to be the unit matrix.
!
!
!  H is a product of k elementary reflectors as returned by DTZRZF.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': form  H * C
!          = 'R': form  C * H
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  L       (input) INTEGER
!          The number of entries of the vector V containing
!          the meaningful part of the Householder vectors.
!          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!
!  V       (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
!          The vector v in the representation of H as returned by
!          DTZRZF. V is not used if TAU = 0.
!
!  INCV    (input) INTEGER
!          The increment between elements of v. INCV <> 0.
!
!  TAU     (input) DOUBLE PRECISION
!          The value tau in the representation of H.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!          or C * H if SIDE = 'R'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                         (N) if SIDE = 'L'
!                      or (M) if SIDE = 'R'
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        Form  H * C
!
         IF( TAU.NE.ZERO ) THEN
!
!           w( 1:n ) = C( 1, 1:n )
!
            CALL DCOPY( N, C, LDC, WORK, 1 )
!
!           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
!
            CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V, &
                        INCV, ONE, WORK, 1 )
!
!           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
!
            CALL DAXPY( N, -TAU, WORK, 1, C, LDC )
!
!           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
!                               tau * v( 1:l ) * w( 1:n )'
!
            CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ), &
                       LDC )
         END IF
!
      ELSE
!
!        Form  C * H
!
         IF( TAU.NE.ZERO ) THEN
!
!           w( 1:m ) = C( 1:m, 1 )
!
            CALL DCOPY( M, C, 1, WORK, 1 )
!
!           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
!
            CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC, &
                        V, INCV, ONE, WORK, 1 )
!
!           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
!
            CALL DAXPY( M, -TAU, WORK, 1, C, 1 )
!
!           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
!                               tau * w( 1:m ) * v( 1:l )'
!
            CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ), &
                       LDC )
!
         END IF
!
      END IF
!
      RETURN
!
!     End of DLARZ
!
      END
      SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, &
                         LDV, T, LDT, C, LDC, WORK, LDWORK )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     December 1, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, L, LDC, LDT, LDV, LDWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ), &
                         WORK( LDWORK, * )
!     ..
!
!  Purpose
!  =======
!
!  DLARZB applies a real block reflector H or its transpose H**T to
!  a real distributed M-by-N  C from the left or the right.
!
!  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply H or H' from the Left
!          = 'R': apply H or H' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply H (No transpose)
!          = 'C': apply H' (Transpose)
!
!  DIRECT  (input) CHARACTER*1
!          Indicates how H is formed from a product of elementary
!          reflectors
!          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
!          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!
!  STOREV  (input) CHARACTER*1
!          Indicates how the vectors which define the elementary
!          reflectors are stored:
!          = 'C': Columnwise                        (not supported yet)
!          = 'R': Rowwise
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  K       (input) INTEGER
!          The order of the matrix T (= the number of elementary
!          reflectors whose product defines the block reflector).
!
!  L       (input) INTEGER
!          The number of columns of the matrix V containing the
!          meaningful part of the Householder reflectors.
!          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!
!  V       (input) DOUBLE PRECISION array, dimension (LDV,NV).
!          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V.
!          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
!
!  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
!          The triangular K-by-K matrix T in the representation of the
!          block reflector.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= K.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
!
!  LDWORK  (input) INTEGER
!          The leading dimension of the array WORK.
!          If SIDE = 'L', LDWORK >= max(1,N);
!          if SIDE = 'R', LDWORK >= max(1,M).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, INFO, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DTRMM, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( M.LE.0 .OR. N.LE.0 ) &
         RETURN
!
!     Check for currently supported options
!
      INFO = 0
      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLARZB', -INFO )
         RETURN
      END IF
!
      IF( LSAME( TRANS, 'N' ) ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        Form  H * C  or  H' * C
!
!        W( 1:n, 1:k ) = C( 1:k, 1:n )'
!
         DO 10 J = 1, K
            CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10    CONTINUE
!
!        W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
!                        C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
!
         IF( L.GT.0 ) &
            CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE, &
                        C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
!
!        W( 1:n, 1:k ) = W( 1:n, 1:k ) * T'  or  W( 1:m, 1:k ) * T
!
         CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T, &
                     LDT, WORK, LDWORK )
!
!        C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
!
         DO 30 J = 1, N
            DO 20 I = 1, K
               C( I, J ) = C( I, J ) - WORK( J, I )
   20       CONTINUE
   30    CONTINUE
!
!        C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
!                            V( 1:k, 1:l )' * W( 1:n, 1:k )'
!
         IF( L.GT.0 ) &
            CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV, &
                        WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
!
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!        Form  C * H  or  C * H'
!
!        W( 1:m, 1:k ) = C( 1:m, 1:k )
!
         DO 40 J = 1, K
            CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40    CONTINUE
!
!        W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
!                        C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
!
         IF( L.GT.0 ) &
            CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE, &
                        C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
!
!        W( 1:m, 1:k ) = W( 1:m, 1:k ) * T  or  W( 1:m, 1:k ) * T'
!
         CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T, &
                     LDT, WORK, LDWORK )
!
!        C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
!
         DO 60 J = 1, K
            DO 50 I = 1, M
               C( I, J ) = C( I, J ) - WORK( I, J )
   50       CONTINUE
   60    CONTINUE
!
!        C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
!                            W( 1:m, 1:k ) * V( 1:k, 1:l )
!
         IF( L.GT.0 ) &
            CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE, &
                        WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
!
      END IF
!
      RETURN
!
!     End of DLARZB
!
      END
      SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
!     ..
!
!  Purpose
!  =======
!
!  DLARZT forms the triangular factor T of a real block reflector
!  H of order > n, which is defined as a product of k elementary
!  reflectors.
!
!  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!
!  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!
!  If STOREV = 'C', the vector which defines the elementary reflector
!  H(i) is stored in the i-th column of the array V, and
!
!     H  =  I - V * T * V'
!
!  If STOREV = 'R', the vector which defines the elementary reflector
!  H(i) is stored in the i-th row of the array V, and
!
!     H  =  I - V' * T * V
!
!  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
!
!  Arguments
!  =========
!
!  DIRECT  (input) CHARACTER*1
!          Specifies the order in which the elementary reflectors are
!          multiplied to form the block reflector:
!          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
!          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!
!  STOREV  (input) CHARACTER*1
!          Specifies how the vectors which define the elementary
!          reflectors are stored (see also Further Details):
!          = 'C': columnwise                        (not supported yet)
!          = 'R': rowwise
!
!  N       (input) INTEGER
!          The order of the block reflector H. N >= 0.
!
!  K       (input) INTEGER
!          The order of the triangular factor T (= the number of
!          elementary reflectors). K >= 1.
!
!  V       (input/output) DOUBLE PRECISION array, dimension
!                               (LDV,K) if STOREV = 'C'
!                               (LDV,N) if STOREV = 'R'
!          The matrix V. See further details.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V.
!          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i).
!
!  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
!          The k by k triangular factor T of the block reflector.
!          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
!          lower triangular. The rest of the array is not used.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= K.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  The shape of the matrix V and the storage of the vectors which define
!  the H(i) is best illustrated by the following example with n = 5 and
!  k = 3. The elements equal to 1 are not stored; the corresponding
!  array elements are modified but restored on exit. The rest of the
!  array is not used.
!
!  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
!
!                                              ______V_____
!         ( v1 v2 v3 )                        /            \
!         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
!     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
!         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
!         ( v1 v2 v3 )
!            .  .  .
!            .  .  .
!            1  .  .
!               1  .
!                  1
!
!  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!
!                                                        ______V_____
!            1                                          /            \
!            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
!            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
!            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
!            .  .  .
!         ( v1 v2 v3 )
!         ( v1 v2 v3 )
!     V = ( v1 v2 v3 )
!         ( v1 v2 v3 )
!         ( v1 v2 v3 )
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, INFO, J
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DTRMV, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
!     Check for currently supported options
!
      INFO = 0
      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLARZT', -INFO )
         RETURN
      END IF
!
      DO 20 I = K, 1, -1
         IF( TAU( I ).EQ.ZERO ) THEN
!
!           H(i)  =  I
!
            DO 10 J = I, K
               T( J, I ) = ZERO
   10       CONTINUE
         ELSE
!
!           general case
!
            IF( I.LT.K ) THEN
!
!              T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
!
               CALL DGEMV( 'No transpose', K-I, N, -TAU( I ), &
                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, &
                           T( I+1, I ), 1 )
!
!              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
!
               CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, &
                           T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
            END IF
            T( I, I ) = TAU( I )
         END IF
   20 CONTINUE
      RETURN
!
!     End of DLARZT
!
      END
      SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   F, G, H, SSMAX, SSMIN
!     ..
!
!  Purpose
!  =======
!
!  DLAS2  computes the singular values of the 2-by-2 matrix
!     [  F   G  ]
!     [  0   H  ].
!  On return, SSMIN is the smaller singular value and SSMAX is the
!  larger singular value.
!
!  Arguments
!  =========
!
!  F       (input) DOUBLE PRECISION
!          The (1,1) element of the 2-by-2 matrix.
!
!  G       (input) DOUBLE PRECISION
!          The (1,2) element of the 2-by-2 matrix.
!
!  H       (input) DOUBLE PRECISION
!          The (2,2) element of the 2-by-2 matrix.
!
!  SSMIN   (output) DOUBLE PRECISION
!          The smaller singular value.
!
!  SSMAX   (output) DOUBLE PRECISION
!          The larger singular value.
!
!  Further Details
!  ===============
!
!  Barring over/underflow, all output quantities are correct to within
!  a few units in the last place (ulps), even in the absence of a guard
!  digit in addition/subtraction.
!
!  In IEEE arithmetic, the code works correctly if one matrix element is
!  infinite.
!
!  Overflow will not occur unless the largest singular value itself
!  overflows, or is within a few ulps of overflow. (On machines with
!  partial overflow, like the Cray, overflow may occur if the largest
!  singular value is within a factor of 2 of overflow.)
!
!  Underflow is harmless if underflow is gradual. Otherwise, results
!  may correspond to a matrix modified by perturbations of size near
!  the underflow threshold.
!
!  ====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      FA = ABS( F )
      GA = ABS( G )
      HA = ABS( H )
      FHMN = MIN( FA, HA )
      FHMX = MAX( FA, HA )
      IF( FHMN.EQ.ZERO ) THEN
         SSMIN = ZERO
         IF( FHMX.EQ.ZERO ) THEN
            SSMAX = GA
         ELSE
            SSMAX = MAX( FHMX, GA )*SQRT( ONE+ &
                    ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
         END IF
      ELSE
         IF( GA.LT.FHMX ) THEN
            AS = ONE + FHMN / FHMX
            AT = ( FHMX-FHMN ) / FHMX
            AU = ( GA / FHMX )**2
            C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
            SSMIN = FHMN*C
            SSMAX = FHMX / C
         ELSE
            AU = FHMX / GA
            IF( AU.EQ.ZERO ) THEN
!
!              Avoid possible harmful underflow if exponent range
!              asymmetric (true SSMIN may not underflow even if
!              AU underflows)
!
               SSMIN = ( FHMN*FHMX ) / GA
               SSMAX = GA
            ELSE
               AS = ONE + FHMN / FHMX
               AT = ( FHMX-FHMN ) / FHMX
               C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ &
                   SQRT( ONE+( AT*AU )**2 ) )
               SSMIN = ( FHMN*C )*AU
               SSMIN = SSMIN + SSMIN
               SSMAX = GA / ( C+C )
            END IF
         END IF
      END IF
      RETURN
!
!     End of DLAS2
!
      END
      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      DOUBLE PRECISION   CFROM, CTO
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASCL multiplies the M by N real matrix A by the real scalar
!  CTO/CFROM.  This is done without over/underflow as long as the final
!  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!  A may be full, upper triangular, lower triangular, upper Hessenberg,
!  or banded.
!
!  Arguments
!  =========
!
!  TYPE    (input) CHARACTER*1
!          TYPE indices the storage type of the input matrix.
!          = 'G':  A is a full matrix.
!          = 'L':  A is a lower triangular matrix.
!          = 'U':  A is an upper triangular matrix.
!          = 'H':  A is an upper Hessenberg matrix.
!          = 'B':  A is a symmetric band matrix with lower bandwidth KL
!                  and upper bandwidth KU and with the only the lower
!                  half stored.
!          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
!                  and upper bandwidth KU and with the only the upper
!                  half stored.
!          = 'Z':  A is a band matrix with lower bandwidth KL and upper
!                  bandwidth KU.
!
!  KL      (input) INTEGER
!          The lower bandwidth of A.  Referenced only if TYPE = 'B',
!          'Q' or 'Z'.
!
!  KU      (input) INTEGER
!          The upper bandwidth of A.  Referenced only if TYPE = 'B',
!          'Q' or 'Z'.
!
!  CFROM   (input) DOUBLE PRECISION
!  CTO     (input) DOUBLE PRECISION
!          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
!          without over/underflow if the final result CTO*A(I,J)/CFROM
!          can be represented without over/underflow.  CFROM must be
!          nonzero.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
!          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
!          storage type.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  INFO    (output) INTEGER
!          0  - successful exit
!          <0 - if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
!
      IF( LSAME( TYPE, 'G' ) ) THEN
         ITYPE = 0
      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
         ITYPE = 2
      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
         ITYPE = 3
      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
         ITYPE = 4
      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
         ITYPE = 5
      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
         ITYPE = 6
      ELSE
         ITYPE = -1
      END IF
!
      IF( ITYPE.EQ.-1 ) THEN
         INFO = -1
      ELSE IF( CFROM.EQ.ZERO ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. &
               ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
         INFO = -7
      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
         INFO = -9
      ELSE IF( ITYPE.GE.4 ) THEN
         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
            INFO = -2
         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. &
                  ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) &
                   THEN
            INFO = -3
         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. &
                  ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. &
                  ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
            INFO = -9
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASCL', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. M.EQ.0 ) &
         RETURN
!
!     Get machine parameters
!
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
!
      CFROMC = CFROM
      CTOC = CTO
!
   10 CONTINUE
      CFROM1 = CFROMC*SMLNUM
      CTO1 = CTOC / BIGNUM
      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
         MUL = SMLNUM
         DONE = .FALSE.
         CFROMC = CFROM1
      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
         MUL = BIGNUM
         DONE = .FALSE.
         CTOC = CTO1
      ELSE
         MUL = CTOC / CFROMC
         DONE = .TRUE.
      END IF
!
      IF( ITYPE.EQ.0 ) THEN
!
!        Full matrix
!
         DO 30 J = 1, N
            DO 20 I = 1, M
               A( I, J ) = A( I, J )*MUL
   20       CONTINUE
   30    CONTINUE
!
      ELSE IF( ITYPE.EQ.1 ) THEN
!
!        Lower triangular matrix
!
         DO 50 J = 1, N
            DO 40 I = J, M
               A( I, J ) = A( I, J )*MUL
   40       CONTINUE
   50    CONTINUE
!
      ELSE IF( ITYPE.EQ.2 ) THEN
!
!        Upper triangular matrix
!
         DO 70 J = 1, N
            DO 60 I = 1, MIN( J, M )
               A( I, J ) = A( I, J )*MUL
   60       CONTINUE
   70    CONTINUE
!
      ELSE IF( ITYPE.EQ.3 ) THEN
!
!        Upper Hessenberg matrix
!
         DO 90 J = 1, N
            DO 80 I = 1, MIN( J+1, M )
               A( I, J ) = A( I, J )*MUL
   80       CONTINUE
   90    CONTINUE
!
      ELSE IF( ITYPE.EQ.4 ) THEN
!
!        Lower half of a symmetric band matrix
!
         K3 = KL + 1
         K4 = N + 1
         DO 110 J = 1, N
            DO 100 I = 1, MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  100       CONTINUE
  110    CONTINUE
!
      ELSE IF( ITYPE.EQ.5 ) THEN
!
!        Upper half of a symmetric band matrix
!
         K1 = KU + 2
         K3 = KU + 1
         DO 130 J = 1, N
            DO 120 I = MAX( K1-J, 1 ), K3
               A( I, J ) = A( I, J )*MUL
  120       CONTINUE
  130    CONTINUE
!
      ELSE IF( ITYPE.EQ.6 ) THEN
!
!        Band matrix
!
         K1 = KL + KU + 2
         K2 = KL + 1
         K3 = 2*KL + KU + 1
         K4 = KL + KU + 1 + M
         DO 150 J = 1, N
            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
               A( I, J ) = A( I, J )*MUL
  140       CONTINUE
  150    CONTINUE
!
      END IF
!
      IF( .NOT.DONE ) &
         GO TO 10
!
      RETURN
!
!     End of DLASCL
!
      END
      SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, &
                         WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, N, SMLSIZ, SQRE
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  Using a divide and conquer approach, DLASD0 computes the singular
!  value decomposition (SVD) of a real upper bidiagonal N-by-M
!  matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
!  The algorithm computes orthogonal matrices U and VT such that
!  B = U * S * VT. The singular values S are overwritten on D.
!
!  A related subroutine, DLASDA, computes only the singular values,
!  and optionally, the singular vectors in compact form.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         On entry, the row dimension of the upper bidiagonal matrix.
!         This is also the dimension of the main diagonal array D.
!
!  SQRE   (input) INTEGER
!         Specifies the column dimension of the bidiagonal matrix.
!         = 0: The bidiagonal matrix has column dimension M = N;
!         = 1: The bidiagonal matrix has column dimension M = N+1;
!
!  D      (input/output) DOUBLE PRECISION array, dimension (N)
!         On entry D contains the main diagonal of the bidiagonal
!         matrix.
!         On exit D, if INFO = 0, contains its singular values.
!
!  E      (input) DOUBLE PRECISION array, dimension (M-1)
!         Contains the subdiagonal entries of the bidiagonal matrix.
!         On exit, E has been destroyed.
!
!  U      (output) DOUBLE PRECISION array, dimension at least (LDQ, N)
!         On exit, U contains the left singular vectors.
!
!  LDU    (input) INTEGER
!         On entry, leading dimension of U.
!
!  VT     (output) DOUBLE PRECISION array, dimension at least (LDVT, M)
!         On exit, VT' contains the right singular vectors.
!
!  LDVT   (input) INTEGER
!         On entry, leading dimension of VT.
!
!  SMLSIZ (input) INTEGER
!         On entry, maximum size of the subproblems at the
!         bottom of the computation tree.
!
!  IWORK  INTEGER work array.
!         Dimension must be at least (8 * N)
!
!  WORK   DOUBLE PRECISION work array.
!         Dimension must be at least (3 * M**2 + 2 * M)
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK, &
                         J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR, &
                         NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASD1, DLASDQ, DLASDT, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -2
      END IF
!
      M = N + SQRE
!
      IF( LDU.LT.N ) THEN
         INFO = -6
      ELSE IF( LDVT.LT.M ) THEN
         INFO = -8
      ELSE IF( SMLSIZ.LT.3 ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD0', -INFO )
         RETURN
      END IF
!
!     If the input matrix is too small, call DLASDQ to find the SVD.
!
      IF( N.LE.SMLSIZ ) THEN
         CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U, &
                      LDU, WORK, INFO )
         RETURN
      END IF
!
!     Set up the computation tree.
!
      INODE = 1
      NDIML = INODE + N
      NDIMR = NDIML + N
      IDXQ = NDIMR + N
      IWK = IDXQ + N
      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), &
                   IWORK( NDIMR ), SMLSIZ )
!
!     For the nodes on bottom level of the tree, solve
!     their subproblems by DLASDQ.
!
      NDB1 = ( ND+1 ) / 2
      NCC = 0
      DO 30 I = NDB1, ND
!
!     IC : center row of each node
!     NL : number of rows of left  subproblem
!     NR : number of rows of right subproblem
!     NLF: starting row of the left   subproblem
!     NRF: starting row of the right  subproblem
!
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NLP1 = NL + 1
         NR = IWORK( NDIMR+I1 )
         NRP1 = NR + 1
         NLF = IC - NL
         NRF = IC + 1
         SQREI = 1
         CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ), &
                      VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU, &
                      U( NLF, NLF ), LDU, WORK, INFO )
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         ITEMP = IDXQ + NLF - 2
         DO 10 J = 1, NL
            IWORK( ITEMP+J ) = J
   10    CONTINUE
         IF( I.EQ.ND ) THEN
            SQREI = SQRE
         ELSE
            SQREI = 1
         END IF
         NRP1 = NR + SQREI
         CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ), &
                      VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU, &
                      U( NRF, NRF ), LDU, WORK, INFO )
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         ITEMP = IDXQ + IC
         DO 20 J = 1, NR
            IWORK( ITEMP+J-1 ) = J
   20    CONTINUE
   30 CONTINUE
!
!     Now conquer each subproblem bottom-up.
!
      DO 50 LVL = NLVL, 1, -1
!
!        Find the first node LF and last node LL on the
!        current level LVL.
!
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 40 I = LF, LL
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
               SQREI = SQRE
            ELSE
               SQREI = 1
            END IF
            IDXQC = IDXQ + NLF - 1
            ALPHA = D( IC )
            BETA = E( IC )
            CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA, &
                         U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT, &
                         IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
            IF( INFO.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
!
      RETURN
!
!     End of DLASD0
!
      END
      SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, &
                         IDXQ, IWORK, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. Array Arguments ..
      INTEGER            IDXQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
!  where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
!
!  A related subroutine DLASD7 handles the case in which the singular
!  values (and the singular vectors in factored form) are desired.
!
!  DLASD1 computes the SVD as follows:
!
!                ( D1(in)  0    0     0 )
!    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
!                (   0     0   D2(in) 0 )
!
!      = U(out) * ( D(out) 0) * VT(out)
!
!  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
!  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!  elsewhere; and the entry b is empty if SQRE = 0.
!
!  The left singular vectors of the original matrix are stored in U, and
!  the transpose of the right singular vectors are stored in VT, and the
!  singular values are in D.  The algorithm consists of three stages:
!
!     The first stage consists of deflating the size of the problem
!     when there are multiple singular values or when there are zeros in
!     the Z vector.  For each such occurence the dimension of the
!     secular equation problem is reduced by one.  This stage is
!     performed by the routine DLASD2.
!
!     The second stage consists of calculating the updated
!     singular values. This is done by finding the square roots of the
!     roots of the secular equation via the routine DLASD4 (as called
!     by DLASD3). This routine also calculates the singular vectors of
!     the current problem.
!
!     The final stage consists of computing the updated singular vectors
!     directly using the updated singular values.  The singular vectors
!     for the current problem are multiplied with the singular vectors
!     from the overall problem.
!
!  Arguments
!  =========
!
!  NL     (input) INTEGER
!         The row dimension of the upper block.  NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block.  NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has row dimension N = NL + NR + 1,
!         and column dimension M = N + SQRE.
!
!  D      (input/output) DOUBLE PRECISION array,
!                        dimension (N = NL+NR+1).
!         On entry D(1:NL,1:NL) contains the singular values of the
!         upper block; and D(NL+2:N) contains the singular values of
!         the lower block. On exit D(1:N) contains the singular values
!         of the modified matrix.
!
!  ALPHA  (input) DOUBLE PRECISION
!         Contains the diagonal element associated with the added row.
!
!  BETA   (input) DOUBLE PRECISION
!         Contains the off-diagonal element associated with the added
!         row.
!
!  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)
!         On entry U(1:NL, 1:NL) contains the left singular vectors of
!         the upper block; U(NL+2:N, NL+2:N) contains the left singular
!         vectors of the lower block. On exit U contains the left
!         singular vectors of the bidiagonal matrix.
!
!  LDU    (input) INTEGER
!         The leading dimension of the array U.  LDU >= max( 1, N ).
!
!  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
!         where M = N + SQRE.
!         On entry VT(1:NL+1, 1:NL+1)' contains the right singular
!         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
!         the right singular vectors of the lower block. On exit
!         VT' contains the right singular vectors of the
!         bidiagonal matrix.
!
!  LDVT   (input) INTEGER
!         The leading dimension of the array VT.  LDVT >= max( 1, M ).
!
!  IDXQ  (output) INTEGER array, dimension(N)
!         This contains the permutation which will reintegrate the
!         subproblem just solved back into sorted order, i.e.
!         D( IDXQ( I = 1, N ) ) will be in ascending order.
!
!  IWORK  (workspace) INTEGER array, dimension( 4 * N )
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
!
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2, &
                         IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
      DOUBLE PRECISION   ORGNRM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( NL.LT.1 ) THEN
         INFO = -1
      ELSE IF( NR.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD1', -INFO )
         RETURN
      END IF
!
      N = NL + NR + 1
      M = N + SQRE
!
!     The following values are for bookkeeping purposes only.  They are
!     integer pointers which indicate the portion of the workspace
!     used by a particular array in DLASD2 and DLASD3.
!
      LDU2 = N
      LDVT2 = M
!
      IZ = 1
      ISIGMA = IZ + M
      IU2 = ISIGMA + N
      IVT2 = IU2 + LDU2*N
      IQ = IVT2 + LDVT2*M
!
      IDX = 1
      IDXC = IDX + N
      COLTYP = IDXC + N
      IDXP = COLTYP + N
!
!     Scale.
!
      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
      D( NL+1 ) = ZERO
      DO 10 I = 1, N
         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
            ORGNRM = ABS( D( I ) )
         END IF
   10 CONTINUE
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
      ALPHA = ALPHA / ORGNRM
      BETA = BETA / ORGNRM
!
!     Deflate singular values.
!
      CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU, &
                   VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2, &
                   WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ), &
                   IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
!
!     Solve Secular Equation and update singular vectors.
!
      LDQ = K
      CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ), &
                   U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ), &
                   LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ), &
                   INFO )
      IF( INFO.NE.0 ) THEN
         RETURN
      END IF
!
!     Unscale.
!
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
!
!     Prepare the IDXQ sorting permutation.
!
      N1 = K
      N2 = N - K
      CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
!
      RETURN
!
!     End of DLASD1
!
      END
      SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, &
                         LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, &
                         IDXC, IDXQ, COLTYP, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. Array Arguments ..
      INTEGER            COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), &
                         IDXQ( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), U( LDU, * ), &
                         U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), &
                         Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD2 merges the two sets of singular values together into a single
!  sorted set.  Then it tries to deflate the size of the problem.
!  There are two ways in which deflation can occur:  when two or more
!  singular values are close together or if there is a tiny entry in the
!  Z vector.  For each such occurrence the order of the related secular
!  equation problem is reduced by one.
!
!  DLASD2 is called from DLASD1.
!
!  Arguments
!  =========
!
!  NL     (input) INTEGER
!         The row dimension of the upper block.  NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block.  NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has N = NL + NR + 1 rows and
!         M = N + SQRE >= N columns.
!
!  K      (output) INTEGER
!         Contains the dimension of the non-deflated matrix,
!         This is the order of the related secular equation. 1 <= K <=N.
!
!  D      (input/output) DOUBLE PRECISION array, dimension(N)
!         On entry D contains the singular values of the two submatrices
!         to be combined.  On exit D contains the trailing (N-K) updated
!         singular values (those which were deflated) sorted into
!         increasing order.
!
!  ALPHA  (input) DOUBLE PRECISION
!         Contains the diagonal element associated with the added row.
!
!  BETA   (input) DOUBLE PRECISION
!         Contains the off-diagonal element associated with the added
!         row.
!
!  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)
!         On entry U contains the left singular vectors of two
!         submatrices in the two square blocks with corners at (1,1),
!         (NL, NL), and (NL+2, NL+2), (N,N).
!         On exit U contains the trailing (N-K) updated left singular
!         vectors (those which were deflated) in its last N-K columns.
!
!  LDU    (input) INTEGER
!         The leading dimension of the array U.  LDU >= N.
!
!  Z      (output) DOUBLE PRECISION array, dimension(N)
!         On exit Z contains the updating row vector in the secular
!         equation.
!
!  DSIGMA (output) DOUBLE PRECISION array, dimension (N)
!         Contains a copy of the diagonal elements (K-1 singular values
!         and one zero) in the secular equation.
!
!  U2     (output) DOUBLE PRECISION array, dimension(LDU2,N)
!         Contains a copy of the first K-1 left singular vectors which
!         will be used by DLASD3 in a matrix multiply (DGEMM) to solve
!         for the new left singular vectors. U2 is arranged into four
!         blocks. The first block contains a column with 1 at NL+1 and
!         zero everywhere else; the second block contains non-zero
!         entries only at and above NL; the third contains non-zero
!         entries only below NL+1; and the fourth is dense.
!
!  LDU2   (input) INTEGER
!         The leading dimension of the array U2.  LDU2 >= N.
!
!  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
!         On entry VT' contains the right singular vectors of two
!         submatrices in the two square blocks with corners at (1,1),
!         (NL+1, NL+1), and (NL+2, NL+2), (M,M).
!         On exit VT' contains the trailing (N-K) updated right singular
!         vectors (those which were deflated) in its last N-K columns.
!         In case SQRE =1, the last row of VT spans the right null
!         space.
!
!  LDVT   (input) INTEGER
!         The leading dimension of the array VT.  LDVT >= M.
!
!  VT2    (output) DOUBLE PRECISION array, dimension(LDVT2,N)
!         VT2' contains a copy of the first K right singular vectors
!         which will be used by DLASD3 in a matrix multiply (DGEMM) to
!         solve for the new right singular vectors. VT2 is arranged into
!         three blocks. The first block contains a row that corresponds
!         to the special 0 diagonal element in SIGMA; the second block
!         contains non-zeros only at and before NL +1; the third block
!         contains non-zeros only at and after  NL +2.
!
!  LDVT2  (input) INTEGER
!         The leading dimension of the array VT2.  LDVT2 >= M.
!
!  IDXP   (workspace) INTEGER array, dimension(N)
!         This will contain the permutation used to place deflated
!         values of D at the end of the array. On output IDXP(2:K)
!         points to the nondeflated D-values and IDXP(K+1:N)
!         points to the deflated singular values.
!
!  IDX    (workspace) INTEGER array, dimension(N)
!         This will contain the permutation used to sort the contents of
!         D into ascending order.
!
!  IDXC   (output) INTEGER array, dimension(N)
!         This will contain the permutation used to arrange the columns
!         of the deflated U matrix into three groups:  the first group
!         contains non-zero entries only at and above NL, the second
!         contains non-zero entries only below NL+2, and the third is
!         dense.
!
!  COLTYP (workspace/output) INTEGER array, dimension(N)
!         As workspace, this will contain a label which will indicate
!         which of the following types a column in the U2 matrix or a
!         row in the VT2 matrix is:
!         1 : non-zero in the upper half only
!         2 : non-zero in the lower half only
!         3 : dense
!         4 : deflated
!
!         On exit, it is an array of dimension 4, with COLTYP(I) being
!         the dimension of the I-th type columns.
!
!  IDXQ   (input) INTEGER array, dimension(N)
!         This contains the permutation which separately sorts the two
!         sub-problems in D into ascending order.  Note that entries in
!         the first hlaf of this permutation must first be moved one
!         position backward; and entries in the second half
!         must first have NL+1 added to their values.
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, &
                         EIGHT = 8.0D+0 )
!     ..
!     .. Local Arrays ..
      INTEGER            CTOT( 4 ), PSM( 4 )
!     ..
!     .. Local Scalars ..
      INTEGER            CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, &
                         N, NLP1, NLP2
      DOUBLE PRECISION   C, EPS, HLFTOL, S, TAU, TOL, Z1
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( NL.LT.1 ) THEN
         INFO = -1
      ELSE IF( NR.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
         INFO = -3
      END IF
!
      N = NL + NR + 1
      M = N + SQRE
!
      IF( LDU.LT.N ) THEN
         INFO = -10
      ELSE IF( LDVT.LT.M ) THEN
         INFO = -12
      ELSE IF( LDU2.LT.N ) THEN
         INFO = -15
      ELSE IF( LDVT2.LT.M ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD2', -INFO )
         RETURN
      END IF
!
      NLP1 = NL + 1
      NLP2 = NL + 2
!
!     Generate the first part of the vector Z; and move the singular
!     values in the first part of D one position backward.
!
      Z1 = ALPHA*VT( NLP1, NLP1 )
      Z( 1 ) = Z1
      DO 10 I = NL, 1, -1
         Z( I+1 ) = ALPHA*VT( I, NLP1 )
         D( I+1 ) = D( I )
         IDXQ( I+1 ) = IDXQ( I ) + 1
   10 CONTINUE
!
!     Generate the second part of the vector Z.
!
      DO 20 I = NLP2, M
         Z( I ) = BETA*VT( I, NLP2 )
   20 CONTINUE
!
!     Initialize some reference arrays.
!
      DO 30 I = 2, NLP1
         COLTYP( I ) = 1
   30 CONTINUE
      DO 40 I = NLP2, N
         COLTYP( I ) = 2
   40 CONTINUE
!
!     Sort the singular values into increasing order
!
      DO 50 I = NLP2, N
         IDXQ( I ) = IDXQ( I ) + NLP1
   50 CONTINUE
!
!     DSIGMA, IDXC, IDXC, and the first column of U2
!     are used as storage space.
!
      DO 60 I = 2, N
         DSIGMA( I ) = D( IDXQ( I ) )
         U2( I, 1 ) = Z( IDXQ( I ) )
         IDXC( I ) = COLTYP( IDXQ( I ) )
   60 CONTINUE
!
      CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
!
      DO 70 I = 2, N
         IDXI = 1 + IDX( I )
         D( I ) = DSIGMA( IDXI )
         Z( I ) = U2( IDXI, 1 )
         COLTYP( I ) = IDXC( IDXI )
   70 CONTINUE
!
!     Calculate the allowable deflation tolerance
!
      EPS = DLAMCH( 'Epsilon' )
      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
      TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
!
!     There are 2 kinds of deflation -- first a value in the z-vector
!     is small, second two (or more) singular values are very close
!     together (their difference is small).
!
!     If the value in the z-vector is small, we simply permute the
!     array so that the corresponding singular value is moved to the
!     end.
!
!     If two values in the D-vector are close, we perform a two-sided
!     rotation designed to make one of the corresponding z-vector
!     entries zero, and then permute the array so that the deflated
!     singular value is moved to the end.
!
!     If there are multiple singular values then the problem deflates.
!     Here the number of equal singular values are found.  As each equal
!     singular value is found, an elementary reflector is computed to
!     rotate the corresponding singular subspace so that the
!     corresponding components of Z are zero in this new basis.
!
      K = 1
      K2 = N + 1
      DO 80 J = 2, N
         IF( ABS( Z( J ) ).LE.TOL ) THEN
!
!           Deflate due to small z component.
!
            K2 = K2 - 1
            IDXP( K2 ) = J
            COLTYP( J ) = 4
            IF( J.EQ.N ) &
               GO TO 120
         ELSE
            JPREV = J
            GO TO 90
         END IF
   80 CONTINUE
   90 CONTINUE
      J = JPREV
  100 CONTINUE
      J = J + 1
      IF( J.GT.N ) &
         GO TO 110
      IF( ABS( Z( J ) ).LE.TOL ) THEN
!
!        Deflate due to small z component.
!
         K2 = K2 - 1
         IDXP( K2 ) = J
         COLTYP( J ) = 4
      ELSE
!
!        Check if singular values are close enough to allow deflation.
!
         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
!
!           Deflation is possible.
!
            S = Z( JPREV )
            C = Z( J )
!
!           Find sqrt(a**2+b**2) without overflow or
!           destructive underflow.
!
            TAU = DLAPY2( C, S )
            C = C / TAU
            S = -S / TAU
            Z( J ) = TAU
            Z( JPREV ) = ZERO
!
!           Apply back the Givens rotation to the left and right
!           singular vector matrices.
!
            IDXJP = IDXQ( IDX( JPREV )+1 )
            IDXJ = IDXQ( IDX( J )+1 )
            IF( IDXJP.LE.NLP1 ) THEN
               IDXJP = IDXJP - 1
            END IF
            IF( IDXJ.LE.NLP1 ) THEN
               IDXJ = IDXJ - 1
            END IF
            CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
            CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, &
                       S )
            IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
               COLTYP( J ) = 3
            END IF
            COLTYP( JPREV ) = 4
            K2 = K2 - 1
            IDXP( K2 ) = JPREV
            JPREV = J
         ELSE
            K = K + 1
            U2( K, 1 ) = Z( JPREV )
            DSIGMA( K ) = D( JPREV )
            IDXP( K ) = JPREV
            JPREV = J
         END IF
      END IF
      GO TO 100
  110 CONTINUE
!
!     Record the last singular value.
!
      K = K + 1
      U2( K, 1 ) = Z( JPREV )
      DSIGMA( K ) = D( JPREV )
      IDXP( K ) = JPREV
!
  120 CONTINUE
!
!     Count up the total number of the various types of columns, then
!     form a permutation which positions the four column types into
!     four groups of uniform structure (although one or more of these
!     groups may be empty).
!
      DO 130 J = 1, 4
         CTOT( J ) = 0
  130 CONTINUE
      DO 140 J = 2, N
         CT = COLTYP( J )
         CTOT( CT ) = CTOT( CT ) + 1
  140 CONTINUE
!
!     PSM(*) = Position in SubMatrix (of types 1 through 4)
!
      PSM( 1 ) = 2
      PSM( 2 ) = 2 + CTOT( 1 )
      PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
      PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
!
!     Fill out the IDXC array so that the permutation which it induces
!     will place all type-1 columns first, all type-2 columns next,
!     then all type-3's, and finally all type-4's, starting from the
!     second column. This applies similarly to the rows of VT.
!
      DO 150 J = 2, N
         JP = IDXP( J )
         CT = COLTYP( JP )
         IDXC( PSM( CT ) ) = J
         PSM( CT ) = PSM( CT ) + 1
  150 CONTINUE
!
!     Sort the singular values and corresponding singular vectors into
!     DSIGMA, U2, and VT2 respectively.  The singular values/vectors
!     which were not deflated go into the first K slots of DSIGMA, U2,
!     and VT2 respectively, while those which were deflated go into the
!     last N - K slots, except that the first column/row will be treated
!     separately.
!
      DO 160 J = 2, N
         JP = IDXP( J )
         DSIGMA( J ) = D( JP )
         IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
         IF( IDXJ.LE.NLP1 ) THEN
            IDXJ = IDXJ - 1
         END IF
         CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
         CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
  160 CONTINUE
!
!     Determine DSIGMA(1), DSIGMA(2) and Z(1)
!
      DSIGMA( 1 ) = ZERO
      HLFTOL = TOL / TWO
      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) &
         DSIGMA( 2 ) = HLFTOL
      IF( M.GT.N ) THEN
         Z( 1 ) = DLAPY2( Z1, Z( M ) )
         IF( Z( 1 ).LE.TOL ) THEN
            C = ONE
            S = ZERO
            Z( 1 ) = TOL
         ELSE
            C = Z1 / Z( 1 )
            S = Z( M ) / Z( 1 )
         END IF
      ELSE
         IF( ABS( Z1 ).LE.TOL ) THEN
            Z( 1 ) = TOL
         ELSE
            Z( 1 ) = Z1
         END IF
      END IF
!
!     Move the rest of the updating row to Z.
!
      CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
!
!     Determine the first column of U2, the first row of VT2 and the
!     last row of VT.
!
      CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
      U2( NLP1, 1 ) = ONE
      IF( M.GT.N ) THEN
         DO 170 I = 1, NLP1
            VT( M, I ) = -S*VT( NLP1, I )
            VT2( 1, I ) = C*VT( NLP1, I )
  170    CONTINUE
         DO 180 I = NLP2, M
            VT2( 1, I ) = S*VT( M, I )
            VT( M, I ) = C*VT( M, I )
  180    CONTINUE
      ELSE
         CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
      END IF
      IF( M.GT.N ) THEN
         CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
      END IF
!
!     The deflated singular values and their corresponding vectors go
!     into the back of D, U, and V respectively.
!
      IF( N.GT.K ) THEN
         CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
         CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), &
                      LDU )
         CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), &
                      LDVT )
      END IF
!
!     Copy CTOT into COLTYP for referencing in DLASD3.
!
      DO 190 J = 1, 4
         COLTYP( J ) = CTOT( J )
  190 CONTINUE
!
      RETURN
!
!     End of DLASD2
!
      END
      SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, &
                         LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, &
                         INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, &
                         SQRE
!     ..
!     .. Array Arguments ..
      INTEGER            CTOT( * ), IDXC( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), &
                         U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), &
                         Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD3 finds all the square roots of the roots of the secular
!  equation, as defined by the values in D and Z.  It makes the
!  appropriate calls to DLASD4 and then updates the singular
!  vectors by matrix multiplication.
!
!  This code makes very mild assumptions about floating point
!  arithmetic. It will work on machines with a guard digit in
!  add/subtract, or on those binary machines without guard digits
!  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
!  It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  DLASD3 is called from DLASD1.
!
!  Arguments
!  =========
!
!  NL     (input) INTEGER
!         The row dimension of the upper block.  NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block.  NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has N = NL + NR + 1 rows and
!         M = N + SQRE >= N columns.
!
!  K      (input) INTEGER
!         The size of the secular equation, 1 =< K = < N.
!
!  D      (output) DOUBLE PRECISION array, dimension(K)
!         On exit the square roots of the roots of the secular equation,
!         in ascending order.
!
!  Q      (workspace) DOUBLE PRECISION array,
!                     dimension at least (LDQ,K).
!
!  LDQ    (input) INTEGER
!         The leading dimension of the array Q.  LDQ >= K.
!
!  DSIGMA (input) DOUBLE PRECISION array, dimension(K)
!         The first K elements of this array contain the old roots
!         of the deflated updating problem.  These are the poles
!         of the secular equation.
!
!  U      (input) DOUBLE PRECISION array, dimension (LDU, N)
!         The last N - K columns of this matrix contain the deflated
!         left singular vectors.
!
!  LDU    (input) INTEGER
!         The leading dimension of the array U.  LDU >= N.
!
!  U2     (input) DOUBLE PRECISION array, dimension (LDU2, N)
!         The first K columns of this matrix contain the non-deflated
!         left singular vectors for the split problem.
!
!  LDU2   (input) INTEGER
!         The leading dimension of the array U2.  LDU2 >= N.
!
!  VT     (input) DOUBLE PRECISION array, dimension (LDVT, M)
!         The last M - K columns of VT' contain the deflated
!         right singular vectors.
!
!  LDVT   (input) INTEGER
!         The leading dimension of the array VT.  LDVT >= N.
!
!  VT2    (input) DOUBLE PRECISION array, dimension (LDVT2, N)
!         The first K columns of VT2' contain the non-deflated
!         right singular vectors for the split problem.
!
!  LDVT2  (input) INTEGER
!         The leading dimension of the array VT2.  LDVT2 >= N.
!
!  IDXC   (input) INTEGER array, dimension ( N )
!         The permutation used to arrange the columns of U (and rows of
!         VT) into three groups:  the first group contains non-zero
!         entries only at and above (or before) NL +1; the second
!         contains non-zero entries only at and below (or after) NL+2;
!         and the third is dense. The first column of U and the row of
!         VT are treated separately, however.
!
!         The rows of the singular vectors found by DLASD4
!         must be likewise permuted before the matrix multiplies can
!         take place.
!
!  CTOT   (input) INTEGER array, dimension ( 4 )
!         A count of the total number of the various types of columns
!         in U (or rows in VT), as described in IDXC. The fourth column
!         type is any column which has been deflated.
!
!  Z      (input) DOUBLE PRECISION array, dimension (K)
!         The first K elements of this array contain the components
!         of the deflation-adjusted updating row vector.
!
!  INFO   (output) INTEGER
!         = 0:  successful exit.
!         < 0:  if INFO = -i, the i-th argument had an illegal value.
!         > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, NEGONE
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0, &
                         NEGONE = -1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
      DOUBLE PRECISION   RHO, TEMP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMC3, DNRM2
      EXTERNAL           DLAMC3, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( NL.LT.1 ) THEN
         INFO = -1
      ELSE IF( NR.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
         INFO = -3
      END IF
!
      N = NL + NR + 1
      M = N + SQRE
      NLP1 = NL + 1
      NLP2 = NL + 2
!
      IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
         INFO = -4
      ELSE IF( LDQ.LT.K ) THEN
         INFO = -7
      ELSE IF( LDU.LT.N ) THEN
         INFO = -10
      ELSE IF( LDU2.LT.N ) THEN
         INFO = -12
      ELSE IF( LDVT.LT.M ) THEN
         INFO = -14
      ELSE IF( LDVT2.LT.M ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD3', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.1 ) THEN
         D( 1 ) = ABS( Z( 1 ) )
         CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
         IF( Z( 1 ).GT.ZERO ) THEN
            CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
         ELSE
            DO 10 I = 1, N
               U( I, 1 ) = -U2( I, 1 )
   10       CONTINUE
         END IF
         RETURN
      END IF
!
!     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
!     be computed with high relative accuracy (barring over/underflow).
!     This is a problem on machines without a guard digit in
!     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
!     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
!     which on any of these machines zeros out the bottommost
!     bit of DSIGMA(I) if it is 1; this makes the subsequent
!     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
!     occurs. On binary machines with a guard digit (almost all
!     machines) it does not change DSIGMA(I) at all. On hexadecimal
!     and decimal machines with a guard digit, it slightly
!     changes the bottommost bits of DSIGMA(I). It does not account
!     for hexadecimal or decimal machines without guard digits
!     (we know of none). We use a subroutine call to compute
!     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
!     this code.
!
      DO 20 I = 1, K
         DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
   20 CONTINUE
!
!     Keep a copy of Z.
!
      CALL DCOPY( K, Z, 1, Q, 1 )
!
!     Normalize Z.
!
      RHO = DNRM2( K, Z, 1 )
      CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
      RHO = RHO*RHO
!
!     Find the new singular values.
!
      DO 30 J = 1, K
         CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ), &
                      VT( 1, J ), INFO )
!
!        If the zero finder fails, the computation is terminated.
!
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
   30 CONTINUE
!
!     Compute updated Z.
!
      DO 60 I = 1, K
         Z( I ) = U( I, K )*VT( I, K )
         DO 40 J = 1, I - 1
            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / &
                     ( DSIGMA( I )-DSIGMA( J ) ) / &
                     ( DSIGMA( I )+DSIGMA( J ) ) )
   40    CONTINUE
         DO 50 J = I, K - 1
            Z( I ) = Z( I )*( U( I, J )*VT( I, J ) / &
                     ( DSIGMA( I )-DSIGMA( J+1 ) ) / &
                     ( DSIGMA( I )+DSIGMA( J+1 ) ) )
   50    CONTINUE
         Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
   60 CONTINUE
!
!     Compute left singular vectors of the modified diagonal matrix,
!     and store related information for the right singular vectors.
!
      DO 90 I = 1, K
         VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
         U( 1, I ) = NEGONE
         DO 70 J = 2, K
            VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
            U( J, I ) = DSIGMA( J )*VT( J, I )
   70    CONTINUE
         TEMP = DNRM2( K, U( 1, I ), 1 )
         Q( 1, I ) = U( 1, I ) / TEMP
         DO 80 J = 2, K
            JC = IDXC( J )
            Q( J, I ) = U( JC, I ) / TEMP
   80    CONTINUE
   90 CONTINUE
!
!     Update the left singular vector matrix.
!
      IF( K.EQ.2 ) THEN
         CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U, &
                     LDU )
         GO TO 100
      END IF
      IF( CTOT( 1 ).GT.0 ) THEN
         CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2, &
                     Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
         IF( CTOT( 3 ).GT.0 ) THEN
            KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
            CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), &
                        LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
         END IF
      ELSE IF( CTOT( 3 ).GT.0 ) THEN
         KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
         CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ), &
                     LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
      ELSE
         CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU )
      END IF
      CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
      KTEMP = 2 + CTOT( 1 )
      CTEMP = CTOT( 2 ) + CTOT( 3 )
      CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2, &
                  Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
!
!     Generate the right singular vectors.
!
  100 CONTINUE
      DO 120 I = 1, K
         TEMP = DNRM2( K, VT( 1, I ), 1 )
         Q( I, 1 ) = VT( 1, I ) / TEMP
         DO 110 J = 2, K
            JC = IDXC( J )
            Q( I, J ) = VT( JC, I ) / TEMP
  110    CONTINUE
  120 CONTINUE
!
!     Update the right singular vector matrix.
!
      IF( K.EQ.2 ) THEN
         CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO, &
                     VT, LDVT )
         RETURN
      END IF
      KTEMP = 1 + CTOT( 1 )
      CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ, &
                  VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
      KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
      IF( KTEMP.LE.LDVT2 ) &
         CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ), &
                     LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ), &
                     LDVT )
!
      KTEMP = CTOT( 1 ) + 1
      NRP1 = NR + SQRE
      IF( KTEMP.GT.1 ) THEN
         DO 130 I = 1, K
            Q( I, KTEMP ) = Q( I, 1 )
  130    CONTINUE
         DO 140 I = NLP2, M
            VT2( KTEMP, I ) = VT2( 1, I )
  140    CONTINUE
      END IF
      CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
      CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ, &
                  VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
!
      RETURN
!
!     End of DLASD3
!
      END
      SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            I, INFO, N
      DOUBLE PRECISION   RHO, SIGMA
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DELTA( * ), WORK( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  This subroutine computes the square root of the I-th updated
!  eigenvalue of a positive symmetric rank-one modification to
!  a positive diagonal matrix whose entries are given as the squares
!  of the corresponding entries in the array d, and that
!
!         0 <= D(i) < D(j)  for  i < j
!
!  and that RHO > 0. This is arranged by the calling routine, and is
!  no loss in generality.  The rank-one modified system is thus
!
!         diag( D ) * diag( D ) +  RHO *  Z * Z_transpose.
!
!  where we assume the Euclidean norm of Z is 1.
!
!  The method consists of approximating the rational functions in the
!  secular equation by simpler interpolating rational functions.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The length of all arrays.
!
!  I      (input) INTEGER
!         The index of the eigenvalue to be computed.  1 <= I <= N.
!
!  D      (input) DOUBLE PRECISION array, dimension ( N )
!         The original eigenvalues.  It is assumed that they are in
!         order, 0 <= D(I) < D(J)  for I < J.
!
!  Z      (input) DOUBLE PRECISION array, dimension ( N )
!         The components of the updating vector.
!
!  DELTA  (output) DOUBLE PRECISION array, dimension ( N )
!         If N .ne. 1, DELTA contains (D(j) - sigma_I) in its  j-th
!         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA
!         contains the information necessary to construct the
!         (singular) eigenvectors.
!
!  RHO    (input) DOUBLE PRECISION
!         The scalar in the symmetric updating formula.
!
!  SIGMA  (output) DOUBLE PRECISION
!         The computed lambda_I, the I-th updated eigenvalue.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension ( N )
!         If N .ne. 1, WORK contains (D(j) + sigma_I) in its  j-th
!         component.  If N = 1, then WORK( 1 ) = 1.
!
!  INFO   (output) INTEGER
!         = 0:  successful exit
!         > 0:  if INFO = 1, the updating process failed.
!
!  Internal Parameters
!  ===================
!
!  Logical variable ORGATI (origin-at-i?) is used for distinguishing
!  whether D(i) or D(i+1) is treated as the origin.
!
!            ORGATI = .true.    origin at i
!            ORGATI = .false.   origin at i+1
!
!  Logical variable SWTCH3 (switch-for-3-poles?) is for noting
!  if we are working with THREE poles!
!
!  MAXIT is the maximum number of iterations allowed for each
!  eigenvalue.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ren-Cang Li, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 20 )
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, &
                         THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0, &
                         TEN = 10.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ORGATI, SWTCH, SWTCH3
      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
      DOUBLE PRECISION   A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM, &
                         DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS, &
                         ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB, &
                         SG2UB, TAU, TEMP, TEMP1, TEMP2, W
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DD( 3 ), ZZ( 3 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAED6, DLASD5
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Since this routine is called in an inner loop, we do no argument
!     checking.
!
!     Quick return for N=1 and 2.
!
      INFO = 0
      IF( N.EQ.1 ) THEN
!
!        Presumably, I=1 upon entry
!
         SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
         DELTA( 1 ) = ONE
         WORK( 1 ) = ONE
         RETURN
      END IF
      IF( N.EQ.2 ) THEN
         CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
         RETURN
      END IF
!
!     Compute machine epsilon
!
      EPS = DLAMCH( 'Epsilon' )
      RHOINV = ONE / RHO
!
!     The case I = N
!
      IF( I.EQ.N ) THEN
!
!        Initialize some basic variables
!
         II = N - 1
         NITER = 1
!
!        Calculate initial guess
!
         TEMP = RHO / TWO
!
!        If ||Z||_2 is not one, then TEMP should be set to
!        RHO * ||Z||_2^2 / TWO
!
         TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
         DO 10 J = 1, N
            WORK( J ) = D( J ) + D( N ) + TEMP1
            DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
   10    CONTINUE
!
         PSI = ZERO
         DO 20 J = 1, N - 2
            PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
   20    CONTINUE
!
         C = RHOINV + PSI
         W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) + &
             Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
!
         IF( W.LE.ZERO ) THEN
            TEMP1 = SQRT( D( N )*D( N )+RHO )
            TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )* &
                   ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) + &
                   Z( N )*Z( N ) / RHO
!
!           The following TAU is to approximate
!           SIGMA_n^2 - D( N )*D( N )
!
            IF( C.LE.TEMP ) THEN
               TAU = RHO
            ELSE
               DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
               A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
               B = Z( N )*Z( N )*DELSQ
               IF( A.LT.ZERO ) THEN
                  TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
               ELSE
                  TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
               END IF
            END IF
!
!           It can be proved that
!               D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
!
         ELSE
            DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
            A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
            B = Z( N )*Z( N )*DELSQ
!
!           The following TAU is to approximate
!           SIGMA_n^2 - D( N )*D( N )
!
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
            ELSE
               TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
            END IF
!
!           It can be proved that
!           D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
!
         END IF
!
!        The following ETA is to approximate SIGMA_n - D( N )
!
         ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
!
         SIGMA = D( N ) + ETA
         DO 30 J = 1, N
            DELTA( J ) = ( D( J )-D( I ) ) - ETA
            WORK( J ) = D( J ) + D( I ) + ETA
   30    CONTINUE
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 40 J = 1, II
            TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   40    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                  ABS( TAU )*( DPSI+DPHI )
!
         W = RHOINV + PHI + PSI
!
!        Test for convergence
!
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            GO TO 240
         END IF
!
!        Calculate the new step
!
         NITER = NITER + 1
         DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
         DTNSQ = WORK( N )*DELTA( N )
         C = W - DTNSQ1*DPSI - DTNSQ*DPHI
         A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
         B = DTNSQ*DTNSQ1*W
         IF( C.LT.ZERO ) &
            C = ABS( C )
         IF( C.EQ.ZERO ) THEN
            ETA = RHO - SIGMA*SIGMA
         ELSE IF( A.GE.ZERO ) THEN
            ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
         ELSE
            ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
         END IF
!
!        Note, eta should be positive if w is negative, and
!        eta should be negative otherwise. However,
!        if for some reason caused by roundoff, eta*w > 0,
!        we simply use one Newton step instead. This way
!        will guarantee eta*w < 0.
!
         IF( W*ETA.GT.ZERO ) &
            ETA = -W / ( DPSI+DPHI )
         TEMP = ETA - DTNSQ
         IF( TEMP.GT.RHO ) &
            ETA = RHO + DTNSQ
!
         TAU = TAU + ETA
         ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
         DO 50 J = 1, N
            DELTA( J ) = DELTA( J ) - ETA
            WORK( J ) = WORK( J ) + ETA
   50    CONTINUE
!
         SIGMA = SIGMA + ETA
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 60 J = 1, II
            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
   60    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
         PHI = Z( N )*TEMP
         DPHI = TEMP*TEMP
         ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                  ABS( TAU )*( DPSI+DPHI )
!
         W = RHOINV + PHI + PSI
!
!        Main loop to update the values of the array   DELTA
!
         ITER = NITER + 1
!
         DO 90 NITER = ITER, MAXIT
!
!           Test for convergence
!
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               GO TO 240
            END IF
!
!           Calculate the new step
!
            DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
            DTNSQ = WORK( N )*DELTA( N )
            C = W - DTNSQ1*DPSI - DTNSQ*DPHI
            A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
            B = DTNSQ1*DTNSQ*W
            IF( A.GE.ZERO ) THEN
               ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
!
!           Note, eta should be positive if w is negative, and
!           eta should be negative otherwise. However,
!           if for some reason caused by roundoff, eta*w > 0,
!           we simply use one Newton step instead. This way
!           will guarantee eta*w < 0.
!
            IF( W*ETA.GT.ZERO ) &
               ETA = -W / ( DPSI+DPHI )
            TEMP = ETA - DTNSQ
            IF( TEMP.LE.ZERO ) &
               ETA = ETA / TWO
!
            TAU = TAU + ETA
            ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
            DO 70 J = 1, N
               DELTA( J ) = DELTA( J ) - ETA
               WORK( J ) = WORK( J ) + ETA
   70       CONTINUE
!
            SIGMA = SIGMA + ETA
!
!           Evaluate PSI and the derivative DPSI
!
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 80 J = 1, II
               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
   80       CONTINUE
            ERRETM = ABS( ERRETM )
!
!           Evaluate PHI and the derivative DPHI
!
            TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
            PHI = Z( N )*TEMP
            DPHI = TEMP*TEMP
            ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + &
                     ABS( TAU )*( DPSI+DPHI )
!
            W = RHOINV + PHI + PSI
   90    CONTINUE
!
!        Return with INFO = 1, NITER = MAXIT and not converged
!
         INFO = 1
         GO TO 240
!
!        End for the case I = N
!
      ELSE
!
!        The case for I < N
!
         NITER = 1
         IP1 = I + 1
!
!        Calculate initial guess
!
         DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
         DELSQ2 = DELSQ / TWO
         TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
         DO 100 J = 1, N
            WORK( J ) = D( J ) + D( I ) + TEMP
            DELTA( J ) = ( D( J )-D( I ) ) - TEMP
  100    CONTINUE
!
         PSI = ZERO
         DO 110 J = 1, I - 1
            PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
  110    CONTINUE
!
         PHI = ZERO
         DO 120 J = N, I + 2, -1
            PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
  120    CONTINUE
         C = RHOINV + PSI + PHI
         W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) + &
             Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
!
         IF( W.GT.ZERO ) THEN
!
!           d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
!
!           We choose d(i) as origin.
!
            ORGATI = .TRUE.
            SG2LB = ZERO
            SG2UB = DELSQ2
            A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
            B = Z( I )*Z( I )*DELSQ
            IF( A.GT.ZERO ) THEN
               TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            ELSE
               TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            END IF
!
!           TAU now is an estimation of SIGMA^2 - D( I )^2. The
!           following, however, is the corresponding estimation of
!           SIGMA - D( I ).
!
            ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
         ELSE
!
!           (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
!
!           We choose d(i+1) as origin.
!
            ORGATI = .FALSE.
            SG2LB = -DELSQ2
            SG2UB = ZERO
            A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
            B = Z( IP1 )*Z( IP1 )*DELSQ
            IF( A.LT.ZERO ) THEN
               TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
            ELSE
               TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
            END IF
!
!           TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
!           following, however, is the corresponding estimation of
!           SIGMA - D( IP1 ).
!
            ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+ &
                  TAU ) ) )
         END IF
!
         IF( ORGATI ) THEN
            II = I
            SIGMA = D( I ) + ETA
            DO 130 J = 1, N
               WORK( J ) = D( J ) + D( I ) + ETA
               DELTA( J ) = ( D( J )-D( I ) ) - ETA
  130       CONTINUE
         ELSE
            II = I + 1
            SIGMA = D( IP1 ) + ETA
            DO 140 J = 1, N
               WORK( J ) = D( J ) + D( IP1 ) + ETA
               DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
  140       CONTINUE
         END IF
         IIM1 = II - 1
         IIP1 = II + 1
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 150 J = 1, IIM1
            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  150    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         DPHI = ZERO
         PHI = ZERO
         DO 160 J = N, IIP1, -1
            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  160    CONTINUE
!
         W = RHOINV + PHI + PSI
!
!        W is the value of the secular function with
!        its ii-th element removed.
!
         SWTCH3 = .FALSE.
         IF( ORGATI ) THEN
            IF( W.LT.ZERO ) &
               SWTCH3 = .TRUE.
         ELSE
            IF( W.GT.ZERO ) &
               SWTCH3 = .TRUE.
         END IF
         IF( II.EQ.1 .OR. II.EQ.N ) &
            SWTCH3 = .FALSE.
!
         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = W + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                  THREE*ABS( TEMP ) + ABS( TAU )*DW
!
!        Test for convergence
!
         IF( ABS( W ).LE.EPS*ERRETM ) THEN
            GO TO 240
         END IF
!
         IF( W.LE.ZERO ) THEN
            SG2LB = MAX( SG2LB, TAU )
         ELSE
            SG2UB = MIN( SG2UB, TAU )
         END IF
!
!        Calculate the new step
!
         NITER = NITER + 1
         IF( .NOT.SWTCH3 ) THEN
            DTIPSQ = WORK( IP1 )*DELTA( IP1 )
            DTISQ = WORK( I )*DELTA( I )
            IF( ORGATI ) THEN
               C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
            ELSE
               C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
            END IF
            A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
            B = DTIPSQ*DTISQ*W
            IF( C.EQ.ZERO ) THEN
               IF( A.EQ.ZERO ) THEN
                  IF( ORGATI ) THEN
                     A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
                  ELSE
                     A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
                  END IF
               END IF
               ETA = B / A
            ELSE IF( A.LE.ZERO ) THEN
               ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
            ELSE
               ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
            END IF
         ELSE
!
!           Interpolation using THREE most relevant poles
!
            DTIIM = WORK( IIM1 )*DELTA( IIM1 )
            DTIIP = WORK( IIP1 )*DELTA( IIP1 )
            TEMP = RHOINV + PSI + PHI
            IF( ORGATI ) THEN
               TEMP1 = Z( IIM1 ) / DTIIM
               TEMP1 = TEMP1*TEMP1
               C = ( TEMP - DTIIP*( DPSI+DPHI ) ) - &
                   ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
               ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
               IF( DPSI.LT.TEMP1 ) THEN
                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
               ELSE
                  ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
               END IF
            ELSE
               TEMP1 = Z( IIP1 ) / DTIIP
               TEMP1 = TEMP1*TEMP1
               C = ( TEMP - DTIIM*( DPSI+DPHI ) ) - &
                   ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
               IF( DPHI.LT.TEMP1 ) THEN
                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
               ELSE
                  ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
               END IF
               ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
            END IF
            ZZ( 2 ) = Z( II )*Z( II )
            DD( 1 ) = DTIIM
            DD( 2 ) = DELTA( II )*WORK( II )
            DD( 3 ) = DTIIP
            CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
            IF( INFO.NE.0 ) &
               GO TO 240
         END IF
!
!        Note, eta should be positive if w is negative, and
!        eta should be negative otherwise. However,
!        if for some reason caused by roundoff, eta*w > 0,
!        we simply use one Newton step instead. This way
!        will guarantee eta*w < 0.
!
         IF( W*ETA.GE.ZERO ) &
            ETA = -W / DW
         IF( ORGATI ) THEN
            TEMP1 = WORK( I )*DELTA( I )
            TEMP = ETA - TEMP1
         ELSE
            TEMP1 = WORK( IP1 )*DELTA( IP1 )
            TEMP = ETA - TEMP1
         END IF
         IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
            IF( W.LT.ZERO ) THEN
               ETA = ( SG2UB-TAU ) / TWO
            ELSE
               ETA = ( SG2LB-TAU ) / TWO
            END IF
         END IF
!
         TAU = TAU + ETA
         ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
!
         PREW = W
!
         SIGMA = SIGMA + ETA
         DO 170 J = 1, N
            WORK( J ) = WORK( J ) + ETA
            DELTA( J ) = DELTA( J ) - ETA
  170    CONTINUE
!
!        Evaluate PSI and the derivative DPSI
!
         DPSI = ZERO
         PSI = ZERO
         ERRETM = ZERO
         DO 180 J = 1, IIM1
            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
            PSI = PSI + Z( J )*TEMP
            DPSI = DPSI + TEMP*TEMP
            ERRETM = ERRETM + PSI
  180    CONTINUE
         ERRETM = ABS( ERRETM )
!
!        Evaluate PHI and the derivative DPHI
!
         DPHI = ZERO
         PHI = ZERO
         DO 190 J = N, IIP1, -1
            TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
            PHI = PHI + Z( J )*TEMP
            DPHI = DPHI + TEMP*TEMP
            ERRETM = ERRETM + PHI
  190    CONTINUE
!
         TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
         DW = DPSI + DPHI + TEMP*TEMP
         TEMP = Z( II )*TEMP
         W = RHOINV + PHI + PSI + TEMP
         ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                  THREE*ABS( TEMP ) + ABS( TAU )*DW
!
         IF( W.LE.ZERO ) THEN
            SG2LB = MAX( SG2LB, TAU )
         ELSE
            SG2UB = MIN( SG2UB, TAU )
         END IF
!
         SWTCH = .FALSE.
         IF( ORGATI ) THEN
            IF( -W.GT.ABS( PREW ) / TEN ) &
               SWTCH = .TRUE.
         ELSE
            IF( W.GT.ABS( PREW ) / TEN ) &
               SWTCH = .TRUE.
         END IF
!
!        Main loop to update the values of the array   DELTA and WORK
!
         ITER = NITER + 1
!
         DO 230 NITER = ITER, MAXIT
!
!           Test for convergence
!
            IF( ABS( W ).LE.EPS*ERRETM ) THEN
               GO TO 240
            END IF
!
!           Calculate the new step
!
            IF( .NOT.SWTCH3 ) THEN
               DTIPSQ = WORK( IP1 )*DELTA( IP1 )
               DTISQ = WORK( I )*DELTA( I )
               IF( .NOT.SWTCH ) THEN
                  IF( ORGATI ) THEN
                     C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
                  ELSE
                     C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
                  END IF
               ELSE
                  TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
                  IF( ORGATI ) THEN
                     DPSI = DPSI + TEMP*TEMP
                  ELSE
                     DPHI = DPHI + TEMP*TEMP
                  END IF
                  C = W - DTISQ*DPSI - DTIPSQ*DPHI
               END IF
               A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
               B = DTIPSQ*DTISQ*W
               IF( C.EQ.ZERO ) THEN
                  IF( A.EQ.ZERO ) THEN
                     IF( .NOT.SWTCH ) THEN
                        IF( ORGATI ) THEN
                           A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ* &
                               ( DPSI+DPHI )
                        ELSE
                           A = Z( IP1 )*Z( IP1 ) + &
                               DTISQ*DTISQ*( DPSI+DPHI )
                        END IF
                     ELSE
                        A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
                     END IF
                  END IF
                  ETA = B / A
               ELSE IF( A.LE.ZERO ) THEN
                  ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
               ELSE
                  ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
               END IF
            ELSE
!
!              Interpolation using THREE most relevant poles
!
               DTIIM = WORK( IIM1 )*DELTA( IIM1 )
               DTIIP = WORK( IIP1 )*DELTA( IIP1 )
               TEMP = RHOINV + PSI + PHI
               IF( SWTCH ) THEN
                  C = TEMP - DTIIM*DPSI - DTIIP*DPHI
                  ZZ( 1 ) = DTIIM*DTIIM*DPSI
                  ZZ( 3 ) = DTIIP*DTIIP*DPHI
               ELSE
                  IF( ORGATI ) THEN
                     TEMP1 = Z( IIM1 ) / DTIIM
                     TEMP1 = TEMP1*TEMP1
                     TEMP2 = ( D( IIM1 )-D( IIP1 ) )* &
                             ( D( IIM1 )+D( IIP1 ) )*TEMP1
                     C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
                     ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
                     IF( DPSI.LT.TEMP1 ) THEN
                        ZZ( 3 ) = DTIIP*DTIIP*DPHI
                     ELSE
                        ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
                     END IF
                  ELSE
                     TEMP1 = Z( IIP1 ) / DTIIP
                     TEMP1 = TEMP1*TEMP1
                     TEMP2 = ( D( IIP1 )-D( IIM1 ) )* &
                             ( D( IIM1 )+D( IIP1 ) )*TEMP1
                     C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
                     IF( DPHI.LT.TEMP1 ) THEN
                        ZZ( 1 ) = DTIIM*DTIIM*DPSI
                     ELSE
                        ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
                     END IF
                     ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
                  END IF
               END IF
               DD( 1 ) = DTIIM
               DD( 2 ) = DELTA( II )*WORK( II )
               DD( 3 ) = DTIIP
               CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
               IF( INFO.NE.0 ) &
                  GO TO 240
            END IF
!
!           Note, eta should be positive if w is negative, and
!           eta should be negative otherwise. However,
!           if for some reason caused by roundoff, eta*w > 0,
!           we simply use one Newton step instead. This way
!           will guarantee eta*w < 0.
!
            IF( W*ETA.GE.ZERO ) &
               ETA = -W / DW
            IF( ORGATI ) THEN
               TEMP1 = WORK( I )*DELTA( I )
               TEMP = ETA - TEMP1
            ELSE
               TEMP1 = WORK( IP1 )*DELTA( IP1 )
               TEMP = ETA - TEMP1
            END IF
            IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
               IF( W.LT.ZERO ) THEN
                  ETA = ( SG2UB-TAU ) / TWO
               ELSE
                  ETA = ( SG2LB-TAU ) / TWO
               END IF
            END IF
!
            TAU = TAU + ETA
            ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
!
            SIGMA = SIGMA + ETA
            DO 200 J = 1, N
               WORK( J ) = WORK( J ) + ETA
               DELTA( J ) = DELTA( J ) - ETA
  200       CONTINUE
!
            PREW = W
!
!           Evaluate PSI and the derivative DPSI
!
            DPSI = ZERO
            PSI = ZERO
            ERRETM = ZERO
            DO 210 J = 1, IIM1
               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
               PSI = PSI + Z( J )*TEMP
               DPSI = DPSI + TEMP*TEMP
               ERRETM = ERRETM + PSI
  210       CONTINUE
            ERRETM = ABS( ERRETM )
!
!           Evaluate PHI and the derivative DPHI
!
            DPHI = ZERO
            PHI = ZERO
            DO 220 J = N, IIP1, -1
               TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
               PHI = PHI + Z( J )*TEMP
               DPHI = DPHI + TEMP*TEMP
               ERRETM = ERRETM + PHI
  220       CONTINUE
!
            TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
            DW = DPSI + DPHI + TEMP*TEMP
            TEMP = Z( II )*TEMP
            W = RHOINV + PHI + PSI + TEMP
            ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + &
                     THREE*ABS( TEMP ) + ABS( TAU )*DW
            IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) &
               SWTCH = .NOT.SWTCH
!
            IF( W.LE.ZERO ) THEN
               SG2LB = MAX( SG2LB, TAU )
            ELSE
               SG2UB = MIN( SG2UB, TAU )
            END IF
!
  230    CONTINUE
!
!        Return with INFO = 1, NITER = MAXIT and not converged
!
         INFO = 1
!
      END IF
!
  240 CONTINUE
      RETURN
!
!     End of DLASD4
!
      END
      SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            I
      DOUBLE PRECISION   DSIGMA, RHO
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
!     ..
!
!  Purpose
!  =======
!
!  This subroutine computes the square root of the I-th eigenvalue
!  of a positive symmetric rank-one modification of a 2-by-2 diagonal
!  matrix
!
!             diag( D ) * diag( D ) +  RHO *  Z * transpose(Z) .
!
!  The diagonal entries in the array D are assumed to satisfy
!
!             0 <= D(i) < D(j)  for  i < j .
!
!  We also assume RHO > 0 and that the Euclidean norm of the vector
!  Z is one.
!
!  Arguments
!  =========
!
!  I      (input) INTEGER
!         The index of the eigenvalue to be computed.  I = 1 or I = 2.
!
!  D      (input) DOUBLE PRECISION array, dimension ( 2 )
!         The original eigenvalues.  We assume 0 <= D(1) < D(2).
!
!  Z      (input) DOUBLE PRECISION array, dimension ( 2 )
!         The components of the updating vector.
!
!  DELTA  (output) DOUBLE PRECISION array, dimension ( 2 )
!         Contains (D(j) - lambda_I) in its  j-th component.
!         The vector DELTA contains the information necessary
!         to construct the eigenvectors.
!
!  RHO    (input) DOUBLE PRECISION
!         The scalar in the symmetric updating formula.
!
!  DSIGMA (output) DOUBLE PRECISION
!         The computed lambda_I, the I-th updated eigenvalue.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension ( 2 )
!         WORK contains (D(j) + sigma_I) in its  j-th component.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ren-Cang Li, Computer Science Division, University of California
!     at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, &
                         THREE = 3.0D+0, FOUR = 4.0D+0 )
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION   B, C, DEL, DELSQ, TAU, W
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
      DEL = D( 2 ) - D( 1 )
      DELSQ = DEL*( D( 2 )+D( 1 ) )
      IF( I.EQ.1 ) THEN
         W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )- &
             Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
         IF( W.GT.ZERO ) THEN
            B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
            C = RHO*Z( 1 )*Z( 1 )*DELSQ
!
!           B > ZERO, always
!
!           The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
!
            TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
!
!           The following TAU is DSIGMA - D( 1 )
!
            TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
            DSIGMA = D( 1 ) + TAU
            DELTA( 1 ) = -TAU
            DELTA( 2 ) = DEL - TAU
            WORK( 1 ) = TWO*D( 1 ) + TAU
            WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
!           DELTA( 1 ) = -Z( 1 ) / TAU
!           DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
         ELSE
            B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
            C = RHO*Z( 2 )*Z( 2 )*DELSQ
!
!           The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
!
            IF( B.GT.ZERO ) THEN
               TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
            ELSE
               TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
            END IF
!
!           The following TAU is DSIGMA - D( 2 )
!
            TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
            DSIGMA = D( 2 ) + TAU
            DELTA( 1 ) = -( DEL+TAU )
            DELTA( 2 ) = -TAU
            WORK( 1 ) = D( 1 ) + TAU + D( 2 )
            WORK( 2 ) = TWO*D( 2 ) + TAU
!           DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
!           DELTA( 2 ) = -Z( 2 ) / TAU
         END IF
!        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
!        DELTA( 1 ) = DELTA( 1 ) / TEMP
!        DELTA( 2 ) = DELTA( 2 ) / TEMP
      ELSE
!
!        Now I=2
!
         B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
         C = RHO*Z( 2 )*Z( 2 )*DELSQ
!
!        The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
!
         IF( B.GT.ZERO ) THEN
            TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
         ELSE
            TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
         END IF
!
!        The following TAU is DSIGMA - D( 2 )
!
         TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
         DSIGMA = D( 2 ) + TAU
         DELTA( 1 ) = -( DEL+TAU )
         DELTA( 2 ) = -TAU
         WORK( 1 ) = D( 1 ) + TAU + D( 2 )
         WORK( 2 ) = TWO*D( 2 ) + TAU
!        DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
!        DELTA( 2 ) = -Z( 2 ) / TAU
!        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
!        DELTA( 1 ) = DELTA( 1 ) / TEMP
!        DELTA( 2 ) = DELTA( 2 ) / TEMP
      END IF
      RETURN
!
!     End of DLASD5
!
      END
      SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, &
                         IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, &
                         LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, &
                         NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA, C, S
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), &
                         PERM( * )
      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( * ), &
                         GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), &
                         VF( * ), VL( * ), WORK( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD6 computes the SVD of an updated upper bidiagonal matrix B
!  obtained by merging two smaller ones by appending a row. This
!  routine is used only for the problem which requires all singular
!  values and optionally singular vector matrices in factored form.
!  B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
!  A related subroutine, DLASD1, handles the case in which all singular
!  values and singular vectors of the bidiagonal matrix are desired.
!
!  DLASD6 computes the SVD as follows:
!
!                ( D1(in)  0    0     0 )
!    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)
!                (   0     0   D2(in) 0 )
!
!      = U(out) * ( D(out) 0) * VT(out)
!
!  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
!  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!  elsewhere; and the entry b is empty if SQRE = 0.
!
!  The singular values of B can be computed using D1, D2, the first
!  components of all the right singular vectors of the lower block, and
!  the last components of all the right singular vectors of the upper
!  block. These components are stored and updated in VF and VL,
!  respectively, in DLASD6. Hence U and VT are not explicitly
!  referenced.
!
!  The singular values are stored in D. The algorithm consists of two
!  stages:
!
!        The first stage consists of deflating the size of the problem
!        when there are multiple singular values or if there is a zero
!        in the Z vector. For each such occurence the dimension of the
!        secular equation problem is reduced by one. This stage is
!        performed by the routine DLASD7.
!
!        The second stage consists of calculating the updated
!        singular values. This is done by finding the roots of the
!        secular equation via the routine DLASD4 (as called by DLASD8).
!        This routine also updates VF and VL and computes the distances
!        between the updated singular values and the old singular
!        values.
!
!  DLASD6 is called from DLASDA.
!
!  Arguments
!  =========
!
!  ICOMPQ (input) INTEGER
!         Specifies whether singular vectors are to be computed in
!         factored form:
!         = 0: Compute singular values only.
!         = 1: Compute singular vectors in factored form as well.
!
!  NL     (input) INTEGER
!         The row dimension of the upper block.  NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block.  NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has row dimension N = NL + NR + 1,
!         and column dimension M = N + SQRE.
!
!  D      (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).
!         On entry D(1:NL,1:NL) contains the singular values of the
!         upper block, and D(NL+2:N) contains the singular values
!         of the lower block. On exit D(1:N) contains the singular
!         values of the modified matrix.
!
!  VF     (input/output) DOUBLE PRECISION array, dimension ( M )
!         On entry, VF(1:NL+1) contains the first components of all
!         right singular vectors of the upper block; and VF(NL+2:M)
!         contains the first components of all right singular vectors
!         of the lower block. On exit, VF contains the first components
!         of all right singular vectors of the bidiagonal matrix.
!
!  VL     (input/output) DOUBLE PRECISION array, dimension ( M )
!         On entry, VL(1:NL+1) contains the  last components of all
!         right singular vectors of the upper block; and VL(NL+2:M)
!         contains the last components of all right singular vectors of
!         the lower block. On exit, VL contains the last components of
!         all right singular vectors of the bidiagonal matrix.
!
!  ALPHA  (input) DOUBLE PRECISION
!         Contains the diagonal element associated with the added row.
!
!  BETA   (input) DOUBLE PRECISION
!         Contains the off-diagonal element associated with the added
!         row.
!
!  IDXQ   (output) INTEGER array, dimension ( N )
!         This contains the permutation which will reintegrate the
!         subproblem just solved back into sorted order, i.e.
!         D( IDXQ( I = 1, N ) ) will be in ascending order.
!
!  PERM   (output) INTEGER array, dimension ( N )
!         The permutations (from deflation and sorting) to be applied
!         to each block. Not referenced if ICOMPQ = 0.
!
!  GIVPTR (output) INTEGER
!         The number of Givens rotations which took place in this
!         subproblem. Not referenced if ICOMPQ = 0.
!
!  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
!         Each pair of numbers indicates a pair of columns to take place
!         in a Givens rotation. Not referenced if ICOMPQ = 0.
!
!  LDGCOL (input) INTEGER
!         leading dimension of GIVCOL, must be at least N.
!
!  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!         Each number indicates the C or S value to be used in the
!         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
!
!  LDGNUM (input) INTEGER
!         The leading dimension of GIVNUM and POLES, must be at least N.
!
!  POLES  (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!         On exit, POLES(1,*) is an array containing the new singular
!         values obtained from solving the secular equation, and
!         POLES(2,*) is an array containing the poles in the secular
!         equation. Not referenced if ICOMPQ = 0.
!
!  DIFL   (output) DOUBLE PRECISION array, dimension ( N )
!         On exit, DIFL(I) is the distance between I-th updated
!         (undeflated) singular value and the I-th (undeflated) old
!         singular value.
!
!  DIFR   (output) DOUBLE PRECISION array,
!                  dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
!                  dimension ( N ) if ICOMPQ = 0.
!         On exit, DIFR(I, 1) is the distance between I-th updated
!         (undeflated) singular value and the I+1-th (undeflated) old
!         singular value.
!
!         If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
!         normalizing factors for the right singular vector matrix.
!
!         See DLASD8 for details on DIFL and DIFR.
!
!  Z      (output) DOUBLE PRECISION array, dimension ( M )
!         The first elements of this array contain the components
!         of the deflation-adjusted updating row vector.
!
!  K      (output) INTEGER
!         Contains the dimension of the non-deflated matrix,
!         This is the order of the related secular equation. 1 <= K <=N.
!
!  C      (output) DOUBLE PRECISION
!         C contains garbage if SQRE =0 and the C-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  S      (output) DOUBLE PRECISION
!         S contains garbage if SQRE =0 and the S-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension ( 4 * M )
!
!  IWORK  (workspace) INTEGER array, dimension ( 3 * N )
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M, &
                         N, N1, N2
      DOUBLE PRECISION   ORGNRM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      N = NL + NR + 1
      M = N + SQRE
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( NL.LT.1 ) THEN
         INFO = -2
      ELSE IF( NR.LT.1 ) THEN
         INFO = -3
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -4
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -14
      ELSE IF( LDGNUM.LT.N ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD6', -INFO )
         RETURN
      END IF
!
!     The following values are for bookkeeping purposes only.  They are
!     integer pointers which indicate the portion of the workspace
!     used by a particular array in DLASD7 and DLASD8.
!
      ISIGMA = 1
      IW = ISIGMA + N
      IVFW = IW + M
      IVLW = IVFW + M
!
      IDX = 1
      IDXC = IDX + N
      IDXP = IDXC + N
!
!     Scale.
!
      ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
      D( NL+1 ) = ZERO
      DO 10 I = 1, N
         IF( ABS( D( I ) ).GT.ORGNRM ) THEN
            ORGNRM = ABS( D( I ) )
         END IF
   10 CONTINUE
      CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
      ALPHA = ALPHA / ORGNRM
      BETA = BETA / ORGNRM
!
!     Sort and Deflate singular values.
!
      CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF, &
                   WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA, &
                   WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ, &
                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, &
                   INFO )
!
!     Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
!
      CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM, &
                   WORK( ISIGMA ), WORK( IW ), INFO )
!
!     Save the poles if ICOMPQ = 1.
!
      IF( ICOMPQ.EQ.1 ) THEN
         CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 )
         CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
      END IF
!
!     Unscale.
!
      CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
!
!     Prepare the IDXQ sorting permutation.
!
      N1 = K
      N2 = N - K
      CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
!
      RETURN
!
!     End of DLASD6
!
      END
      SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, &
                         VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, &
                         PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, &
                         C, S, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, &
                         NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA, C, S
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), &
                         IDXQ( * ), PERM( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), &
                         VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), &
                         ZW( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD7 merges the two sets of singular values together into a single
!  sorted set. Then it tries to deflate the size of the problem. There
!  are two ways in which deflation can occur:  when two or more singular
!  values are close together or if there is a tiny entry in the Z
!  vector. For each such occurrence the order of the related
!  secular equation problem is reduced by one.
!
!  DLASD7 is called from DLASD6.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          Specifies whether singular vectors are to be computed
!          in compact form, as follows:
!          = 0: Compute singular values only.
!          = 1: Compute singular vectors of upper
!               bidiagonal matrix in compact form.
!
!  NL     (input) INTEGER
!         The row dimension of the upper block. NL >= 1.
!
!  NR     (input) INTEGER
!         The row dimension of the lower block. NR >= 1.
!
!  SQRE   (input) INTEGER
!         = 0: the lower block is an NR-by-NR square matrix.
!         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
!
!         The bidiagonal matrix has
!         N = NL + NR + 1 rows and
!         M = N + SQRE >= N columns.
!
!  K      (output) INTEGER
!         Contains the dimension of the non-deflated matrix, this is
!         the order of the related secular equation. 1 <= K <=N.
!
!  D      (input/output) DOUBLE PRECISION array, dimension ( N )
!         On entry D contains the singular values of the two submatrices
!         to be combined. On exit D contains the trailing (N-K) updated
!         singular values (those which were deflated) sorted into
!         increasing order.
!
!  Z      (output) DOUBLE PRECISION array, dimension ( M )
!         On exit Z contains the updating row vector in the secular
!         equation.
!
!  ZW     (workspace) DOUBLE PRECISION array, dimension ( M )
!         Workspace for Z.
!
!  VF     (input/output) DOUBLE PRECISION array, dimension ( M )
!         On entry, VF(1:NL+1) contains the first components of all
!         right singular vectors of the upper block; and VF(NL+2:M)
!         contains the first components of all right singular vectors
!         of the lower block. On exit, VF contains the first components
!         of all right singular vectors of the bidiagonal matrix.
!
!  VFW    (workspace) DOUBLE PRECISION array, dimension ( M )
!         Workspace for VF.
!
!  VL     (input/output) DOUBLE PRECISION array, dimension ( M )
!         On entry, VL(1:NL+1) contains the  last components of all
!         right singular vectors of the upper block; and VL(NL+2:M)
!         contains the last components of all right singular vectors
!         of the lower block. On exit, VL contains the last components
!         of all right singular vectors of the bidiagonal matrix.
!
!  VLW    (workspace) DOUBLE PRECISION array, dimension ( M )
!         Workspace for VL.
!
!  ALPHA  (input) DOUBLE PRECISION
!         Contains the diagonal element associated with the added row.
!
!  BETA   (input) DOUBLE PRECISION
!         Contains the off-diagonal element associated with the added
!         row.
!
!  DSIGMA (output) DOUBLE PRECISION array, dimension ( N )
!         Contains a copy of the diagonal elements (K-1 singular values
!         and one zero) in the secular equation.
!
!  IDX    (workspace) INTEGER array, dimension ( N )
!         This will contain the permutation used to sort the contents of
!         D into ascending order.
!
!  IDXP   (workspace) INTEGER array, dimension ( N )
!         This will contain the permutation used to place deflated
!         values of D at the end of the array. On output IDXP(2:K)
!         points to the nondeflated D-values and IDXP(K+1:N)
!         points to the deflated singular values.
!
!  IDXQ   (input) INTEGER array, dimension ( N )
!         This contains the permutation which separately sorts the two
!         sub-problems in D into ascending order.  Note that entries in
!         the first half of this permutation must first be moved one
!         position backward; and entries in the second half
!         must first have NL+1 added to their values.
!
!  PERM   (output) INTEGER array, dimension ( N )
!         The permutations (from deflation and sorting) to be applied
!         to each singular block. Not referenced if ICOMPQ = 0.
!
!  GIVPTR (output) INTEGER
!         The number of Givens rotations which took place in this
!         subproblem. Not referenced if ICOMPQ = 0.
!
!  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
!         Each pair of numbers indicates a pair of columns to take place
!         in a Givens rotation. Not referenced if ICOMPQ = 0.
!
!  LDGCOL (input) INTEGER
!         The leading dimension of GIVCOL, must be at least N.
!
!  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
!         Each number indicates the C or S value to be used in the
!         corresponding Givens rotation. Not referenced if ICOMPQ = 0.
!
!  LDGNUM (input) INTEGER
!         The leading dimension of GIVNUM, must be at least N.
!
!  C      (output) DOUBLE PRECISION
!         C contains garbage if SQRE =0 and the C-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  S      (output) DOUBLE PRECISION
!         S contains garbage if SQRE =0 and the S-value of a Givens
!         rotation related to the right null space if SQRE = 1.
!
!  INFO   (output) INTEGER
!         = 0:  successful exit.
!         < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, &
                         EIGHT = 8.0D+0 )
!     ..
!     .. Local Scalars ..
!
      INTEGER            I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, &
                         NLP1, NLP2
      DOUBLE PRECISION   EPS, HLFTOL, TAU, TOL, Z1
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAMRG, DROT, XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      N = NL + NR + 1
      M = N + SQRE
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( NL.LT.1 ) THEN
         INFO = -2
      ELSE IF( NR.LT.1 ) THEN
         INFO = -3
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -4
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -22
      ELSE IF( LDGNUM.LT.N ) THEN
         INFO = -24
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD7', -INFO )
         RETURN
      END IF
!
      NLP1 = NL + 1
      NLP2 = NL + 2
      IF( ICOMPQ.EQ.1 ) THEN
         GIVPTR = 0
      END IF
!
!     Generate the first part of the vector Z and move the singular
!     values in the first part of D one position backward.
!
      Z1 = ALPHA*VL( NLP1 )
      VL( NLP1 ) = ZERO
      TAU = VF( NLP1 )
      DO 10 I = NL, 1, -1
         Z( I+1 ) = ALPHA*VL( I )
         VL( I ) = ZERO
         VF( I+1 ) = VF( I )
         D( I+1 ) = D( I )
         IDXQ( I+1 ) = IDXQ( I ) + 1
   10 CONTINUE
      VF( 1 ) = TAU
!
!     Generate the second part of the vector Z.
!
      DO 20 I = NLP2, M
         Z( I ) = BETA*VF( I )
         VF( I ) = ZERO
   20 CONTINUE
!
!     Sort the singular values into increasing order
!
      DO 30 I = NLP2, N
         IDXQ( I ) = IDXQ( I ) + NLP1
   30 CONTINUE
!
!     DSIGMA, IDXC, IDXC, and ZW are used as storage space.
!
      DO 40 I = 2, N
         DSIGMA( I ) = D( IDXQ( I ) )
         ZW( I ) = Z( IDXQ( I ) )
         VFW( I ) = VF( IDXQ( I ) )
         VLW( I ) = VL( IDXQ( I ) )
   40 CONTINUE
!
      CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
!
      DO 50 I = 2, N
         IDXI = 1 + IDX( I )
         D( I ) = DSIGMA( IDXI )
         Z( I ) = ZW( IDXI )
         VF( I ) = VFW( IDXI )
         VL( I ) = VLW( IDXI )
   50 CONTINUE
!
!     Calculate the allowable deflation tolerence
!
      EPS = DLAMCH( 'Epsilon' )
      TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
      TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
!
!     There are 2 kinds of deflation -- first a value in the z-vector
!     is small, second two (or more) singular values are very close
!     together (their difference is small).
!
!     If the value in the z-vector is small, we simply permute the
!     array so that the corresponding singular value is moved to the
!     end.
!
!     If two values in the D-vector are close, we perform a two-sided
!     rotation designed to make one of the corresponding z-vector
!     entries zero, and then permute the array so that the deflated
!     singular value is moved to the end.
!
!     If there are multiple singular values then the problem deflates.
!     Here the number of equal singular values are found.  As each equal
!     singular value is found, an elementary reflector is computed to
!     rotate the corresponding singular subspace so that the
!     corresponding components of Z are zero in this new basis.
!
      K = 1
      K2 = N + 1
      DO 60 J = 2, N
         IF( ABS( Z( J ) ).LE.TOL ) THEN
!
!           Deflate due to small z component.
!
            K2 = K2 - 1
            IDXP( K2 ) = J
            IF( J.EQ.N ) &
               GO TO 100
         ELSE
            JPREV = J
            GO TO 70
         END IF
   60 CONTINUE
   70 CONTINUE
      J = JPREV
   80 CONTINUE
      J = J + 1
      IF( J.GT.N ) &
         GO TO 90
      IF( ABS( Z( J ) ).LE.TOL ) THEN
!
!        Deflate due to small z component.
!
         K2 = K2 - 1
         IDXP( K2 ) = J
      ELSE
!
!        Check if singular values are close enough to allow deflation.
!
         IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
!
!           Deflation is possible.
!
            S = Z( JPREV )
            C = Z( J )
!
!           Find sqrt(a**2+b**2) without overflow or
!           destructive underflow.
!
            TAU = DLAPY2( C, S )
            Z( J ) = TAU
            Z( JPREV ) = ZERO
            C = C / TAU
            S = -S / TAU
!
!           Record the appropriate Givens rotation
!
            IF( ICOMPQ.EQ.1 ) THEN
               GIVPTR = GIVPTR + 1
               IDXJP = IDXQ( IDX( JPREV )+1 )
               IDXJ = IDXQ( IDX( J )+1 )
               IF( IDXJP.LE.NLP1 ) THEN
                  IDXJP = IDXJP - 1
               END IF
               IF( IDXJ.LE.NLP1 ) THEN
                  IDXJ = IDXJ - 1
               END IF
               GIVCOL( GIVPTR, 2 ) = IDXJP
               GIVCOL( GIVPTR, 1 ) = IDXJ
               GIVNUM( GIVPTR, 2 ) = C
               GIVNUM( GIVPTR, 1 ) = S
            END IF
            CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
            CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
            K2 = K2 - 1
            IDXP( K2 ) = JPREV
            JPREV = J
         ELSE
            K = K + 1
            ZW( K ) = Z( JPREV )
            DSIGMA( K ) = D( JPREV )
            IDXP( K ) = JPREV
            JPREV = J
         END IF
      END IF
      GO TO 80
   90 CONTINUE
!
!     Record the last singular value.
!
      K = K + 1
      ZW( K ) = Z( JPREV )
      DSIGMA( K ) = D( JPREV )
      IDXP( K ) = JPREV
!
  100 CONTINUE
!
!     Sort the singular values into DSIGMA. The singular values which
!     were not deflated go into the first K slots of DSIGMA, except
!     that DSIGMA(1) is treated separately.
!
      DO 110 J = 2, N
         JP = IDXP( J )
         DSIGMA( J ) = D( JP )
         VFW( J ) = VF( JP )
         VLW( J ) = VL( JP )
  110 CONTINUE
      IF( ICOMPQ.EQ.1 ) THEN
         DO 120 J = 2, N
            JP = IDXP( J )
            PERM( J ) = IDXQ( IDX( JP )+1 )
            IF( PERM( J ).LE.NLP1 ) THEN
               PERM( J ) = PERM( J ) - 1
            END IF
  120    CONTINUE
      END IF
!
!     The deflated singular values go back into the last N - K slots of
!     D.
!
      CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
!
!     Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
!     VL(M).
!
      DSIGMA( 1 ) = ZERO
      HLFTOL = TOL / TWO
      IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) &
         DSIGMA( 2 ) = HLFTOL
      IF( M.GT.N ) THEN
         Z( 1 ) = DLAPY2( Z1, Z( M ) )
         IF( Z( 1 ).LE.TOL ) THEN
            C = ONE
            S = ZERO
            Z( 1 ) = TOL
         ELSE
            C = Z1 / Z( 1 )
            S = -Z( M ) / Z( 1 )
         END IF
         CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
         CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
      ELSE
         IF( ABS( Z1 ).LE.TOL ) THEN
            Z( 1 ) = TOL
         ELSE
            Z( 1 ) = Z1
         END IF
      END IF
!
!     Restore Z, VF, and VL.
!
      CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
      CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
      CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
!
      RETURN
!
!     End of DLASD7
!
      END
      SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, &
                         DSIGMA, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, K, LDDIFR
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( LDDIFR, * ), &
                         DSIGMA( * ), VF( * ), VL( * ), WORK( * ), &
                         Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD8 finds the square roots of the roots of the secular equation,
!  as defined by the values in DSIGMA and Z. It makes the appropriate
!  calls to DLASD4, and stores, for each  element in D, the distance
!  to its two nearest poles (elements in DSIGMA). It also updates
!  the arrays VF and VL, the first and last components of all the
!  right singular vectors of the original bidiagonal matrix.
!
!  DLASD8 is called from DLASD6.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          Specifies whether singular vectors are to be computed in
!          factored form in the calling routine:
!          = 0: Compute singular values only.
!          = 1: Compute singular vectors in factored form as well.
!
!  K       (input) INTEGER
!          The number of terms in the rational function to be solved
!          by DLASD4.  K >= 1.
!
!  D       (output) DOUBLE PRECISION array, dimension ( K )
!          On output, D contains the updated singular values.
!
!  Z       (input) DOUBLE PRECISION array, dimension ( K )
!          The first K elements of this array contain the components
!          of the deflation-adjusted updating row vector.
!
!  VF      (input/output) DOUBLE PRECISION array, dimension ( K )
!          On entry, VF contains  information passed through DBEDE8.
!          On exit, VF contains the first K components of the first
!          components of all right singular vectors of the bidiagonal
!          matrix.
!
!  VL      (input/output) DOUBLE PRECISION array, dimension ( K )
!          On entry, VL contains  information passed through DBEDE8.
!          On exit, VL contains the first K components of the last
!          components of all right singular vectors of the bidiagonal
!          matrix.
!
!  DIFL    (output) DOUBLE PRECISION array, dimension ( K )
!          On exit, DIFL(I) = D(I) - DSIGMA(I).
!
!  DIFR    (output) DOUBLE PRECISION array,
!                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
!                   dimension ( K ) if ICOMPQ = 0.
!          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
!          defined and will not be referenced.
!
!          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
!          normalizing factors for the right singular vector matrix.
!
!  LDDIFR  (input) INTEGER
!          The leading dimension of DIFR, must be at least K.
!
!  DSIGMA  (input) DOUBLE PRECISION array, dimension ( K )
!          The first K elements of this array contain the old roots
!          of the deflated updating problem.  These are the poles
!          of the secular equation.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension at least 3 * K
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLASCL, DLASD4, DLASET, XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMC3, DNRM2
      EXTERNAL           DDOT, DLAMC3, DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( K.LT.1 ) THEN
         INFO = -2
      ELSE IF( LDDIFR.LT.K ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD8', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.1 ) THEN
         D( 1 ) = ABS( Z( 1 ) )
         DIFL( 1 ) = D( 1 )
         IF( ICOMPQ.EQ.1 ) THEN
            DIFL( 2 ) = ONE
            DIFR( 1, 2 ) = ONE
         END IF
         RETURN
      END IF
!
!     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
!     be computed with high relative accuracy (barring over/underflow).
!     This is a problem on machines without a guard digit in
!     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
!     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
!     which on any of these machines zeros out the bottommost
!     bit of DSIGMA(I) if it is 1; this makes the subsequent
!     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
!     occurs. On binary machines with a guard digit (almost all
!     machines) it does not change DSIGMA(I) at all. On hexadecimal
!     and decimal machines with a guard digit, it slightly
!     changes the bottommost bits of DSIGMA(I). It does not account
!     for hexadecimal or decimal machines without guard digits
!     (we know of none). We use a subroutine call to compute
!     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
!     this code.
!
      DO 10 I = 1, K
         DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
   10 CONTINUE
!
!     Book keeping.
!
      IWK1 = 1
      IWK2 = IWK1 + K
      IWK3 = IWK2 + K
      IWK2I = IWK2 - 1
      IWK3I = IWK3 - 1
!
!     Normalize Z.
!
      RHO = DNRM2( K, Z, 1 )
      CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
      RHO = RHO*RHO
!
!     Initialize WORK(IWK3).
!
      CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
!
!     Compute the updated singular values, the arrays DIFL, DIFR,
!     and the updated Z.
!
      DO 40 J = 1, K
         CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), &
                      WORK( IWK2 ), INFO )
!
!        If the root finder fails, the computation is terminated.
!
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
         DIFL( J ) = -WORK( J )
         DIFR( J, 1 ) = -WORK( J+1 )
         DO 20 I = 1, J - 1
            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* &
                              WORK( IWK2I+I ) / ( DSIGMA( I )- &
                              DSIGMA( J ) ) / ( DSIGMA( I )+ &
                              DSIGMA( J ) )
   20    CONTINUE
         DO 30 I = J + 1, K
            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* &
                              WORK( IWK2I+I ) / ( DSIGMA( I )- &
                              DSIGMA( J ) ) / ( DSIGMA( I )+ &
                              DSIGMA( J ) )
   30    CONTINUE
   40 CONTINUE
!
!     Compute updated Z.
!
      DO 50 I = 1, K
         Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
   50 CONTINUE
!
!     Update VF and VL.
!
      DO 80 J = 1, K
         DIFLJ = DIFL( J )
         DJ = D( J )
         DSIGJ = -DSIGMA( J )
         IF( J.LT.K ) THEN
            DIFRJ = -DIFR( J, 1 )
            DSIGJP = -DSIGMA( J+1 )
         END IF
         WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
         DO 60 I = 1, J - 1
            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) &
                         / ( DSIGMA( I )+DJ )
   60    CONTINUE
         DO 70 I = J + 1, K
            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) &
                         / ( DSIGMA( I )+DJ )
   70    CONTINUE
         TEMP = DNRM2( K, WORK, 1 )
         WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
         WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
         IF( ICOMPQ.EQ.1 ) THEN
            DIFR( J, 2 ) = TEMP
         END IF
   80 CONTINUE
!
      CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
      CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
!
      RETURN
!
!     End of DLASD8
!
      END
      SUBROUTINE DLASD9( ICOMPQ, LDU, K, D, Z, VF, VL, DIFL, DIFR, &
                         DSIGMA, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
!     Courant Institute, NAG Ltd., and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, K, LDU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( LDU, * ), DSIGMA( * ), &
                         VF( * ), VL( * ), WORK( * ), Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASD9 finds the square roots of the roots of the secular equation,
!  as defined by the values in DSIGMA and Z.  It makes the
!  appropriate calls to DLASD4, and stores, for each  element in D,
!  the distance to its two nearest poles (elements in DSIGMA). It also
!  updates the arrays VF and VL, the first and last components of all
!  the right singular vectors of the original bidiagonal matrix.
!
!  DLASD9 is called from DLASD7.
!
!  Arguments
!  =========
!
!  ICOMPQ  (input) INTEGER
!          Specifies whether singular vectors are to be computed in
!          factored form in the calling routine:
!
!             ICOMPQ = 0             Compute singular values only.
!
!             ICOMPQ = 1             Compute singular vector matrices in
!                                    factored form also.
!  K       (input) INTEGER
!          The number of terms in the rational function to be solved by
!          DLASD4.  K >= 1.
!
!  D       (output) DOUBLE PRECISION array, dimension(K)
!          D(I) contains the updated singular values.
!
!  DSIGMA  (input) DOUBLE PRECISION array, dimension(K)
!          The first K elements of this array contain the old roots
!          of the deflated updating problem.  These are the poles
!          of the secular equation.
!
!  Z       (input) DOUBLE PRECISION array, dimension (K)
!          The first K elements of this array contain the components
!          of the deflation-adjusted updating row vector.
!
!  VF      (input/output) DOUBLE PRECISION array, dimension(K)
!          On entry, VF contains  information passed through SBEDE8.f
!          On exit, VF contains the first K components of the first
!          components of all right singular vectors of the bidiagonal
!          matrix.
!
!  VL      (input/output) DOUBLE PRECISION array, dimension(K)
!          On entry, VL contains  information passed through SBEDE8.f
!          On exit, VL contains the first K components of the last
!          components of all right singular vectors of the bidiagonal
!          matrix.
!
!  DIFL    (output) DOUBLE PRECISION array, dimension (K).
!          On exit, DIFL(I) = D(I) - DSIGMA(I).
!
!  DIFR    (output) DOUBLE PRECISION array,
!                              dimension (LDU, 2) if ICOMPQ =1 and
!                              dimension (K) if ICOMPQ = 0.
!          On exit, DIFR(I, 1) = D(I) - DSIGMA(I+1), DIFR(K, 1) is not
!          defined and will not be referenced.
!
!          If ICOMPQ = 1, DIFR(1:K, 2) is an array containing the
!          normalizing factors for the right singular vector matrix.
!
!  WORK    (workspace) DOUBLE PRECISION array,
!                                 dimension at least (3 * K)
!          Workspace.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DJP1, DSIGJ, DSIGJP, RHO, &
                         TEMP
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMC3, DNRM2
      EXTERNAL           DDOT, DLAMC3, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLASCL, DLASD4, DLASET, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( K.LT.1 ) THEN
         INFO = -3
      ELSE IF( LDU.LT.K ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASD9', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( K.EQ.1 ) THEN
         D( 1 ) = ABS( Z( 1 ) )
         DIFL( 1 ) = D( 1 )
         IF( ICOMPQ.EQ.1 ) THEN
            DIFL( 2 ) = ONE
            DIFR( 1, 2 ) = ONE
         END IF
         RETURN
      END IF
!
!     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
!     be computed with high relative accuracy (barring over/underflow).
!     This is a problem on machines without a guard digit in
!     add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
!     The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
!     which on any of these machines zeros out the bottommost
!     bit of DSIGMA(I) if it is 1; this makes the subsequent
!     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
!     occurs. On binary machines with a guard digit (almost all
!     machines) it does not change DSIGMA(I) at all. On hexadecimal
!     and decimal machines with a guard digit, it slightly
!     changes the bottommost bits of DSIGMA(I). It does not account
!     for hexadecimal or decimal machines without guard digits
!     (we know of none). We use a subroutine call to compute
!     2*DLAMBDA(I) to prevent optimizing compilers from eliminating
!     this code.
!
      DO 10 I = 1, K
         DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
   10 CONTINUE
!
!     Book keeping.
!
      IWK1 = 1
      IWK2 = IWK1 + K
      IWK3 = IWK2 + K
      IWK2I = IWK2 - 1
      IWK3I = IWK3 - 1
!
!     Normalize Z.
!
      RHO = DNRM2( K, Z, 1 )
      CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
      RHO = RHO*RHO
!
!     Initialize WORK(IWK3).
!
      CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
!
!     Compute the updated singular values, the arrays DIFL, DIFR,
!     and the updated Z.
!
      DO 40 J = 1, K
         CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ), &
                      WORK( IWK2 ), INFO )
!
!        If the root finder fails, the computation is terminated.
!
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
         DIFL( J ) = -WORK( J )
         DIFR( J, 1 ) = -WORK( J+1 )
         DO 20 I = 1, J - 1
            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* &
                              WORK( IWK2I+I ) / ( DSIGMA( I )- &
                              DSIGMA( J ) ) / ( DSIGMA( I )+ &
                              DSIGMA( J ) )
   20    CONTINUE
         DO 30 I = J + 1, K
            WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )* &
                              WORK( IWK2I+I ) / ( DSIGMA( I )- &
                              DSIGMA( J ) ) / ( DSIGMA( I )+ &
                              DSIGMA( J ) )
   30    CONTINUE
   40 CONTINUE
!
!     Compute updated Z.
!
      DO 50 I = 1, K
         Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
   50 CONTINUE
!
!     Update VF and VL.
!
      DO 80 J = 1, K
         DIFLJ = DIFL( J )
         DJ = D( J )
         DSIGJ = -DSIGMA( J )
         IF( J.LT.K ) THEN
            DIFRJ = -DIFR( J, 1 )
            DJP1 = D( J+1 )
            DSIGJP = -DSIGMA( J+1 )
         END IF
         WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
         DO 60 I = 1, J - 1
            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ ) &
                         / ( DSIGMA( I )+DJ )
   60    CONTINUE
         DO 70 I = J + 1, K
            WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ ) &
                         / ( DSIGMA( I )+DJ )
   70    CONTINUE
         TEMP = DNRM2( K, WORK, 1 )
         WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
         WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
         IF( ICOMPQ.EQ.1 ) THEN
            DIFR( J, 2 ) = TEMP
         END IF
   80 CONTINUE
!
      CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
      CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
!
      RETURN
!
!     End of DLASD9
!
      END
      SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, &
                         DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, &
                         PERM, GIVNUM, C, S, WORK, IWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
!     ..
!     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), &
                         K( * ), PERM( LDGCOL, * )
      DOUBLE PRECISION   C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), &
                         E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), &
                         S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), &
                         Z( LDU, * )
!     ..
!
!  Purpose
!  =======
!
!  Using a divide and conquer approach, DLASDA computes the singular
!  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
!  B with diagonal D and offdiagonal E, where M = N + SQRE. The
!  algorithm computes the singular values in the SVD B = U * S * VT.
!  The orthogonal matrices U and VT are optionally computed in
!  compact form.
!
!  A related subroutine, DLASD0, computes the singular values and
!  the singular vectors in explicit form.
!
!  Arguments
!  =========
!
!  ICOMPQ (input) INTEGER
!         Specifies whether singular vectors are to be computed
!         in compact form, as follows
!         = 0: Compute singular values only.
!         = 1: Compute singular vectors of upper bidiagonal
!              matrix in compact form.
!
!  SMLSIZ (input) INTEGER
!         The maximum size of the subproblems at the bottom of the
!         computation tree.
!
!  N      (input) INTEGER
!         The row dimension of the upper bidiagonal matrix. This is
!         also the dimension of the main diagonal array D.
!
!  SQRE   (input) INTEGER
!         Specifies the column dimension of the bidiagonal matrix.
!         = 0: The bidiagonal matrix has column dimension M = N;
!         = 1: The bidiagonal matrix has column dimension M = N + 1.
!
!  D      (input/output) DOUBLE PRECISION array, dimension ( N )
!         On entry D contains the main diagonal of the bidiagonal
!         matrix. On exit D, if INFO = 0, contains its singular values.
!
!  E      (input) DOUBLE PRECISION array, dimension ( M-1 )
!         Contains the subdiagonal entries of the bidiagonal matrix.
!         On exit, E has been destroyed.
!
!  U      (output) DOUBLE PRECISION array,
!         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
!         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
!         singular vector matrices of all subproblems at the bottom
!         level.
!
!  LDU    (input) INTEGER, LDU = > N.
!         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
!         GIVNUM, and Z.
!
!  VT     (output) DOUBLE PRECISION array,
!         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
!         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
!         singular vector matrices of all subproblems at the bottom
!         level.
!
!  K      (output) INTEGER array,
!         dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
!         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
!         secular equation on the computation tree.
!
!  DIFL   (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
!         where NLVL = floor(log_2 (N/SMLSIZ))).
!
!  DIFR   (output) DOUBLE PRECISION array,
!                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
!                  dimension ( N ) if ICOMPQ = 0.
!         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
!         record distances between singular values on the I-th
!         level and singular values on the (I -1)-th level, and
!         DIFR(1:N, 2 * I ) contains the normalizing factors for
!         the right singular vector matrix. See DLASD8 for details.
!
!  Z      (output) DOUBLE PRECISION array,
!                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and
!                  dimension ( N ) if ICOMPQ = 0.
!         The first K elements of Z(1, I) contain the components of
!         the deflation-adjusted updating row vector for subproblems
!         on the I-th level.
!
!  POLES  (output) DOUBLE PRECISION array,
!         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
!         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
!         POLES(1, 2*I) contain  the new and old singular values
!         involved in the secular equations on the I-th level.
!
!  GIVPTR (output) INTEGER array,
!         dimension ( N ) if ICOMPQ = 1, and not referenced if
!         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
!         the number of Givens rotations performed on the I-th
!         problem on the computation tree.
!
!  GIVCOL (output) INTEGER array,
!         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
!         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
!         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
!         of Givens rotations performed on the I-th level on the
!         computation tree.
!
!  LDGCOL (input) INTEGER, LDGCOL = > N.
!         The leading dimension of arrays GIVCOL and PERM.
!
!  PERM   (output) INTEGER array,
!         dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
!         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
!         permutations done on the I-th level of the computation tree.
!
!  GIVNUM (output) DOUBLE PRECISION array,
!         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not
!         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
!         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
!         values of Givens rotations performed on the I-th level on
!         the computation tree.
!
!  C      (output) DOUBLE PRECISION array,
!         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
!         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
!         C( I ) contains the C-value of a Givens rotation related to
!         the right null space of the I-th subproblem.
!
!  S      (output) DOUBLE PRECISION array, dimension ( N ) if
!         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
!         and the I-th subproblem is not square, on exit, S( I )
!         contains the S-value of a Givens rotation related to
!         the right null space of the I-th subproblem.
!
!  WORK   (workspace) DOUBLE PRECISION array, dimension
!         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
!
!  IWORK  (workspace) INTEGER array.
!         Dimension must be at least (7 * N).
!
!  INFO   (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = 1, an singular value did not converge
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK, &
                         J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML, &
                         NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU, &
                         NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( SMLSIZ.LT.3 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -4
      ELSE IF( LDU.LT.( N+SQRE ) ) THEN
         INFO = -8
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASDA', -INFO )
         RETURN
      END IF
!
      M = N + SQRE
!
!     If the input matrix is too small, call DLASDQ to find the SVD.
!
      IF( N.LE.SMLSIZ ) THEN
         IF( ICOMPQ.EQ.0 ) THEN
            CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU, &
                         U, LDU, WORK, INFO )
         ELSE
            CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU, &
                         U, LDU, WORK, INFO )
         END IF
         RETURN
      END IF
!
!     Book-keeping and  set up the computation tree.
!
      INODE = 1
      NDIML = INODE + N
      NDIMR = NDIML + N
      IDXQ = NDIMR + N
      IWK = IDXQ + N
!
      NCC = 0
      NRU = 0
!
      SMLSZP = SMLSIZ + 1
      VF = 1
      VL = VF + M
      NWORK1 = VL + M
      NWORK2 = NWORK1 + SMLSZP*SMLSZP
!
      CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ), &
                   IWORK( NDIMR ), SMLSIZ )
!
!     for the nodes on bottom level of the tree, solve
!     their subproblems by DLASDQ.
!
      NDB1 = ( ND+1 ) / 2
      DO 30 I = NDB1, ND
!
!        IC : center row of each node
!        NL : number of rows of left  subproblem
!        NR : number of rows of right subproblem
!        NLF: starting row of the left   subproblem
!        NRF: starting row of the right  subproblem
!
         I1 = I - 1
         IC = IWORK( INODE+I1 )
         NL = IWORK( NDIML+I1 )
         NLP1 = NL + 1
         NR = IWORK( NDIMR+I1 )
         NLF = IC - NL
         NRF = IC + 1
         IDXQI = IDXQ + NLF - 2
         VFI = VF + NLF - 1
         VLI = VL + NLF - 1
         SQREI = 1
         IF( ICOMPQ.EQ.0 ) THEN
            CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ), &
                         SMLSZP )
            CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ), &
                         E( NLF ), WORK( NWORK1 ), SMLSZP, &
                         WORK( NWORK2 ), NL, WORK( NWORK2 ), NL, &
                         WORK( NWORK2 ), INFO )
            ITEMP = NWORK1 + NL*SMLSZP
            CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
            CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
         ELSE
            CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
            CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
            CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), &
                         E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU, &
                         U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
            CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
            CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
         END IF
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         DO 10 J = 1, NL
            IWORK( IDXQI+J ) = J
   10    CONTINUE
         IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
            SQREI = 0
         ELSE
            SQREI = 1
         END IF
         IDXQI = IDXQI + NLP1
         VFI = VFI + NLP1
         VLI = VLI + NLP1
         NRP1 = NR + SQREI
         IF( ICOMPQ.EQ.0 ) THEN
            CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ), &
                         SMLSZP )
            CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ), &
                         E( NRF ), WORK( NWORK1 ), SMLSZP, &
                         WORK( NWORK2 ), NR, WORK( NWORK2 ), NR, &
                         WORK( NWORK2 ), INFO )
            ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
            CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
            CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
         ELSE
            CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
            CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
            CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), &
                         E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU, &
                         U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
            CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
            CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
         END IF
         IF( INFO.NE.0 ) THEN
            RETURN
         END IF
         DO 20 J = 1, NR
            IWORK( IDXQI+J ) = J
   20    CONTINUE
   30 CONTINUE
!
!     Now conquer each subproblem bottom-up.
!
      J = 2**NLVL
      DO 50 LVL = NLVL, 1, -1
         LVL2 = LVL*2 - 1
!
!        Find the first node LF and last node LL on
!        the current level LVL.
!
         IF( LVL.EQ.1 ) THEN
            LF = 1
            LL = 1
         ELSE
            LF = 2**( LVL-1 )
            LL = 2*LF - 1
         END IF
         DO 40 I = LF, LL
            IM1 = I - 1
            IC = IWORK( INODE+IM1 )
            NL = IWORK( NDIML+IM1 )
            NR = IWORK( NDIMR+IM1 )
            NLF = IC - NL
            NRF = IC + 1
            IF( I.EQ.LL ) THEN
               SQREI = SQRE
            ELSE
               SQREI = 1
            END IF
            VFI = VF + NLF - 1
            VLI = VL + NLF - 1
            IDXQI = IDXQ + NLF - 1
            ALPHA = D( IC )
            BETA = E( IC )
            IF( ICOMPQ.EQ.0 ) THEN
               CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), &
                            WORK( VFI ), WORK( VLI ), ALPHA, BETA, &
                            IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL, &
                            LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z, &
                            K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ), &
                            IWORK( IWK ), INFO )
            ELSE
               J = J - 1
               CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ), &
                            WORK( VFI ), WORK( VLI ), ALPHA, BETA, &
                            IWORK( IDXQI ), PERM( NLF, LVL ), &
                            GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL, &
                            GIVNUM( NLF, LVL2 ), LDU, &
                            POLES( NLF, LVL2 ), DIFL( NLF, LVL ), &
                            DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ), &
                            C( J ), S( J ), WORK( NWORK1 ), &
                            IWORK( IWK ), INFO )
            END IF
            IF( INFO.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
!
      RETURN
!
!     End of DLASDA
!
      END
      SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, &
                         U, LDU, C, LDC, WORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ), &
                         VT( LDVT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASDQ computes the singular value decomposition (SVD) of a real
!  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
!  E, accumulating the transformations if desired. Letting B denote
!  the input bidiagonal matrix, the algorithm computes orthogonal
!  matrices Q and P such that B = Q * S * P' (P' denotes the transpose
!  of P). The singular values S are overwritten on D.
!
!  The input matrix U  is changed to U  * Q  if desired.
!  The input matrix VT is changed to P' * VT if desired.
!  The input matrix C  is changed to Q' * C  if desired.
!
!  See "Computing  Small Singular Values of Bidiagonal Matrices With
!  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
!  LAPACK Working Note #3, for a detailed description of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO  (input) CHARACTER*1
!        On entry, UPLO specifies whether the input bidiagonal matrix
!        is upper or lower bidiagonal, and wether it is square are
!        not.
!           UPLO = 'U' or 'u'   B is upper bidiagonal.
!           UPLO = 'L' or 'l'   B is lower bidiagonal.
!
!  SQRE  (input) INTEGER
!        = 0: then the input matrix is N-by-N.
!        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
!             (N+1)-by-N if UPLU = 'L'.
!
!        The bidiagonal matrix has
!        N = NL + NR + 1 rows and
!        M = N + SQRE >= N columns.
!
!  N     (input) INTEGER
!        On entry, N specifies the number of rows and columns
!        in the matrix. N must be at least 0.
!
!  NCVT  (input) INTEGER
!        On entry, NCVT specifies the number of columns of
!        the matrix VT. NCVT must be at least 0.
!
!  NRU   (input) INTEGER
!        On entry, NRU specifies the number of rows of
!        the matrix U. NRU must be at least 0.
!
!  NCC   (input) INTEGER
!        On entry, NCC specifies the number of columns of
!        the matrix C. NCC must be at least 0.
!
!  D     (input/output) DOUBLE PRECISION array, dimension (N)
!        On entry, D contains the diagonal entries of the
!        bidiagonal matrix whose SVD is desired. On normal exit,
!        D contains the singular values in ascending order.
!
!  E     (input/output) DOUBLE PRECISION array.
!        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
!        On entry, the entries of E contain the offdiagonal entries
!        of the bidiagonal matrix whose SVD is desired. On normal
!        exit, E will contain 0. If the algorithm does not converge,
!        D and E will contain the diagonal and superdiagonal entries
!        of a bidiagonal matrix orthogonally equivalent to the one
!        given as input.
!
!  VT    (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
!        On entry, contains a matrix which on exit has been
!        premultiplied by P', dimension N-by-NCVT if SQRE = 0
!        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
!
!  LDVT  (input) INTEGER
!        On entry, LDVT specifies the leading dimension of VT as
!        declared in the calling (sub) program. LDVT must be at
!        least 1. If NCVT is nonzero LDVT must also be at least N.
!
!  U     (input/output) DOUBLE PRECISION array, dimension (LDU, N)
!        On entry, contains a  matrix which on exit has been
!        postmultiplied by Q, dimension NRU-by-N if SQRE = 0
!        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
!
!  LDU   (input) INTEGER
!        On entry, LDU  specifies the leading dimension of U as
!        declared in the calling (sub) program. LDU must be at
!        least max( 1, NRU ) .
!
!  C     (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
!        On entry, contains an N-by-NCC matrix which on exit
!        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0
!        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
!
!  LDC   (input) INTEGER
!        On entry, LDC  specifies the leading dimension of C as
!        declared in the calling (sub) program. LDC must be at
!        least 1. If NCC is nonzero, LDC must also be at least N.
!
!  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)
!        Workspace. Only referenced if one of NCVT, NRU, or NCC is
!        nonzero, and if N is at least 2.
!
!  INFO  (output) INTEGER
!        On exit, a value of 0 indicates a successful exit.
!        If INFO < 0, argument number -INFO is illegal.
!        If INFO > 0, the algorithm did not converge, and INFO
!        specifies how many superdiagonals did not converge.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
      DOUBLE PRECISION   CS, R, SMIN, SN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DBDSQR, DLARTG, DLASR, DSWAP, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IUPLO = 0
      IF( LSAME( UPLO, 'U' ) ) &
         IUPLO = 1
      IF( LSAME( UPLO, 'L' ) ) &
         IUPLO = 2
      IF( IUPLO.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCVT.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRU.LT.0 ) THEN
         INFO = -5
      ELSE IF( NCC.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. &
               ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
         INFO = -12
      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. &
               ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
         INFO = -14
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASDQ', -INFO )
         RETURN
      END IF
      IF( N.EQ.0 ) &
         RETURN
!
!     ROTATE is true if any singular vectors desired, false otherwise
!
      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
      NP1 = N + 1
      SQRE1 = SQRE
!
!     If matrix non-square upper bidiagonal, rotate to be lower
!     bidiagonal.  The rotations are on the right.
!
      IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
         DO 10 I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( ROTATE ) THEN
               WORK( I ) = CS
               WORK( N+I ) = SN
            END IF
   10    CONTINUE
         CALL DLARTG( D( N ), E( N ), CS, SN, R )
         D( N ) = R
         E( N ) = ZERO
         IF( ROTATE ) THEN
            WORK( N ) = CS
            WORK( N+N ) = SN
         END IF
         IUPLO = 2
         SQRE1 = 0
!
!        Update singular vectors if desired.
!
         IF( NCVT.GT.0 ) &
            CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ), &
                        WORK( NP1 ), VT, LDVT )
      END IF
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left.
!
      IF( IUPLO.EQ.2 ) THEN
         DO 20 I = 1, N - 1
            CALL DLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( ROTATE ) THEN
               WORK( I ) = CS
               WORK( N+I ) = SN
            END IF
   20    CONTINUE
!
!        If matrix (N+1)-by-N lower bidiagonal, one additional
!        rotation is needed.
!
         IF( SQRE1.EQ.1 ) THEN
            CALL DLARTG( D( N ), E( N ), CS, SN, R )
            D( N ) = R
            IF( ROTATE ) THEN
               WORK( N ) = CS
               WORK( N+N ) = SN
            END IF
         END IF
!
!        Update singular vectors if desired.
!
         IF( NRU.GT.0 ) THEN
            IF( SQRE1.EQ.0 ) THEN
               CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), &
                           WORK( NP1 ), U, LDU )
            ELSE
               CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ), &
                           WORK( NP1 ), U, LDU )
            END IF
         END IF
         IF( NCC.GT.0 ) THEN
            IF( SQRE1.EQ.0 ) THEN
               CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), &
                           WORK( NP1 ), C, LDC )
            ELSE
               CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ), &
                           WORK( NP1 ), C, LDC )
            END IF
         END IF
      END IF
!
!     Call DBDSQR to compute the SVD of the reduced real
!     N-by-N upper bidiagonal matrix.
!
      CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, &
                   LDC, WORK, INFO )
!
!     Sort the singular values into ascending order (insertion sort on
!     singular values, but only one transposition per singular vector)
!
      DO 40 I = 1, N
!
!        Scan for smallest D(I).
!
         ISUB = I
         SMIN = D( I )
         DO 30 J = I + 1, N
            IF( D( J ).LT.SMIN ) THEN
               ISUB = J
               SMIN = D( J )
            END IF
   30    CONTINUE
         IF( ISUB.NE.I ) THEN
!
!           Swap singular values and vectors.
!
            D( ISUB ) = D( I )
            D( I ) = SMIN
            IF( NCVT.GT.0 ) &
               CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
            IF( NRU.GT.0 ) &
               CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
            IF( NCC.GT.0 ) &
               CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
         END IF
   40 CONTINUE
!
      RETURN
!
!     End of DLASDQ
!
      END
      SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            LVL, MSUB, N, ND
!     ..
!     .. Array Arguments ..
      INTEGER            INODE( * ), NDIML( * ), NDIMR( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASDT creates a tree of subproblems for bidiagonal divide and
!  conquer.
!
!  Arguments
!  =========
!
!   N      (input) INTEGER
!          On entry, the number of diagonal elements of the
!          bidiagonal matrix.
!
!   LVL    (output) INTEGER
!          On exit, the number of levels on the computation tree.
!
!   ND     (output) INTEGER
!          On exit, the number of nodes on the tree.
!
!   INODE  (output) INTEGER array, dimension ( N )
!          On exit, centers of subproblems.
!
!   NDIML  (output) INTEGER array, dimension ( N )
!          On exit, row dimensions of left children.
!
!   NDIMR  (output) INTEGER array, dimension ( N )
!          On exit, row dimensions of right children.
!
!   MSUB   (input) INTEGER.
!          On entry, the maximum row dimension each subproblem at the
!          bottom of the tree can be of.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Ming Gu and Huan Ren, Computer Science Division, University of
!     California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IL, IR, LLST, MAXN, NCRNT, NLVL
      DOUBLE PRECISION   TEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, LOG, MAX
!     ..
!     .. Executable Statements ..
!
!     Find the number of levels on the tree.
!
      MAXN = MAX( 1, N )
      TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO )
      LVL = INT( TEMP ) + 1
!
      I = N / 2
      INODE( 1 ) = I + 1
      NDIML( 1 ) = I
      NDIMR( 1 ) = N - I - 1
      IL = 0
      IR = 1
      LLST = 1
      DO 20 NLVL = 1, LVL - 1
!
!        Constructing the tree at (NLVL+1)-st level. The number of
!        nodes created on this level is LLST * 2.
!
         DO 10 I = 0, LLST - 1
            IL = IL + 2
            IR = IR + 2
            NCRNT = LLST + I
            NDIML( IL ) = NDIML( NCRNT ) / 2
            NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
            INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
            NDIML( IR ) = NDIMR( NCRNT ) / 2
            NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
            INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
   10    CONTINUE
         LLST = LLST*2
   20 CONTINUE
      ND = LLST*2 - 1
!
      RETURN
!
!     End of DLASDT
!
      END
      SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, M, N
      DOUBLE PRECISION   ALPHA, BETA
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASET initializes an m-by-n matrix A to BETA on the diagonal and
!  ALPHA on the offdiagonals.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies the part of the matrix A to be set.
!          = 'U':      Upper triangular part is set; the strictly lower
!                      triangular part of A is not changed.
!          = 'L':      Lower triangular part is set; the strictly upper
!                      triangular part of A is not changed.
!          Otherwise:  All of the matrix A is set.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  ALPHA   (input) DOUBLE PRECISION
!          The constant to which the offdiagonal elements are to be set.
!
!  BETA    (input) DOUBLE PRECISION
!          The constant to which the diagonal elements are to be set.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On exit, the leading m-by-n submatrix of A is set as follows:
!
!          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
!          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
!          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
!
!          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
      IF( LSAME( UPLO, 'U' ) ) THEN
!
!        Set the strictly upper triangular or trapezoidal part of the
!        array to ALPHA.
!
         DO 20 J = 2, N
            DO 10 I = 1, MIN( J-1, M )
               A( I, J ) = ALPHA
   10       CONTINUE
   20    CONTINUE
!
      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
!
!        Set the strictly lower triangular or trapezoidal part of the
!        array to ALPHA.
!
         DO 40 J = 1, MIN( M, N )
            DO 30 I = J + 1, M
               A( I, J ) = ALPHA
   30       CONTINUE
   40    CONTINUE
!
      ELSE
!
!        Set the leading m-by-n submatrix to ALPHA.
!
         DO 60 J = 1, N
            DO 50 I = 1, M
               A( I, J ) = ALPHA
   50       CONTINUE
   60    CONTINUE
      END IF
!
!     Set the first min(M,N) diagonal elements to BETA.
!
      DO 70 I = 1, MIN( M, N )
         A( I, I ) = BETA
   70 CONTINUE
!
      RETURN
!
!     End of DLASET
!
      END
      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ1 computes the singular values of a real N-by-N bidiagonal
!  matrix with diagonal D and off-diagonal E. The singular values
!  are computed to high relative accuracy, in the absence of
!  denormalization, underflow and overflow. The algorithm was first
!  presented in
!
!  "Accurate singular values and differential qd algorithms" by K. V.
!  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
!  1994,
!
!  and the present implementation is described in "An implementation of
!  the dqds Algorithm (Positive Case)", LAPACK Working Note.
!
!  Arguments
!  =========
!
!  N     (input) INTEGER
!        The number of rows and columns in the matrix. N >= 0.
!
!  D     (input/output) DOUBLE PRECISION array, dimension (N)
!        On entry, D contains the diagonal elements of the
!        bidiagonal matrix whose SVD is desired. On normal exit,
!        D contains the singular values in decreasing order.
!
!  E     (input/output) DOUBLE PRECISION array, dimension (N)
!        On entry, elements E(1:N-1) contain the off-diagonal elements
!        of the bidiagonal matrix whose SVD is desired.
!        On exit, E is overwritten.
!
!  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  INFO  (output) INTEGER
!        = 0: successful exit
!        < 0: if INFO = -i, the i-th argument had an illegal value
!        > 0: the algorithm failed
!             = 1, a split was marked by a positive value in E
!             = 2, current block of Z not diagonalized after 30*N
!                  iterations (in inner while loop)
!             = 3, termination criterion of outer while loop not met
!                  (program created more than N unreduced blocks)
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO
      DOUBLE PRECISION   EPS, SCALE, SAFMIN, SIGMN, SIGMX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAS2, DLASQ2, DLASRT, XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -2
         CALL XERBLA( 'DLASQ1', -INFO )
         RETURN
      ELSE IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         D( 1 ) = ABS( D( 1 ) )
         RETURN
      ELSE IF( N.EQ.2 ) THEN
         CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
         D( 1 ) = SIGMX
         D( 2 ) = SIGMN
         RETURN
      END IF
!
!     Estimate the largest singular value.
!
      SIGMX = ZERO
      DO 10 I = 1, N - 1
         D( I ) = ABS( D( I ) )
         SIGMX = MAX( SIGMX, ABS( E( I ) ) )
   10 CONTINUE
      D( N ) = ABS( D( N ) )
!
!     Early return if SIGMX is zero (matrix is already diagonal).
!
      IF( SIGMX.EQ.ZERO ) THEN
         CALL DLASRT( 'D', N, D, IINFO )
         RETURN
      END IF
!
      DO 20 I = 1, N
         SIGMX = MAX( SIGMX, D( I ) )
   20 CONTINUE
!
!     Copy D and E into WORK (in the Z format) and scale (squaring the
!     input data makes scaling by a power of the radix pointless).
!
      EPS = DLAMCH( 'Precision' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SCALE = SQRT( EPS / SAFMIN )
      CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
      CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
      CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, &
                   IINFO )
!
!     Compute the q's and e's.
!
      DO 30 I = 1, 2*N - 1
         WORK( I ) = WORK( I )**2
   30 CONTINUE
      WORK( 2*N ) = ZERO
!
      CALL DLASQ2( N, WORK, INFO )
!
      IF( INFO.EQ.0 ) THEN
         DO 40 I = 1, N
            D( I ) = SQRT( WORK( I ) )
   40    CONTINUE
         CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
      END IF
!
      RETURN
!
!     End of DLASQ1
!
      END
      SUBROUTINE DLASQ2( N, Z, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ2 computes all the eigenvalues of the symmetric positive
!  definite tridiagonal matrix associated with the qd array Z to high
!  relative accuracy are computed to high relative accuracy, in the
!  absence of denormalization, underflow and overflow.
!
!  To see the relation of Z to the tridiagonal matrix, let L be a
!  unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
!  let U be an upper bidiagonal matrix with 1's above and diagonal
!  Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
!  symmetric tridiagonal to which it is similar.
!
!  Note : DLASQ2 defines a logical variable, IEEE, which is true
!  on machines which follow ieee-754 floating-point standard in their
!  handling of infinities and NaNs, and false otherwise. This variable
!  is passed to DLASQ3.
!
!  Arguments
!  =========
!
!  N     (input) INTEGER
!        The number of rows and columns in the matrix. N >= 0.
!
!  Z     (workspace) DOUBLE PRECISION array, dimension ( 4*N )
!        On entry Z holds the qd array. On exit, entries 1 to N hold
!        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
!        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
!        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
!        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
!        shifts that failed.
!
!  INFO  (output) INTEGER
!        = 0: successful exit
!        < 0: if the i-th argument is a scalar and had an illegal
!             value, then INFO = -i, if the i-th argument is an
!             array and the j-entry had an illegal value, then
!             INFO = -(i*100+j)
!        > 0: the algorithm failed
!              = 1, a split was marked by a positive value in E
!              = 2, current block of Z not diagonalized after 30*N
!                   iterations (in inner while loop)
!              = 3, termination criterion of outer while loop not met
!                   (program created more than N unreduced blocks)
!
!  Further Details
!  ===============
!  Local Variables: I0:N0 defines a current unreduced segment of Z.
!  The shifts are accumulated in SIGMA. Iteration count is in ITER.
!  Ping-pong is controlled by PP (alternates between 0 and 1).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   CBIAS
      PARAMETER          ( CBIAS = 1.50D0 )
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, FOUR, HUNDRD
      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, &
                           TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            IEEE
      INTEGER            I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, &
                         N0, NBIG, NDIV, NFAIL, PP, SPLT
      DOUBLE PRECISION   D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, &
                         QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, &
                         TOL2, TRACE, ZMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASQ3, DLASRT, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!     (in case DLASQ2 is not called by DLASQ1)
!
      INFO = 0
      EPS = DLAMCH( 'Precision' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      TOL = EPS*HUNDRD
      TOL2 = TOL**2
!
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DLASQ2', 1 )
         RETURN
      ELSE IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
!
!        1-by-1 case.
!
         IF( Z( 1 ).LT.ZERO ) THEN
            INFO = -201
            CALL XERBLA( 'DLASQ2', 2 )
         END IF
         RETURN
      ELSE IF( N.EQ.2 ) THEN
!
!        2-by-2 case.
!
         IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
            INFO = -2
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
            D = Z( 3 )
            Z( 3 ) = Z( 1 )
            Z( 1 ) = D
         END IF
         Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
         IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
            T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
            S = Z( 3 )*( Z( 2 ) / T )
            IF( S.LE.T ) THEN
               S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
            ELSE
               S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
            END IF
            T = Z( 1 ) + ( S+Z( 2 ) )
            Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
            Z( 1 ) = T
         END IF
         Z( 2 ) = Z( 3 )
         Z( 6 ) = Z( 2 ) + Z( 1 )
         RETURN
      END IF
!
!     Check for negative data and compute sums of q's and e's.
!
      Z( 2*N ) = ZERO
      EMIN = Z( 2 )
      QMAX = ZERO
      ZMAX = ZERO
      D = ZERO
      E = ZERO
!
      DO 10 K = 1, 2*( N-1 ), 2
         IF( Z( K ).LT.ZERO ) THEN
            INFO = -( 200+K )
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         ELSE IF( Z( K+1 ).LT.ZERO ) THEN
            INFO = -( 200+K+1 )
            CALL XERBLA( 'DLASQ2', 2 )
            RETURN
         END IF
         D = D + Z( K )
         E = E + Z( K+1 )
         QMAX = MAX( QMAX, Z( K ) )
         EMIN = MIN( EMIN, Z( K+1 ) )
         ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
   10 CONTINUE
      IF( Z( 2*N-1 ).LT.ZERO ) THEN
         INFO = -( 200+2*N-1 )
         CALL XERBLA( 'DLASQ2', 2 )
         RETURN
      END IF
      D = D + Z( 2*N-1 )
      QMAX = MAX( QMAX, Z( 2*N-1 ) )
      ZMAX = MAX( QMAX, ZMAX )
!
!     Check for diagonality.
!
      IF( E.EQ.ZERO ) THEN
         DO 20 K = 2, N
            Z( K ) = Z( 2*K-1 )
   20    CONTINUE
         CALL DLASRT( 'D', N, Z, IINFO )
         Z( 2*N-1 ) = D
         RETURN
      END IF
!
      TRACE = D + E
!
!     Check for zero data.
!
      IF( TRACE.EQ.ZERO ) THEN
         Z( 2*N-1 ) = ZERO
         RETURN
      END IF
!
!     Check whether the machine is IEEE conformable.
!
      IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. &
             ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
!
!     Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
!
      DO 30 K = 2*N, 2, -2
         Z( 2*K ) = ZERO
         Z( 2*K-1 ) = Z( K )
         Z( 2*K-2 ) = ZERO
         Z( 2*K-3 ) = Z( K-1 )
   30 CONTINUE
!
      I0 = 1
      N0 = N
!
!     Reverse the qd-array, if warranted.
!
      IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
         IPN4 = 4*( I0+N0 )
         DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
            TEMP = Z( I4-3 )
            Z( I4-3 ) = Z( IPN4-I4-3 )
            Z( IPN4-I4-3 ) = TEMP
            TEMP = Z( I4-1 )
            Z( I4-1 ) = Z( IPN4-I4-5 )
            Z( IPN4-I4-5 ) = TEMP
   40    CONTINUE
      END IF
!
!     Initial split checking via dqd and Li's test.
!
      PP = 0
!
      DO 80 K = 1, 2
!
         D = Z( 4*N0+PP-3 )
         DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
            IF( Z( I4-1 ).LE.TOL2*D ) THEN
               Z( I4-1 ) = -ZERO
               D = Z( I4-3 )
            ELSE
               D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
            END IF
   50    CONTINUE
!
!        dqd maps Z to ZZ plus Li's test.
!
         EMIN = Z( 4*I0+PP+1 )
         D = Z( 4*I0+PP-3 )
         DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
            Z( I4-2*PP-2 ) = D + Z( I4-1 )
            IF( Z( I4-1 ).LE.TOL2*D ) THEN
               Z( I4-1 ) = -ZERO
               Z( I4-2*PP-2 ) = D
               Z( I4-2*PP ) = ZERO
               D = Z( I4+1 )
            ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. &
                     SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
               TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
               Z( I4-2*PP ) = Z( I4-1 )*TEMP
               D = D*TEMP
            ELSE
               Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
               D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
            END IF
            EMIN = MIN( EMIN, Z( I4-2*PP ) )
   60    CONTINUE
         Z( 4*N0-PP-2 ) = D
!
!        Now find qmax.
!
         QMAX = Z( 4*I0-PP-2 )
         DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
            QMAX = MAX( QMAX, Z( I4 ) )
   70    CONTINUE
!
!        Prepare for the next iteration on K.
!
         PP = 1 - PP
   80 CONTINUE
!
      ITER = 2
      NFAIL = 0
      NDIV = 2*( N0-I0 )
!
      DO 140 IWHILA = 1, N + 1
         IF( N0.LT.1 ) &
            GO TO 150
!
!        While array unfinished do
!
!        E(N0) holds the value of SIGMA when submatrix in I0:N0
!        splits from the rest of the array, but is negated.
!
         DESIG = ZERO
         IF( N0.EQ.N ) THEN
            SIGMA = ZERO
         ELSE
            SIGMA = -Z( 4*N0-1 )
         END IF
         IF( SIGMA.LT.ZERO ) THEN
            INFO = 1
            RETURN
         END IF
!
!        Find last unreduced submatrix's top index I0, find QMAX and
!        EMIN. Find Gershgorin-type bound if Q's much greater than E's.
!
         EMAX = ZERO
         IF( N0.GT.I0 ) THEN
            EMIN = ABS( Z( 4*N0-5 ) )
         ELSE
            EMIN = ZERO
         END IF
         QMIN = Z( 4*N0-3 )
         QMAX = QMIN
         DO 90 I4 = 4*N0, 8, -4
            IF( Z( I4-5 ).LE.ZERO ) &
               GO TO 100
            IF( QMIN.GE.FOUR*EMAX ) THEN
               QMIN = MIN( QMIN, Z( I4-3 ) )
               EMAX = MAX( EMAX, Z( I4-5 ) )
            END IF
            QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
            EMIN = MIN( EMIN, Z( I4-5 ) )
   90    CONTINUE
         I4 = 4
!
  100    CONTINUE
         I0 = I4 / 4
!
!        Store EMIN for passing to DLASQ3.
!
         Z( 4*N0-1 ) = EMIN
!
!        Put -(initial shift) into DMIN.
!
         DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
!
!        Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
!
         PP = 0
!
         NBIG = 30*( N0-I0+1 )
         DO 120 IWHILB = 1, NBIG
            IF( I0.GT.N0 ) &
               GO TO 130
!
!           While submatrix unfinished take a good dqds step.
!
            CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, &
                         ITER, NDIV, IEEE )
!
            PP = 1 - PP
!
!           When EMIN is very small check for splits.
!
            IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
               IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. &
                   Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
                  SPLT = I0 - 1
                  QMAX = Z( 4*I0-3 )
                  EMIN = Z( 4*I0-1 )
                  OLDEMN = Z( 4*I0 )
                  DO 110 I4 = 4*I0, 4*( N0-3 ), 4
                     IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. &
                         Z( I4-1 ).LE.TOL2*SIGMA ) THEN
                        Z( I4-1 ) = -SIGMA
                        SPLT = I4 / 4
                        QMAX = ZERO
                        EMIN = Z( I4+3 )
                        OLDEMN = Z( I4+4 )
                     ELSE
                        QMAX = MAX( QMAX, Z( I4+1 ) )
                        EMIN = MIN( EMIN, Z( I4-1 ) )
                        OLDEMN = MIN( OLDEMN, Z( I4 ) )
                     END IF
  110             CONTINUE
                  Z( 4*N0-1 ) = EMIN
                  Z( 4*N0 ) = OLDEMN
                  I0 = SPLT + 1
               END IF
            END IF
!
  120    CONTINUE
!
         INFO = 2
         RETURN
!
!        end IWHILB
!
  130    CONTINUE
!
  140 CONTINUE
!
      INFO = 3
      RETURN
!
!     end IWHILA
!
  150 CONTINUE
!
!     Move q's to the front.
!
      DO 160 K = 2, N
         Z( K ) = Z( 4*K-3 )
  160 CONTINUE
!
!     Sort and compute sum of eigenvalues.
!
      CALL DLASRT( 'D', N, Z, IINFO )
!
      E = ZERO
      DO 170 K = N, 1, -1
         E = E + Z( K )
  170 CONTINUE
!
!     Store trace, sum(eigenvalues) and information on performance.
!
      Z( 2*N+1 ) = TRACE
      Z( 2*N+2 ) = E
      Z( 2*N+3 ) = DBLE( ITER )
      Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
      Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
      RETURN
!
!     End of DLASQ2
!
      END
      SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, &
                         ITER, NDIV, IEEE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     May 17, 2000
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            I0, ITER, N0, NDIV, NFAIL, PP
      DOUBLE PRECISION   DESIG, DMIN, QMAX, SIGMA
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
!  In case of failure it changes shifts, and tries again until output
!  is positive.
!
!  Arguments
!  =========
!
!  I0     (input) INTEGER
!         First index.
!
!  N0     (input) INTEGER
!         Last index.
!
!  Z      (input) DOUBLE PRECISION array, dimension ( 4*N )
!         Z holds the qd array.
!
!  PP     (input) INTEGER
!         PP=0 for ping, PP=1 for pong.
!
!  DMIN   (output) DOUBLE PRECISION
!         Minimum value of d.
!
!  SIGMA  (output) DOUBLE PRECISION
!         Sum of shifts used in current segment.
!
!  DESIG  (input/output) DOUBLE PRECISION
!         Lower order part of SIGMA
!
!  QMAX   (input) DOUBLE PRECISION
!         Maximum value of q.
!
!  NFAIL  (output) INTEGER
!         Number of times shift was too big.
!
!  ITER   (output) INTEGER
!         Number of iterations.
!
!  NDIV   (output) INTEGER
!         Number of divisions.
!
!  TTYPE  (output) INTEGER
!         Shift type.
!
!  IEEE   (input) LOGICAL
!         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   CBIAS
      PARAMETER          ( CBIAS = 1.50D0 )
      DOUBLE PRECISION   ZERO, QURTR, HALF, ONE, TWO, HUNDRD
      PARAMETER          ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, &
                           ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            IPN4, J4, N0IN, NN, TTYPE
      DOUBLE PRECISION   DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, &
                         TAU, TEMP, TOL, TOL2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASQ4, DLASQ5, DLASQ6
!     ..
!     .. External Function ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MIN, SQRT
!     ..
!     .. Save statement ..
      SAVE               TTYPE
      SAVE               DMIN1, DMIN2, DN, DN1, DN2, TAU
!     ..
!     .. Data statement ..
      DATA               TTYPE / 0 /
      DATA               DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, &
                         DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
!     ..
!     .. Executable Statements ..
!
      N0IN = N0
      EPS = DLAMCH( 'Precision' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      TOL = EPS*HUNDRD
      TOL2 = TOL**2
!
!     Check for deflation.
!
   10 CONTINUE
!
      IF( N0.LT.I0 ) &
         RETURN
      IF( N0.EQ.I0 ) &
         GO TO 20
      NN = 4*N0 + PP
      IF( N0.EQ.( I0+1 ) ) &
         GO TO 40
!
!     Check whether E(N0-1) is negligible, 1 eigenvalue.
!
      IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. &
          Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) &
         GO TO 30
!
   20 CONTINUE
!
      Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
      N0 = N0 - 1
      GO TO 10
!
!     Check  whether E(N0-2) is negligible, 2 eigenvalues.
!
   30 CONTINUE
!
      IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. &
          Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) &
         GO TO 50
!
   40 CONTINUE
!
      IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
         S = Z( NN-3 )
         Z( NN-3 ) = Z( NN-7 )
         Z( NN-7 ) = S
      END IF
      IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
         T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
         S = Z( NN-3 )*( Z( NN-5 ) / T )
         IF( S.LE.T ) THEN
            S = Z( NN-3 )*( Z( NN-5 ) / &
                ( T*( ONE+SQRT( ONE+S / T ) ) ) )
         ELSE
            S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
         END IF
         T = Z( NN-7 ) + ( S+Z( NN-5 ) )
         Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
         Z( NN-7 ) = T
      END IF
      Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
      Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
      N0 = N0 - 2
      GO TO 10
!
   50 CONTINUE
!
!     Reverse the qd-array, if warranted.
!
      IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
         IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
            IPN4 = 4*( I0+N0 )
            DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
               TEMP = Z( J4-3 )
               Z( J4-3 ) = Z( IPN4-J4-3 )
               Z( IPN4-J4-3 ) = TEMP
               TEMP = Z( J4-2 )
               Z( J4-2 ) = Z( IPN4-J4-2 )
               Z( IPN4-J4-2 ) = TEMP
               TEMP = Z( J4-1 )
               Z( J4-1 ) = Z( IPN4-J4-5 )
               Z( IPN4-J4-5 ) = TEMP
               TEMP = Z( J4 )
               Z( J4 ) = Z( IPN4-J4-4 )
               Z( IPN4-J4-4 ) = TEMP
   60       CONTINUE
            IF( N0-I0.LE.4 ) THEN
               Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
               Z( 4*N0-PP ) = Z( 4*I0-PP )
            END IF
            DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
            Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), &
                                  Z( 4*I0+PP+3 ) )
            Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), &
                                Z( 4*I0-PP+4 ) )
            QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
            DMIN = -ZERO
         END IF
      END IF
!
   70 CONTINUE
!
      IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), &
          Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
!
!        Choose a shift.
!
         CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, &
                      DN2, TAU, TTYPE )
!
!        Call dqds until DMIN > 0.
!
   80    CONTINUE
!
         CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, &
                      DN1, DN2, IEEE )
!
         NDIV = NDIV + ( N0-I0+2 )
         ITER = ITER + 1
!
!        Check status.
!
         IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
!
!           Success.
!
            GO TO 100
!
         ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. &
                  Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. &
                  ABS( DN ).LT.TOL*SIGMA ) THEN
!
!           Convergence hidden by negative DN.
!
            Z( 4*( N0-1 )-PP+2 ) = ZERO
            DMIN = ZERO
            GO TO 100
         ELSE IF( DMIN.LT.ZERO ) THEN
!
!           TAU too big. Select new TAU and try again.
!
            NFAIL = NFAIL + 1
            IF( TTYPE.LT.-22 ) THEN
!
!              Failed twice. Play it safe.
!
               TAU = ZERO
            ELSE IF( DMIN1.GT.ZERO ) THEN
!
!              Late failure. Gives excellent shift.
!
               TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
               TTYPE = TTYPE - 11
            ELSE
!
!              Early failure. Divide by 4.
!
               TAU = QURTR*TAU
               TTYPE = TTYPE - 12
            END IF
            GO TO 80
         ELSE IF( DMIN.NE.DMIN ) THEN
!
!           NaN.
!
            TAU = ZERO
            GO TO 80
         ELSE
!
!           Possible underflow. Play it safe.
!
            GO TO 90
         END IF
      END IF
!
!     Risk of underflow.
!
   90 CONTINUE
      CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
      NDIV = NDIV + ( N0-I0+2 )
      ITER = ITER + 1
      TAU = ZERO
!
  100 CONTINUE
      IF( TAU.LT.SIGMA ) THEN
         DESIG = DESIG + TAU
         T = SIGMA + DESIG
         DESIG = DESIG - ( T-SIGMA )
      ELSE
         T = SIGMA + TAU
         DESIG = SIGMA - ( T-TAU ) + DESIG
      END IF
      SIGMA = T
!
      RETURN
!
!     End of DLASQ3
!
      END
      SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, &
                         DN1, DN2, TAU, TTYPE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            I0, N0, N0IN, PP, TTYPE
      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ4 computes an approximation TAU to the smallest eigenvalue
!  using values of d from the previous transform.
!
!  I0    (input) INTEGER
!        First index.
!
!  N0    (input) INTEGER
!        Last index.
!
!  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
!        Z holds the qd array.
!
!  PP    (input) INTEGER
!        PP=0 for ping, PP=1 for pong.
!
!  NOIN  (input) INTEGER
!        The value of N0 at start of EIGTEST.
!
!  DMIN  (input) DOUBLE PRECISION
!        Minimum value of d.
!
!  DMIN1 (input) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ).
!
!  DMIN2 (input) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!
!  DN    (input) DOUBLE PRECISION
!        d(N)
!
!  DN1   (input) DOUBLE PRECISION
!        d(N-1)
!
!  DN2   (input) DOUBLE PRECISION
!        d(N-2)
!
!  TAU   (output) DOUBLE PRECISION
!        This is the shift.
!
!  TTYPE (output) INTEGER
!        Shift type.
!
!  Further Details
!  ===============
!  CNST1 = 9/16
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   CNST1, CNST2, CNST3
      PARAMETER          ( CNST1 = 0.5630D0, CNST2 = 1.010D0, &
                         CNST3 = 1.050D0 )
      DOUBLE PRECISION   QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
      PARAMETER          ( QURTR = 0.250D0, THIRD = 0.3330D0, &
                         HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, &
                         TWO = 2.0D0, HUNDRD = 100.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I4, NN, NP
      DOUBLE PRECISION   A2, B1, B2, G, GAM, GAP1, GAP2, S
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Save statement ..
      SAVE               G
!     ..
!     .. Data statement ..
      DATA               G / ZERO /
!     ..
!     .. Executable Statements ..
!
!     A negative DMIN forces the shift to take that absolute value
!     TTYPE records the type of shift.
!
      IF( DMIN.LE.ZERO ) THEN
         TAU = -DMIN
         TTYPE = -1
         RETURN
      END IF
!
      NN = 4*N0 + PP
      IF( N0IN.EQ.N0 ) THEN
!
!        No eigenvalues deflated.
!
         IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
!
            B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
            B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
            A2 = Z( NN-7 ) + Z( NN-5 )
!
!           Cases 2 and 3.
!
            IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
               GAP2 = DMIN2 - A2 - DMIN2*QURTR
               IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
                  GAP1 = A2 - DN - ( B2 / GAP2 )*B2
               ELSE
                  GAP1 = A2 - DN - ( B1+B2 )
               END IF
               IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
                  S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
                  TTYPE = -2
               ELSE
                  S = ZERO
                  IF( DN.GT.B1 ) &
                     S = DN - B1
                  IF( A2.GT.( B1+B2 ) ) &
                     S = MIN( S, A2-( B1+B2 ) )
                  S = MAX( S, THIRD*DMIN )
                  TTYPE = -3
               END IF
            ELSE
!
!              Case 4.
!
               TTYPE = -4
               S = QURTR*DMIN
               IF( DMIN.EQ.DN ) THEN
                  GAM = DN
                  A2 = ZERO
                  IF( Z( NN-5 ) .GT. Z( NN-7 ) ) &
                     RETURN
                  B2 = Z( NN-5 ) / Z( NN-7 )
                  NP = NN - 9
               ELSE
                  NP = NN - 2*PP
                  B2 = Z( NP-2 )
                  GAM = DN1
                  IF( Z( NP-4 ) .GT. Z( NP-2 ) ) &
                     RETURN
                  A2 = Z( NP-4 ) / Z( NP-2 )
                  IF( Z( NN-9 ) .GT. Z( NN-11 ) ) &
                     RETURN
                  B2 = Z( NN-9 ) / Z( NN-11 )
                  NP = NN - 13
               END IF
!
!              Approximate contribution to norm squared from I < NN-1.
!
               A2 = A2 + B2
               DO 10 I4 = NP, 4*I0 - 1 + PP, -4
                  IF( B2.EQ.ZERO ) &
                     GO TO 20
                  B1 = B2
                  IF( Z( I4 ) .GT. Z( I4-2 ) ) &
                     RETURN
                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
                  A2 = A2 + B2
                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) &
                     GO TO 20
   10          CONTINUE
   20          CONTINUE
               A2 = CNST3*A2
!
!              Rayleigh quotient residual bound.
!
               IF( A2.LT.CNST1 ) &
                  S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
            END IF
         ELSE IF( DMIN.EQ.DN2 ) THEN
!
!           Case 5.
!
            TTYPE = -5
            S = QURTR*DMIN
!
!           Compute contribution to norm squared from I > NN-2.
!
            NP = NN - 2*PP
            B1 = Z( NP-2 )
            B2 = Z( NP-6 )
            GAM = DN2
            IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) &
               RETURN
            A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
!
!           Approximate contribution to norm squared from I < NN-2.
!
            IF( N0-I0.GT.2 ) THEN
               B2 = Z( NN-13 ) / Z( NN-15 )
               A2 = A2 + B2
               DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
                  IF( B2.EQ.ZERO ) &
                     GO TO 40
                  B1 = B2
                  IF( Z( I4 ) .GT. Z( I4-2 ) ) &
                     RETURN
                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
                  A2 = A2 + B2
                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) &
                     GO TO 40
   30          CONTINUE
   40          CONTINUE
               A2 = CNST3*A2
            END IF
!
            IF( A2.LT.CNST1 ) &
               S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
         ELSE
!
!           Case 6, no information to guide us.
!
            IF( TTYPE.EQ.-6 ) THEN
               G = G + THIRD*( ONE-G )
            ELSE IF( TTYPE.EQ.-18 ) THEN
               G = QURTR*THIRD
            ELSE
               G = QURTR
            END IF
            S = G*DMIN
            TTYPE = -6
         END IF
!
      ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
!
!        One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
!
         IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
!
!           Cases 7 and 8.
!
            TTYPE = -7
            S = THIRD*DMIN1
            IF( Z( NN-5 ).GT.Z( NN-7 ) ) &
               RETURN
            B1 = Z( NN-5 ) / Z( NN-7 )
            B2 = B1
            IF( B2.EQ.ZERO ) &
               GO TO 60
            DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
               A2 = B1
               IF( Z( I4 ).GT.Z( I4-2 ) ) &
                  RETURN
               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
               B2 = B2 + B1
               IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) &
                  GO TO 60
   50       CONTINUE
   60       CONTINUE
            B2 = SQRT( CNST3*B2 )
            A2 = DMIN1 / ( ONE+B2**2 )
            GAP2 = HALF*DMIN2 - A2
            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
            ELSE
               S = MAX( S, A2*( ONE-CNST2*B2 ) )
               TTYPE = -8
            END IF
         ELSE
!
!           Case 9.
!
            S = QURTR*DMIN1
            IF( DMIN1.EQ.DN1 ) &
               S = HALF*DMIN1
            TTYPE = -9
         END IF
!
      ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
!
!        Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
!
!        Cases 10 and 11.
!
         IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
            TTYPE = -10
            S = THIRD*DMIN2
            IF( Z( NN-5 ).GT.Z( NN-7 ) ) &
               RETURN
            B1 = Z( NN-5 ) / Z( NN-7 )
            B2 = B1
            IF( B2.EQ.ZERO ) &
               GO TO 80
            DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
               IF( Z( I4 ).GT.Z( I4-2 ) ) &
                  RETURN
               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
               B2 = B2 + B1
               IF( HUNDRD*B1.LT.B2 ) &
                  GO TO 80
   70       CONTINUE
   80       CONTINUE
            B2 = SQRT( CNST3*B2 )
            A2 = DMIN2 / ( ONE+B2**2 )
            GAP2 = Z( NN-7 ) + Z( NN-9 ) - &
                   SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
            ELSE
               S = MAX( S, A2*( ONE-CNST2*B2 ) )
            END IF
         ELSE
            S = QURTR*DMIN2
            TTYPE = -11
         END IF
      ELSE IF( N0IN.GT.( N0+2 ) ) THEN
!
!        Case 12, more than two eigenvalues deflated. No information.
!
         S = ZERO
         TTYPE = -12
      END IF
!
      TAU = S
      RETURN
!
!     End of DLASQ4
!
      END
      SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, &
                         DNM1, DNM2, IEEE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     May 17, 2000
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            I0, N0, PP
      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ5 computes one dqds transform in ping-pong form, one
!  version for IEEE machines another for non IEEE machines.
!
!  Arguments
!  =========
!
!  I0    (input) INTEGER
!        First index.
!
!  N0    (input) INTEGER
!        Last index.
!
!  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
!        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!        an extra argument.
!
!  PP    (input) INTEGER
!        PP=0 for ping, PP=1 for pong.
!
!  TAU   (input) DOUBLE PRECISION
!        This is the shift.
!
!  DMIN  (output) DOUBLE PRECISION
!        Minimum value of d.
!
!  DMIN1 (output) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ).
!
!  DMIN2 (output) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!
!  DN    (output) DOUBLE PRECISION
!        d(N0), the last value of d.
!
!  DNM1  (output) DOUBLE PRECISION
!        d(N0-1).
!
!  DNM2  (output) DOUBLE PRECISION
!        d(N0-2).
!
!  IEEE  (input) LOGICAL
!        Flag for IEEE or non IEEE arithmetic.
!
!  =====================================================================
!
!     .. Parameter ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J4, J4P2
      DOUBLE PRECISION   D, EMIN, TEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
      IF( ( N0-I0-1 ).LE.0 ) &
         RETURN
!
      J4 = 4*I0 + PP - 3
      EMIN = Z( J4+4 )
      D = Z( J4 ) - TAU
      DMIN = D
      DMIN1 = -Z( J4 )
!
      IF( IEEE ) THEN
!
!        Code for IEEE arithmetic.
!
         IF( PP.EQ.0 ) THEN
            DO 10 J4 = 4*I0, 4*( N0-3 ), 4
               Z( J4-2 ) = D + Z( J4-1 )
               TEMP = Z( J4+1 ) / Z( J4-2 )
               D = D*TEMP - TAU
               DMIN = MIN( DMIN, D )
               Z( J4 ) = Z( J4-1 )*TEMP
               EMIN = MIN( Z( J4 ), EMIN )
   10       CONTINUE
         ELSE
            DO 20 J4 = 4*I0, 4*( N0-3 ), 4
               Z( J4-3 ) = D + Z( J4 )
               TEMP = Z( J4+2 ) / Z( J4-3 )
               D = D*TEMP - TAU
               DMIN = MIN( DMIN, D )
               Z( J4-1 ) = Z( J4 )*TEMP
               EMIN = MIN( Z( J4-1 ), EMIN )
   20       CONTINUE
         END IF
!
!        Unroll last two steps.
!
         DNM2 = D
         DMIN2 = DMIN
         J4 = 4*( N0-2 ) - PP
         J4P2 = J4 + 2*PP - 1
         Z( J4-2 ) = DNM2 + Z( J4P2 )
         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
         DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
         DMIN = MIN( DMIN, DNM1 )
!
         DMIN1 = DMIN
         J4 = J4 + 4
         J4P2 = J4 + 2*PP - 1
         Z( J4-2 ) = DNM1 + Z( J4P2 )
         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
         DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
         DMIN = MIN( DMIN, DN )
!
      ELSE
!
!        Code for non IEEE arithmetic.
!
         IF( PP.EQ.0 ) THEN
            DO 30 J4 = 4*I0, 4*( N0-3 ), 4
               Z( J4-2 ) = D + Z( J4-1 )
               IF( D.LT.ZERO ) THEN
                  RETURN
               ELSE
                  Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
                  D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
               END IF
               DMIN = MIN( DMIN, D )
               EMIN = MIN( EMIN, Z( J4 ) )
   30       CONTINUE
         ELSE
            DO 40 J4 = 4*I0, 4*( N0-3 ), 4
               Z( J4-3 ) = D + Z( J4 )
               IF( D.LT.ZERO ) THEN
                  RETURN
               ELSE
                  Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
                  D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
               END IF
               DMIN = MIN( DMIN, D )
               EMIN = MIN( EMIN, Z( J4-1 ) )
   40       CONTINUE
         END IF
!
!        Unroll last two steps.
!
         DNM2 = D
         DMIN2 = DMIN
         J4 = 4*( N0-2 ) - PP
         J4P2 = J4 + 2*PP - 1
         Z( J4-2 ) = DNM2 + Z( J4P2 )
         IF( DNM2.LT.ZERO ) THEN
            RETURN
         ELSE
            Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
            DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
         END IF
         DMIN = MIN( DMIN, DNM1 )
!
         DMIN1 = DMIN
         J4 = J4 + 4
         J4P2 = J4 + 2*PP - 1
         Z( J4-2 ) = DNM1 + Z( J4P2 )
         IF( DNM1.LT.ZERO ) THEN
            RETURN
         ELSE
            Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
            DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
         END IF
         DMIN = MIN( DMIN, DN )
!
      END IF
!
      Z( J4+2 ) = DN
      Z( 4*N0-PP ) = EMIN
      RETURN
!
!     End of DLASQ5
!
      END
      SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, &
                         DNM1, DNM2 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      INTEGER            I0, N0, PP
      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Z( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASQ6 computes one dqd (shift equal to zero) transform in
!  ping-pong form, with protection against underflow and overflow.
!
!  Arguments
!  =========
!
!  I0    (input) INTEGER
!        First index.
!
!  N0    (input) INTEGER
!        Last index.
!
!  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
!        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!        an extra argument.
!
!  PP    (input) INTEGER
!        PP=0 for ping, PP=1 for pong.
!
!  DMIN  (output) DOUBLE PRECISION
!        Minimum value of d.
!
!  DMIN1 (output) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ).
!
!  DMIN2 (output) DOUBLE PRECISION
!        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!
!  DN    (output) DOUBLE PRECISION
!        d(N0), the last value of d.
!
!  DNM1  (output) DOUBLE PRECISION
!        d(N0-1).
!
!  DNM2  (output) DOUBLE PRECISION
!        d(N0-2).
!
!  =====================================================================
!
!     .. Parameter ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J4, J4P2
      DOUBLE PRECISION   D, EMIN, SAFMIN, TEMP
!     ..
!     .. External Function ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
      IF( ( N0-I0-1 ).LE.0 ) &
         RETURN
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      J4 = 4*I0 + PP - 3
      EMIN = Z( J4+4 )
      D = Z( J4 )
      DMIN = D
!
      IF( PP.EQ.0 ) THEN
         DO 10 J4 = 4*I0, 4*( N0-3 ), 4
            Z( J4-2 ) = D + Z( J4-1 )
            IF( Z( J4-2 ).EQ.ZERO ) THEN
               Z( J4 ) = ZERO
               D = Z( J4+1 )
               DMIN = D
               EMIN = ZERO
            ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. &
                     SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
               TEMP = Z( J4+1 ) / Z( J4-2 )
               Z( J4 ) = Z( J4-1 )*TEMP
               D = D*TEMP
            ELSE
               Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
               D = Z( J4+1 )*( D / Z( J4-2 ) )
            END IF
            DMIN = MIN( DMIN, D )
            EMIN = MIN( EMIN, Z( J4 ) )
   10    CONTINUE
      ELSE
         DO 20 J4 = 4*I0, 4*( N0-3 ), 4
            Z( J4-3 ) = D + Z( J4 )
            IF( Z( J4-3 ).EQ.ZERO ) THEN
               Z( J4-1 ) = ZERO
               D = Z( J4+2 )
               DMIN = D
               EMIN = ZERO
            ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. &
                     SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
               TEMP = Z( J4+2 ) / Z( J4-3 )
               Z( J4-1 ) = Z( J4 )*TEMP
               D = D*TEMP
            ELSE
               Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
               D = Z( J4+2 )*( D / Z( J4-3 ) )
            END IF
            DMIN = MIN( DMIN, D )
            EMIN = MIN( EMIN, Z( J4-1 ) )
   20    CONTINUE
      END IF
!
!     Unroll last two steps.
!
      DNM2 = D
      DMIN2 = DMIN
      J4 = 4*( N0-2 ) - PP
      J4P2 = J4 + 2*PP - 1
      Z( J4-2 ) = DNM2 + Z( J4P2 )
      IF( Z( J4-2 ).EQ.ZERO ) THEN
         Z( J4 ) = ZERO
         DNM1 = Z( J4P2+2 )
         DMIN = DNM1
         EMIN = ZERO
      ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. &
               SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
         TEMP = Z( J4P2+2 ) / Z( J4-2 )
         Z( J4 ) = Z( J4P2 )*TEMP
         DNM1 = DNM2*TEMP
      ELSE
         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
         DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
      END IF
      DMIN = MIN( DMIN, DNM1 )
!
      DMIN1 = DMIN
      J4 = J4 + 4
      J4P2 = J4 + 2*PP - 1
      Z( J4-2 ) = DNM1 + Z( J4P2 )
      IF( Z( J4-2 ).EQ.ZERO ) THEN
         Z( J4 ) = ZERO
         DN = Z( J4P2+2 )
         DMIN = DN
         EMIN = ZERO
      ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. &
               SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
         TEMP = Z( J4P2+2 ) / Z( J4-2 )
         Z( J4 ) = Z( J4P2 )*TEMP
         DN = DNM1*TEMP
      ELSE
         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
         DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
      END IF
      DMIN = MIN( DMIN, DN )
!
      Z( J4+2 ) = DN
      Z( 4*N0-PP ) = EMIN
      RETURN
!
!     End of DLASQ6
!
      END
      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASR   performs the transformation
!
!     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
!
!     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
!
!  where A is an m by n real matrix and P is an orthogonal matrix,
!  consisting of a sequence of plane rotations determined by the
!  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
!  and z = n when SIDE = 'R' or 'r' ):
!
!  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
!
!     P = P( z - 1 )*...*P( 2 )*P( 1 ),
!
!  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
!
!     P = P( 1 )*P( 2 )*...*P( z - 1 ),
!
!  where  P( k ) is a plane rotation matrix for the following planes:
!
!     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
!        the plane ( k, k + 1 )
!
!     when  PIVOT = 'T' or 't'  ( Top pivot ),
!        the plane ( 1, k + 1 )
!
!     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
!        the plane ( k, z )
!
!  c( k ) and s( k )  must contain the  cosine and sine that define the
!  matrix  P( k ).  The two by two plane rotation part of the matrix
!  P( k ), R( k ), is assumed to be of the form
!
!     R( k ) = (  c( k )  s( k ) ).
!              ( -s( k )  c( k ) )
!
!  This version vectorises across rows of the array A when SIDE = 'L'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          Specifies whether the plane rotation matrix P is applied to
!          A on the left or the right.
!          = 'L':  Left, compute A := P*A
!          = 'R':  Right, compute A:= A*P'
!
!  DIRECT  (input) CHARACTER*1
!          Specifies whether P is a forward or backward sequence of
!          plane rotations.
!          = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
!          = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
!
!  PIVOT   (input) CHARACTER*1
!          Specifies the plane for which P(k) is a plane rotation
!          matrix.
!          = 'V':  Variable pivot, the plane (k,k+1)
!          = 'T':  Top pivot, the plane (1,k+1)
!          = 'B':  Bottom pivot, the plane (k,z)
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  If m <= 1, an immediate
!          return is effected.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  If n <= 1, an
!          immediate return is effected.
!
!  C, S    (input) DOUBLE PRECISION arrays, dimension
!                  (M-1) if SIDE = 'L'
!                  (N-1) if SIDE = 'R'
!          c(k) and s(k) contain the cosine and sine that define the
!          matrix P(k).  The two by two plane rotation part of the
!          matrix P(k), R(k), is assumed to be of the form
!          R( k ) = (  c( k )  s( k ) ).
!                   ( -s( k )  c( k ) )
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          The m by n matrix A.  On exit, A is overwritten by P*A if
!          SIDE = 'R' or by A*P' if SIDE = 'L'.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, INFO, J
      DOUBLE PRECISION   CTEMP, STEMP, TEMP
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
         INFO = 1
      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, &
               'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
         INFO = 2
      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) &
                THEN
         INFO = 3
      ELSE IF( M.LT.0 ) THEN
         INFO = 4
      ELSE IF( N.LT.0 ) THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASR ', INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) &
         RETURN
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        Form  P * A
!
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 20 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 10 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 40 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 30 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 60 J = 2, M
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 50 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 80 J = M, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 70 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 100 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 90 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 120 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 110 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!        Form A * P'
!
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 140 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 130 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 160 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 150 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 180 J = 2, N
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 170 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 200 J = N, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 190 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 220 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 210 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 240 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 230 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DLASR
!
      END
      SUBROUTINE DLASRT( ID, N, D, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * )
!     ..
!
!  Purpose
!  =======
!
!  Sort the numbers in D in increasing order (if ID = 'I') or
!  in decreasing order (if ID = 'D' ).
!
!  Use Quick Sort, reverting to Insertion sort on arrays of
!  size <= 20. Dimension of STACK limits N to about 2**32.
!
!  Arguments
!  =========
!
!  ID      (input) CHARACTER*1
!          = 'I': sort D in increasing order;
!          = 'D': sort D in decreasing order.
!
!  N       (input) INTEGER
!          The length of the array D.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the array to be sorted.
!          On exit, D has been sorted into increasing order
!          (D(1) <= ... <= D(N) ) or into decreasing order
!          (D(1) >= ... >= D(N) ), depending on ID.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            SELECT
      PARAMETER          ( SELECT = 20 )
!     ..
!     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
!     ..
!     .. Local Arrays ..
      INTEGER            STACK( 2, 32 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input paramters.
!
      INFO = 0
      DIR = -1
      IF( LSAME( ID, 'D' ) ) THEN
         DIR = 0
      ELSE IF( LSAME( ID, 'I' ) ) THEN
         DIR = 1
      END IF
      IF( DIR.EQ.-1 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASRT', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.1 ) &
         RETURN
!
      STKPNT = 1
      STACK( 1, 1 ) = 1
      STACK( 2, 1 ) = N
   10 CONTINUE
      START = STACK( 1, STKPNT )
      ENDD = STACK( 2, STKPNT )
      STKPNT = STKPNT - 1
      IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
!
!        Do Insertion sort on D( START:ENDD )
!
         IF( DIR.EQ.0 ) THEN
!
!           Sort into decreasing order
!
            DO 30 I = START + 1, ENDD
               DO 20 J = I, START + 1, -1
                  IF( D( J ).GT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 30
                  END IF
   20          CONTINUE
   30       CONTINUE
!
         ELSE
!
!           Sort into increasing order
!
            DO 50 I = START + 1, ENDD
               DO 40 J = I, START + 1, -1
                  IF( D( J ).LT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 50
                  END IF
   40          CONTINUE
   50       CONTINUE
!
         END IF
!
      ELSE IF( ENDD-START.GT.SELECT ) THEN
!
!        Partition D( START:ENDD ) and stack parts, largest one first
!
!        Choose partition entry as median of 3
!
         D1 = D( START )
         D2 = D( ENDD )
         I = ( START+ENDD ) / 2
         D3 = D( I )
         IF( D1.LT.D2 ) THEN
            IF( D3.LT.D1 ) THEN
               DMNMX = D1
            ELSE IF( D3.LT.D2 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D2
            END IF
         ELSE
            IF( D3.LT.D2 ) THEN
               DMNMX = D2
            ELSE IF( D3.LT.D1 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D1
            END IF
         END IF
!
         IF( DIR.EQ.0 ) THEN
!
!           Sort into decreasing order
!
            I = START - 1
            J = ENDD + 1
   60       CONTINUE
   70       CONTINUE
            J = J - 1
            IF( D( J ).LT.DMNMX ) &
               GO TO 70
   80       CONTINUE
            I = I + 1
            IF( D( I ).GT.DMNMX ) &
               GO TO 80
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 60
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         ELSE
!
!           Sort into increasing order
!
            I = START - 1
            J = ENDD + 1
   90       CONTINUE
  100       CONTINUE
            J = J - 1
            IF( D( J ).GT.DMNMX ) &
               GO TO 100
  110       CONTINUE
            I = I + 1
            IF( D( I ).LT.DMNMX ) &
               GO TO 110
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 90
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         END IF
      END IF
      IF( STKPNT.GT.0 ) &
         GO TO 10
      RETURN
!
!     End of DLASRT
!
      END
      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SCALE, SUMSQ
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLASSQ  returns the values  scl  and  smsq  such that
!
!     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!
!  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!  assumed to be non-negative and  scl  returns the value
!
!     scl = max( scale, abs( x( i ) ) ).
!
!  scale and sumsq must be supplied in SCALE and SUMSQ and
!  scl and smsq are overwritten on SCALE and SUMSQ respectively.
!
!  The routine makes only one pass through the vector x.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements to be used from the vector X.
!
!  X       (input) DOUBLE PRECISION array, dimension (N)
!          The vector for which a scaled sum of squares is computed.
!             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!
!  INCX    (input) INTEGER
!          The increment between successive values of the vector X.
!          INCX > 0.
!
!  SCALE   (input/output) DOUBLE PRECISION
!          On entry, the value  scale  in the equation above.
!          On exit, SCALE is overwritten with  scl , the scaling factor
!          for the sum of squares.
!
!  SUMSQ   (input/output) DOUBLE PRECISION
!          On entry, the value  sumsq  in the equation above.
!          On exit, SUMSQ is overwritten with  smsq , the basic sum of
!          squares from which  scl  has been factored out.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            IX
      DOUBLE PRECISION   ABSXI
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      IF( N.GT.0 ) THEN
         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
            IF( X( IX ).NE.ZERO ) THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
!
!     End of DLASSQ
!
      END
      SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
!     ..
!
!  Purpose
!  =======
!
!  DLASV2 computes the singular value decomposition of a 2-by-2
!  triangular matrix
!     [  F   G  ]
!     [  0   H  ].
!  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
!  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
!  right singular vectors for abs(SSMAX), giving the decomposition
!
!     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
!     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
!
!  Arguments
!  =========
!
!  F       (input) DOUBLE PRECISION
!          The (1,1) element of the 2-by-2 matrix.
!
!  G       (input) DOUBLE PRECISION
!          The (1,2) element of the 2-by-2 matrix.
!
!  H       (input) DOUBLE PRECISION
!          The (2,2) element of the 2-by-2 matrix.
!
!  SSMIN   (output) DOUBLE PRECISION
!          abs(SSMIN) is the smaller singular value.
!
!  SSMAX   (output) DOUBLE PRECISION
!          abs(SSMAX) is the larger singular value.
!
!  SNL     (output) DOUBLE PRECISION
!  CSL     (output) DOUBLE PRECISION
!          The vector (CSL, SNL) is a unit left singular vector for the
!          singular value abs(SSMAX).
!
!  SNR     (output) DOUBLE PRECISION
!  CSR     (output) DOUBLE PRECISION
!          The vector (CSR, SNR) is a unit right singular vector for the
!          singular value abs(SSMAX).
!
!  Further Details
!  ===============
!
!  Any input parameter may be aliased with any output parameter.
!
!  Barring over/underflow and assuming a guard digit in subtraction, all
!  output quantities are correct to within a few units in the last
!  place (ulps).
!
!  In IEEE arithmetic, the code works correctly if one matrix element is
!  infinite.
!
!  Overflow will not occur unless the largest singular value itself
!  overflows or is within a few ulps of overflow. (On machines with
!  partial overflow, like the Cray, overflow may occur if the largest
!  singular value is within a factor of 2 of overflow.)
!
!  Underflow is harmless if underflow is gradual. Otherwise, results
!  may correspond to a matrix modified by perturbations of size near
!  the underflow threshold.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
      DOUBLE PRECISION   FOUR
      PARAMETER          ( FOUR = 4.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            GASMAL, SWAP
      INTEGER            PMAX
      DOUBLE PRECISION   A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, &
                         MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Executable Statements ..
!
      FT = F
      FA = ABS( FT )
      HT = H
      HA = ABS( H )
!
!     PMAX points to the maximum absolute element of matrix
!       PMAX = 1 if F largest in absolute values
!       PMAX = 2 if G largest in absolute values
!       PMAX = 3 if H largest in absolute values
!
      PMAX = 1
      SWAP = ( HA.GT.FA )
      IF( SWAP ) THEN
         PMAX = 3
         TEMP = FT
         FT = HT
         HT = TEMP
         TEMP = FA
         FA = HA
         HA = TEMP
!
!        Now FA .ge. HA
!
      END IF
      GT = G
      GA = ABS( GT )
      IF( GA.EQ.ZERO ) THEN
!
!        Diagonal matrix
!
         SSMIN = HA
         SSMAX = FA
         CLT = ONE
         CRT = ONE
         SLT = ZERO
         SRT = ZERO
      ELSE
         GASMAL = .TRUE.
         IF( GA.GT.FA ) THEN
            PMAX = 2
            IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
!
!              Case of very large GA
!
               GASMAL = .FALSE.
               SSMAX = GA
               IF( HA.GT.ONE ) THEN
                  SSMIN = FA / ( GA / HA )
               ELSE
                  SSMIN = ( FA / GA )*HA
               END IF
               CLT = ONE
               SLT = HT / GT
               SRT = ONE
               CRT = FT / GT
            END IF
         END IF
         IF( GASMAL ) THEN
!
!           Normal case
!
            D = FA - HA
            IF( D.EQ.FA ) THEN
!
!              Copes with infinite F or H
!
               L = ONE
            ELSE
               L = D / FA
            END IF
!
!           Note that 0 .le. L .le. 1
!
            M = GT / FT
!
!           Note that abs(M) .le. 1/macheps
!
            T = TWO - L
!
!           Note that T .ge. 1
!
            MM = M*M
            TT = T*T
            S = SQRT( TT+MM )
!
!           Note that 1 .le. S .le. 1 + 1/macheps
!
            IF( L.EQ.ZERO ) THEN
               R = ABS( M )
            ELSE
               R = SQRT( L*L+MM )
            END IF
!
!           Note that 0 .le. R .le. 1 + 1/macheps
!
            A = HALF*( S+R )
!
!           Note that 1 .le. A .le. 1 + abs(M)
!
            SSMIN = HA / A
            SSMAX = FA*A
            IF( MM.EQ.ZERO ) THEN
!
!              Note that M is very tiny
!
               IF( L.EQ.ZERO ) THEN
                  T = SIGN( TWO, FT )*SIGN( ONE, GT )
               ELSE
                  T = GT / SIGN( D, FT ) + M / T
               END IF
            ELSE
               T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
            END IF
            L = SQRT( T*T+FOUR )
            CRT = TWO / L
            SRT = T / L
            CLT = ( CRT+SRT*M ) / A
            SLT = ( HT / FT )*SRT / A
         END IF
      END IF
      IF( SWAP ) THEN
         CSL = SRT
         SNL = CRT
         CSR = SLT
         SNR = CLT
      ELSE
         CSL = CLT
         SNL = SLT
         CSR = CRT
         SNR = SRT
      END IF
!
!     Correct signs of SSMAX and SSMIN
!
      IF( PMAX.EQ.1 ) &
         TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
      IF( PMAX.EQ.2 ) &
         TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
      IF( PMAX.EQ.3 ) &
         TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
      SSMAX = SIGN( SSMAX, TSIGN )
      SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
      RETURN
!
!     End of DLASV2
!
      END
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in positions
!          K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
!  Further Details
!  ===============
!
!  Modified by
!   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of DLASWP
!
      END
      SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, &
                         LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            LTRANL, LTRANR
      INTEGER            INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
      DOUBLE PRECISION   SCALE, XNORM
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
!
!         op(TL)*X + ISGN*X*op(TR) = SCALE*B,
!
!  where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
!  -1.  op(T) = T or T', where T' denotes the transpose of T.
!
!  Arguments
!  =========
!
!  LTRANL  (input) LOGICAL
!          On entry, LTRANL specifies the op(TL):
!             = .FALSE., op(TL) = TL,
!             = .TRUE., op(TL) = TL'.
!
!  LTRANR  (input) LOGICAL
!          On entry, LTRANR specifies the op(TR):
!            = .FALSE., op(TR) = TR,
!            = .TRUE., op(TR) = TR'.
!
!  ISGN    (input) INTEGER
!          On entry, ISGN specifies the sign of the equation
!          as described before. ISGN may only be 1 or -1.
!
!  N1      (input) INTEGER
!          On entry, N1 specifies the order of matrix TL.
!          N1 may only be 0, 1 or 2.
!
!  N2      (input) INTEGER
!          On entry, N2 specifies the order of matrix TR.
!          N2 may only be 0, 1 or 2.
!
!  TL      (input) DOUBLE PRECISION array, dimension (LDTL,2)
!          On entry, TL contains an N1 by N1 matrix.
!
!  LDTL    (input) INTEGER
!          The leading dimension of the matrix TL. LDTL >= max(1,N1).
!
!  TR      (input) DOUBLE PRECISION array, dimension (LDTR,2)
!          On entry, TR contains an N2 by N2 matrix.
!
!  LDTR    (input) INTEGER
!          The leading dimension of the matrix TR. LDTR >= max(1,N2).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
!          On entry, the N1 by N2 matrix B contains the right-hand
!          side of the equation.
!
!  LDB     (input) INTEGER
!          The leading dimension of the matrix B. LDB >= max(1,N1).
!
!  SCALE   (output) DOUBLE PRECISION
!          On exit, SCALE contains the scale factor. SCALE is chosen
!          less than or equal to 1 to prevent the solution overflowing.
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,2)
!          On exit, X contains the N1 by N2 solution.
!
!  LDX     (input) INTEGER
!          The leading dimension of the matrix X. LDX >= max(1,N1).
!
!  XNORM   (output) DOUBLE PRECISION
!          On exit, XNORM is the infinity-norm of the solution.
!
!  INFO    (output) INTEGER
!          On exit, INFO is set to
!             0: successful exit.
!             1: TL and TR have too close eigenvalues, so TL or
!                TR is perturbed to get a nonsingular equation.
!          NOTE: In the interests of speed, this routine does not
!                check the inputs for errors.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO, HALF, EIGHT
      PARAMETER          ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            BSWAP, XSWAP
      INTEGER            I, IP, IPIV, IPSV, J, JP, JPSV, K
      DOUBLE PRECISION   BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, &
                         TEMP, U11, U12, U22, XMAX
!     ..
!     .. Local Arrays ..
      LOGICAL            BSWPIV( 4 ), XSWPIV( 4 )
      INTEGER            JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), &
                         LOCU22( 4 )
      DOUBLE PRECISION   BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Data statements ..
      DATA               LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , &
                         LOCU22 / 4, 3, 2, 1 /
      DATA               XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
      DATA               BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
!     ..
!     .. Executable Statements ..
!
!     Do not check the input parameters for errors
!
      INFO = 0
!
!     Quick return if possible
!
      IF( N1.EQ.0 .OR. N2.EQ.0 ) &
         RETURN
!
!     Set constants to control overflow
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      SGN = ISGN
!
      K = N1 + N1 + N2 - 2
      GO TO ( 10, 20, 30, 50 )K
!
!     1 by 1: TL11*X + SGN*X*TR11 = B11
!
   10 CONTINUE
      TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
      BET = ABS( TAU1 )
      IF( BET.LE.SMLNUM ) THEN
         TAU1 = SMLNUM
         BET = SMLNUM
         INFO = 1
      END IF
!
      SCALE = ONE
      GAM = ABS( B( 1, 1 ) )
      IF( SMLNUM*GAM.GT.BET ) &
         SCALE = ONE / GAM
!
      X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
      XNORM = ABS( X( 1, 1 ) )
      RETURN
!
!     1 by 2:
!     TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12]  = [B11 B12]
!                                       [TR21 TR22]
!
   20 CONTINUE
!
      SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), &
             ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), &
             SMLNUM )
      TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
      TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
      IF( LTRANR ) THEN
         TMP( 2 ) = SGN*TR( 2, 1 )
         TMP( 3 ) = SGN*TR( 1, 2 )
      ELSE
         TMP( 2 ) = SGN*TR( 1, 2 )
         TMP( 3 ) = SGN*TR( 2, 1 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 1, 2 )
      GO TO 40
!
!     2 by 1:
!          op[TL11 TL12]*[X11] + ISGN* [X11]*TR11  = [B11]
!            [TL21 TL22] [X21]         [X21]         [B21]
!
   30 CONTINUE
      SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), &
             ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), &
             SMLNUM )
      TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
      TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
      IF( LTRANL ) THEN
         TMP( 2 ) = TL( 1, 2 )
         TMP( 3 ) = TL( 2, 1 )
      ELSE
         TMP( 2 ) = TL( 2, 1 )
         TMP( 3 ) = TL( 1, 2 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 2, 1 )
   40 CONTINUE
!
!     Solve 2 by 2 system using complete pivoting.
!     Set pivots less than SMIN to SMIN.
!
      IPIV = IDAMAX( 4, TMP, 1 )
      U11 = TMP( IPIV )
      IF( ABS( U11 ).LE.SMIN ) THEN
         INFO = 1
         U11 = SMIN
      END IF
      U12 = TMP( LOCU12( IPIV ) )
      L21 = TMP( LOCL21( IPIV ) ) / U11
      U22 = TMP( LOCU22( IPIV ) ) - U12*L21
      XSWAP = XSWPIV( IPIV )
      BSWAP = BSWPIV( IPIV )
      IF( ABS( U22 ).LE.SMIN ) THEN
         INFO = 1
         U22 = SMIN
      END IF
      IF( BSWAP ) THEN
         TEMP = BTMP( 2 )
         BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
         BTMP( 1 ) = TEMP
      ELSE
         BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
      END IF
      SCALE = ONE
      IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. &
          ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
         SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
         BTMP( 1 ) = BTMP( 1 )*SCALE
         BTMP( 2 ) = BTMP( 2 )*SCALE
      END IF
      X2( 2 ) = BTMP( 2 ) / U22
      X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
      IF( XSWAP ) THEN
         TEMP = X2( 2 )
         X2( 2 ) = X2( 1 )
         X2( 1 ) = TEMP
      END IF
      X( 1, 1 ) = X2( 1 )
      IF( N1.EQ.1 ) THEN
         X( 1, 2 ) = X2( 2 )
         XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
      ELSE
         X( 2, 1 ) = X2( 2 )
         XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
      END IF
      RETURN
!
!     2 by 2:
!     op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
!       [TL21 TL22] [X21 X22]        [X21 X22]   [TR21 TR22]   [B21 B22]
!
!     Solve equivalent 4 by 4 system using complete pivoting.
!     Set pivots less than SMIN to SMIN.
!
   50 CONTINUE
      SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), &
             ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
      SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), &
             ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
      SMIN = MAX( EPS*SMIN, SMLNUM )
      BTMP( 1 ) = ZERO
      CALL DCOPY( 16, BTMP, 0, T16, 1 )
      T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
      T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
      T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
      T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
      IF( LTRANL ) THEN
         T16( 1, 2 ) = TL( 2, 1 )
         T16( 2, 1 ) = TL( 1, 2 )
         T16( 3, 4 ) = TL( 2, 1 )
         T16( 4, 3 ) = TL( 1, 2 )
      ELSE
         T16( 1, 2 ) = TL( 1, 2 )
         T16( 2, 1 ) = TL( 2, 1 )
         T16( 3, 4 ) = TL( 1, 2 )
         T16( 4, 3 ) = TL( 2, 1 )
      END IF
      IF( LTRANR ) THEN
         T16( 1, 3 ) = SGN*TR( 1, 2 )
         T16( 2, 4 ) = SGN*TR( 1, 2 )
         T16( 3, 1 ) = SGN*TR( 2, 1 )
         T16( 4, 2 ) = SGN*TR( 2, 1 )
      ELSE
         T16( 1, 3 ) = SGN*TR( 2, 1 )
         T16( 2, 4 ) = SGN*TR( 2, 1 )
         T16( 3, 1 ) = SGN*TR( 1, 2 )
         T16( 4, 2 ) = SGN*TR( 1, 2 )
      END IF
      BTMP( 1 ) = B( 1, 1 )
      BTMP( 2 ) = B( 2, 1 )
      BTMP( 3 ) = B( 1, 2 )
      BTMP( 4 ) = B( 2, 2 )
!
!     Perform elimination
!
      DO 100 I = 1, 3
         XMAX = ZERO
         DO 70 IP = I, 4
            DO 60 JP = I, 4
               IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
                  XMAX = ABS( T16( IP, JP ) )
                  IPSV = IP
                  JPSV = JP
               END IF
   60       CONTINUE
   70    CONTINUE
         IF( IPSV.NE.I ) THEN
            CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
            TEMP = BTMP( I )
            BTMP( I ) = BTMP( IPSV )
            BTMP( IPSV ) = TEMP
         END IF
         IF( JPSV.NE.I ) &
            CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
         JPIV( I ) = JPSV
         IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
            INFO = 1
            T16( I, I ) = SMIN
         END IF
         DO 90 J = I + 1, 4
            T16( J, I ) = T16( J, I ) / T16( I, I )
            BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
            DO 80 K = I + 1, 4
               T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      IF( ABS( T16( 4, 4 ) ).LT.SMIN ) &
         T16( 4, 4 ) = SMIN
      SCALE = ONE
      IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. &
          ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. &
          ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. &
          ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
         SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), &
                 ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
         BTMP( 1 ) = BTMP( 1 )*SCALE
         BTMP( 2 ) = BTMP( 2 )*SCALE
         BTMP( 3 ) = BTMP( 3 )*SCALE
         BTMP( 4 ) = BTMP( 4 )*SCALE
      END IF
      DO 120 I = 1, 4
         K = 5 - I
         TEMP = ONE / T16( K, K )
         TMP( K ) = BTMP( K )*TEMP
         DO 110 J = K + 1, 4
            TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
  110    CONTINUE
  120 CONTINUE
      DO 130 I = 1, 3
         IF( JPIV( 4-I ).NE.4-I ) THEN
            TEMP = TMP( 4-I )
            TMP( 4-I ) = TMP( JPIV( 4-I ) )
            TMP( JPIV( 4-I ) ) = TEMP
         END IF
  130 CONTINUE
      X( 1, 1 ) = TMP( 1 )
      X( 2, 1 ) = TMP( 2 )
      X( 1, 2 ) = TMP( 3 )
      X( 2, 2 ) = TMP( 4 )
      XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), &
              ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
      RETURN
!
!     End of DLASY2
!
      END
      SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KB, LDA, LDW, N, NB
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), W( LDW, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASYF computes a partial factorization of a real symmetric matrix A
!  using the Bunch-Kaufman diagonal pivoting method. The partial
!  factorization has the form:
!
!  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:
!        ( 0  U22 ) (  0   D  ) ( U12' U22' )
!
!  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'
!        ( L21  I ) (  0  A22 ) (  0    I   )
!
!  where the order of D is at most NB. The actual order is returned in
!  the argument KB, and is either NB or NB-1, or N if N <= NB.
!
!  DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
!  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
!  A22 (if UPLO = 'L').
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NB      (input) INTEGER
!          The maximum number of columns of the matrix A that should be
!          factored.  NB should be at least 2 to allow for 2-by-2 pivot
!          blocks.
!
!  KB      (output) INTEGER
!          The number of columns of A that were actually factored.
!          KB is either NB-1 or NB, or N if N <= NB.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n-by-n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n-by-n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!          On exit, A contains details of the partial factorization.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D.
!          If UPLO = 'U', only the last KB elements of IPIV are set;
!          if UPLO = 'L', only the first KB elements are set.
!
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!  W       (workspace) DOUBLE PRECISION array, dimension (LDW,NB)
!
!  LDW     (input) INTEGER
!          The leading dimension of the array W.  LDW >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!               has been completed, but the block diagonal matrix D is
!               exactly singular.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   EIGHT, SEVTEN
      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, &
                         KSTEP, KW
      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, &
                         ROWMAX, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      EXTERNAL           LSAME, IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
!     Initialize ALPHA for use in choosing pivot block size.
!
      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
!
      IF( LSAME( UPLO, 'U' ) ) THEN
!
!        Factorize the trailing columns of A using the upper triangle
!        of A and working backwards, and compute the matrix W = U12*D
!        for use in updating A11
!
!        K is the main loop index, decreasing from N in steps of 1 or 2
!
!        KW is the column of W which corresponds to column K of A
!
         K = N
   10    CONTINUE
         KW = NB + K - N
!
!        Exit from loop
!
         IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) &
            GO TO 30
!
!        Copy column K of A to column KW of W and update it
!
         CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
         IF( K.LT.N ) &
            CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, &
                        W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
!
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( W( K, KW ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.GT.1 ) THEN
            IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
            COLMAX = ABS( W( IMAX, KW ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              Copy column IMAX to column KW-1 of W and update it
!
               CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
               CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, &
                           W( IMAX+1, KW-1 ), 1 )
               IF( K.LT.N ) &
                  CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), &
                              LDA, W( IMAX, KW+1 ), LDW, ONE, &
                              W( 1, KW-1 ), 1 )
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
               ROWMAX = ABS( W( JMAX, KW-1 ) )
               IF( IMAX.GT.1 ) THEN
                  JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
!
!                 copy column KW-1 of W to column KW
!
                  CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
               ELSE
!
!                 interchange rows and columns K-1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K - KSTEP + 1
            KKW = NB + KK - N
!
!           Updated column KP is already stored in column KKW of W
!
            IF( KP.NE.KK ) THEN
!
!              Copy non-updated column KK to column KP
!
               A( KP, K ) = A( KK, K )
               CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), &
                           LDA )
               CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
!
!              Interchange rows KK and KP in last KK columns of A and W
!
               CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
               CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), &
                           LDW )
            END IF
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column KW of W now holds
!
!              W(k) = U(k)*D(k)
!
!              where U(k) is the k-th column of U
!
!              Store U(k) in column k of A
!
               CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
               R1 = ONE / A( K, K )
               CALL DSCAL( K-1, R1, A( 1, K ), 1 )
            ELSE
!
!              2-by-2 pivot block D(k): columns KW and KW-1 of W now
!              hold
!
!              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
!
!              where U(k) and U(k-1) are the k-th and (k-1)-th columns
!              of U
!
               IF( K.GT.2 ) THEN
!
!                 Store U(k) and U(k-1) in columns k and k-1 of A
!
                  D21 = W( K-1, KW )
                  D11 = W( K, KW ) / D21
                  D22 = W( K-1, KW-1 ) / D21
                  T = ONE / ( D11*D22-ONE )
                  D21 = T / D21
                  DO 20 J = 1, K - 2
                     A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
                     A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
   20             CONTINUE
               END IF
!
!              Copy D(k) to A
!
               A( K-1, K-1 ) = W( K-1, KW-1 )
               A( K-1, K ) = W( K-1, KW )
               A( K, K ) = W( K, KW )
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K-1 ) = -KP
         END IF
!
!        Decrease K and return to the start of the main loop
!
         K = K - KSTEP
         GO TO 10
!
   30    CONTINUE
!
!        Update the upper triangle of A11 (= A(1:k,1:k)) as
!
!        A11 := A11 - U12*D*U12' = A11 - U12*W'
!
!        computing blocks of NB columns at a time
!
         DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
            JB = MIN( NB, K-J+1 )
!
!           Update the upper triangle of the diagonal block
!
            DO 40 JJ = J, J + JB - 1
               CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, &
                           A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, &
                           A( J, JJ ), 1 )
   40       CONTINUE
!
!           Update the rectangular superdiagonal block
!
            CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, &
                        A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, &
                        A( 1, J ), LDA )
   50    CONTINUE
!
!        Put U12 in standard form by partially undoing the interchanges
!        in columns k+1:n
!
         J = K + 1
   60    CONTINUE
         JJ = J
         JP = IPIV( J )
         IF( JP.LT.0 ) THEN
            JP = -JP
            J = J + 1
         END IF
         J = J + 1
         IF( JP.NE.JJ .AND. J.LE.N ) &
            CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
         IF( J.LE.N ) &
            GO TO 60
!
!        Set KB to the number of columns factorized
!
         KB = N - K
!
      ELSE
!
!        Factorize the leading columns of A using the lower triangle
!        of A and working forwards, and compute the matrix W = L21*D
!        for use in updating A22
!
!        K is the main loop index, increasing from 1 in steps of 1 or 2
!
         K = 1
   70    CONTINUE
!
!        Exit from loop
!
         IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) &
            GO TO 90
!
!        Copy column K of A to column K of W and update it
!
         CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
         CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, &
                     W( K, 1 ), LDW, ONE, W( K, K ), 1 )
!
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( W( K, K ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.LT.N ) THEN
            IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
            COLMAX = ABS( W( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              Copy column IMAX to column K+1 of W and update it
!
               CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
               CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), &
                           1 )
               CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), &
                           LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
               ROWMAX = ABS( W( JMAX, K+1 ) )
               IF( IMAX.LT.N ) THEN
                  JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
!
!                 copy column K+1 of W to column K
!
                  CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
               ELSE
!
!                 interchange rows and columns K+1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K + KSTEP - 1
!
!           Updated column KP is already stored in column KK of W
!
            IF( KP.NE.KK ) THEN
!
!              Copy non-updated column KK to column KP
!
               A( KP, K ) = A( KK, K )
               CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
               CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
!
!              Interchange rows KK and KP in first KK columns of A and W
!
               CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
               CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
            END IF
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column k of W now holds
!
!              W(k) = L(k)*D(k)
!
!              where L(k) is the k-th column of L
!
!              Store L(k) in column k of A
!
               CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
               IF( K.LT.N ) THEN
                  R1 = ONE / A( K, K )
                  CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
               END IF
            ELSE
!
!              2-by-2 pivot block D(k): columns k and k+1 of W now hold
!
!              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
!
!              where L(k) and L(k+1) are the k-th and (k+1)-th columns
!              of L
!
               IF( K.LT.N-1 ) THEN
!
!                 Store L(k) and L(k+1) in columns k and k+1 of A
!
                  D21 = W( K+1, K )
                  D11 = W( K+1, K+1 ) / D21
                  D22 = W( K, K ) / D21
                  T = ONE / ( D11*D22-ONE )
                  D21 = T / D21
                  DO 80 J = K + 2, N
                     A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
                     A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
   80             CONTINUE
               END IF
!
!              Copy D(k) to A
!
               A( K, K ) = W( K, K )
               A( K+1, K ) = W( K+1, K )
               A( K+1, K+1 ) = W( K+1, K+1 )
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K+1 ) = -KP
         END IF
!
!        Increase K and return to the start of the main loop
!
         K = K + KSTEP
         GO TO 70
!
   90    CONTINUE
!
!        Update the lower triangle of A22 (= A(k:n,k:n)) as
!
!        A22 := A22 - L21*D*L21' = A22 - L21*W'
!
!        computing blocks of NB columns at a time
!
         DO 110 J = K, N, NB
            JB = MIN( NB, N-J+1 )
!
!           Update the lower triangle of the diagonal block
!
            DO 100 JJ = J, J + JB - 1
               CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, &
                           A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, &
                           A( JJ, JJ ), 1 )
  100       CONTINUE
!
!           Update the rectangular subdiagonal block
!
            IF( J+JB.LE.N ) &
               CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, &
                           K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, &
                           ONE, A( J+JB, J ), LDA )
  110    CONTINUE
!
!        Put L21 in standard form by partially undoing the interchanges
!        in columns 1:k-1
!
         J = K - 1
  120    CONTINUE
         JJ = J
         JP = IPIV( J )
         IF( JP.LT.0 ) THEN
            JP = -JP
            J = J - 1
         END IF
         J = J - 1
         IF( JP.NE.JJ .AND. J.GE.1 ) &
            CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
         IF( J.GE.1 ) &
            GO TO 120
!
!        Set KB to the number of columns factorized
!
         KB = K - 1
!
      END IF
      RETURN
!
!     End of DLASYF
!
      END
      SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, &
                         SCALE, CNORM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORMIN, TRANS, UPLO
      INTEGER            INFO, KD, LDAB, N
      DOUBLE PRECISION   SCALE
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), CNORM( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLATBS solves one of the triangular systems
!
!     A *x = s*b  or  A'*x = s*b
!
!  with scaling to prevent overflow, where A is an upper or lower
!  triangular band matrix.  Here A' denotes the transpose of A, x and b
!  are n-element vectors, and s is a scaling factor, usually less than
!  or equal to 1, chosen so that the components of x will be less than
!  the overflow threshold.  If the unscaled problem will not cause
!  overflow, the Level 2 BLAS routine DTBSV is called.  If the matrix A
!  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!  non-trivial solution to A*x = 0 is returned.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  TRANS   (input) CHARACTER*1
!          Specifies the operation applied to A.
!          = 'N':  Solve A * x = s*b  (No transpose)
!          = 'T':  Solve A'* x = s*b  (Transpose)
!          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  NORMIN  (input) CHARACTER*1
!          Specifies whether CNORM has been set or not.
!          = 'Y':  CNORM contains the column norms on entry
!          = 'N':  CNORM is not set on entry.  On exit, the norms will
!                  be computed and stored in CNORM.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of subdiagonals or superdiagonals in the
!          triangular matrix A.  KD >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangular band matrix A, stored in the
!          first KD+1 rows of the array. The j-th column of A is stored
!          in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  X       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the right hand side b of the triangular system.
!          On exit, X is overwritten by the solution vector x.
!
!  SCALE   (output) DOUBLE PRECISION
!          The scaling factor s for the triangular system
!             A * x = s*b  or  A'* x = s*b.
!          If SCALE = 0, the matrix A is singular or badly scaled, and
!          the vector x is an exact or approximate solution to A*x = 0.
!
!  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
!
!          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!          contains the norm of the off-diagonal part of the j-th column
!          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!          must be greater than or equal to the 1-norm.
!
!          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!          returns the 1-norm of the offdiagonal part of the j-th column
!          of A.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -k, the k-th argument had an illegal value
!
!  Further Details
!  ======= =======
!
!  A rough bound on x is computed; if that is less than overflow, DTBSV
!  is called, otherwise, specific code is used which checks for possible
!  overflow or divide-by-zero at every operation.
!
!  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!  if A is lower triangular is
!
!       x[1:n] := b[1:n]
!       for j = 1, ..., n
!            x(j) := x(j) / A(j,j)
!            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!       end
!
!  Define bounds on the components of x after j iterations of the loop:
!     M(j) = bound on x[1:j]
!     G(j) = bound on x[j+1:n]
!  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!
!  Then for iteration j+1 we have
!     M(j+1) <= G(j) / | A(j+1,j+1) |
!     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!
!  where CNORM(j+1) is greater than or equal to the infinity-norm of
!  column j+1 of A, not counting the diagonal.  Hence
!
!     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!                  1<=i<=j
!  and
!
!     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!                                   1<=i< j
!
!  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
!  reciprocal of the largest M(j), j=1,..,n, is larger than
!  max(underflow, 1/overflow).
!
!  The bound on x(j) is also used to determine when a step in the
!  columnwise method can be performed without fear of overflow.  If
!  the computed bound is greater than a large constant, x is scaled to
!  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!
!  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
!  algorithm for A upper triangular is
!
!       for j = 1, ..., n
!            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!       end
!
!  We simultaneously compute two bounds
!       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
!       M(j) = bound on x(i), 1<=i<=j
!
!  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!  Then the bound on x(j) is
!
!       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!
!            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!                      1<=i<=j
!
!  and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater
!  than max(underflow, 1/overflow).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, &
                         TMAX, TSCAL, USCAL, XBND, XJ, XMAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DTBSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Test the input parameters.
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. &
               LSAME( NORMIN, 'N' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( KD.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLATBS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine machine dependent parameters to control overflow.
!
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      SCALE = ONE
!
      IF( LSAME( NORMIN, 'N' ) ) THEN
!
!        Compute the 1-norm of each column, not including the diagonal.
!
         IF( UPPER ) THEN
!
!           A is upper triangular.
!
            DO 10 J = 1, N
               JLEN = MIN( KD, J-1 )
               CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
   10       CONTINUE
         ELSE
!
!           A is lower triangular.
!
            DO 20 J = 1, N
               JLEN = MIN( KD, N-J )
               IF( JLEN.GT.0 ) THEN
                  CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 )
               ELSE
                  CNORM( J ) = ZERO
               END IF
   20       CONTINUE
         END IF
      END IF
!
!     Scale the column norms by TSCAL if the maximum element in CNORM is
!     greater than BIGNUM.
!
      IMAX = IDAMAX( N, CNORM, 1 )
      TMAX = CNORM( IMAX )
      IF( TMAX.LE.BIGNUM ) THEN
         TSCAL = ONE
      ELSE
         TSCAL = ONE / ( SMLNUM*TMAX )
         CALL DSCAL( N, TSCAL, CNORM, 1 )
      END IF
!
!     Compute a bound on the computed solution vector to see if the
!     Level 2 BLAS routine DTBSV can be used.
!
      J = IDAMAX( N, X, 1 )
      XMAX = ABS( X( J ) )
      XBND = XMAX
      IF( NOTRAN ) THEN
!
!        Compute the growth in A * x = b.
!
         IF( UPPER ) THEN
            JFIRST = N
            JLAST = 1
            JINC = -1
            MAIND = KD + 1
         ELSE
            JFIRST = 1
            JLAST = N
            JINC = 1
            MAIND = 1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 50
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, G(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 30 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              M(j) = G(j-1) / abs(A(j,j))
!
               TJJ = ABS( AB( MAIND, J ) )
               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
!
!                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
!
                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
               ELSE
!
!                 G(j) could overflow, set GROW to 0.
!
                  GROW = ZERO
               END IF
   30       CONTINUE
            GROW = XBND
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 40 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              G(j) = G(j-1)*( 1 + CNORM(j) )
!
               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
   40       CONTINUE
         END IF
   50    CONTINUE
!
      ELSE
!
!        Compute the growth in A' * x = b.
!
         IF( UPPER ) THEN
            JFIRST = 1
            JLAST = N
            JINC = 1
            MAIND = KD + 1
         ELSE
            JFIRST = N
            JLAST = 1
            JINC = -1
            MAIND = 1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 80
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, M(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 60 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
!
               XJ = ONE + CNORM( J )
               GROW = MIN( GROW, XBND / XJ )
!
!              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
!
               TJJ = ABS( AB( MAIND, J ) )
               IF( XJ.GT.TJJ ) &
                  XBND = XBND*( TJJ / XJ )
   60       CONTINUE
            GROW = MIN( GROW, XBND )
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 70 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = ( 1 + CNORM(j) )*G(j-1)
!
               XJ = ONE + CNORM( J )
               GROW = GROW / XJ
   70       CONTINUE
         END IF
   80    CONTINUE
      END IF
!
      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
!
!        Use the Level 2 BLAS solve if the reciprocal of the bound on
!        elements of X is not too small.
!
         CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
      ELSE
!
!        Use a Level 1 BLAS solve, scaling intermediate results.
!
         IF( XMAX.GT.BIGNUM ) THEN
!
!           Scale X so that its components are less than or equal to
!           BIGNUM in absolute value.
!
            SCALE = BIGNUM / XMAX
            CALL DSCAL( N, SCALE, X, 1 )
            XMAX = BIGNUM
         END IF
!
         IF( NOTRAN ) THEN
!
!           Solve A * x = b
!
            DO 110 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
!
               XJ = ABS( X( J ) )
               IF( NOUNIT ) THEN
                  TJJS = AB( MAIND, J )*TSCAL
               ELSE
                  TJJS = TSCAL
                  IF( TSCAL.EQ.ONE ) &
                     GO TO 100
               END IF
               TJJ = ABS( TJJS )
               IF( TJJ.GT.SMLNUM ) THEN
!
!                    abs(A(j,j)) > SMLNUM:
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by 1/b(j).
!
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE IF( TJJ.GT.ZERO ) THEN
!
!                    0 < abs(A(j,j)) <= SMLNUM:
!
                  IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
!                       to avoid overflow when dividing by A(j,j).
!
                     REC = ( TJJ*BIGNUM ) / XJ
                     IF( CNORM( J ).GT.ONE ) THEN
!
!                          Scale by 1/CNORM(j) to avoid overflow when
!                          multiplying x(j) times column j.
!
                        REC = REC / CNORM( J )
                     END IF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE
!
!                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                    scale = 0, and compute a solution to A*x = 0.
!
                  DO 90 I = 1, N
                     X( I ) = ZERO
   90             CONTINUE
                  X( J ) = ONE
                  XJ = ONE
                  SCALE = ZERO
                  XMAX = ZERO
               END IF
  100          CONTINUE
!
!              Scale x if necessary to avoid overflow when adding a
!              multiple of column j of A.
!
               IF( XJ.GT.ONE ) THEN
                  REC = ONE / XJ
                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
!
!                    Scale x by 1/(2*abs(x(j))).
!
                     REC = REC*HALF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                  END IF
               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
!
!                 Scale x by 1/2.
!
                  CALL DSCAL( N, HALF, X, 1 )
                  SCALE = SCALE*HALF
               END IF
!
               IF( UPPER ) THEN
                  IF( J.GT.1 ) THEN
!
!                    Compute the update
!                       x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
!                                             x(j)* A(max(1,j-kd):j-1,j)
!
                     JLEN = MIN( KD, J-1 )
                     CALL DAXPY( JLEN, -X( J )*TSCAL, &
                                 AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
                     I = IDAMAX( J-1, X, 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               ELSE IF( J.LT.N ) THEN
!
!                 Compute the update
!                    x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
!                                          x(j) * A(j+1:min(j+kd,n),j)
!
                  JLEN = MIN( KD, N-J )
                  IF( JLEN.GT.0 ) &
                     CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, &
                                 X( J+1 ), 1 )
                  I = J + IDAMAX( N-J, X( J+1 ), 1 )
                  XMAX = ABS( X( I ) )
               END IF
  110       CONTINUE
!
         ELSE
!
!           Solve A' * x = b
!
            DO 160 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) - sum A(k,j)*x(k).
!                                    k<>j
!
               XJ = ABS( X( J ) )
               USCAL = TSCAL
               REC = ONE / MAX( XMAX, ONE )
               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
!
!                 If x(j) could overflow, scale x by 1/(2*XMAX).
!
                  REC = REC*HALF
                  IF( NOUNIT ) THEN
                     TJJS = AB( MAIND, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.ONE ) THEN
!
!                       Divide by A(j,j) when scaling x if A(j,j) > 1.
!
                     REC = MIN( ONE, REC*TJJ )
                     USCAL = USCAL / TJJS
                  END IF
                  IF( REC.LT.ONE ) THEN
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
               END IF
!
               SUMJ = ZERO
               IF( USCAL.EQ.ONE ) THEN
!
!                 If the scaling needed for A in the dot product is 1,
!                 call DDOT to perform the dot product.
!
                  IF( UPPER ) THEN
                     JLEN = MIN( KD, J-1 )
                     SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, &
                            X( J-JLEN ), 1 )
                  ELSE
                     JLEN = MIN( KD, N-J )
                     IF( JLEN.GT.0 ) &
                        SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
                  END IF
               ELSE
!
!                 Otherwise, use in-line code for the dot product.
!
                  IF( UPPER ) THEN
                     JLEN = MIN( KD, J-1 )
                     DO 120 I = 1, JLEN
                        SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* &
                               X( J-JLEN-1+I )
  120                CONTINUE
                  ELSE
                     JLEN = MIN( KD, N-J )
                     DO 130 I = 1, JLEN
                        SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
  130                CONTINUE
                  END IF
               END IF
!
               IF( USCAL.EQ.TSCAL ) THEN
!
!                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
!                 was not used to scale the dotproduct.
!
                  X( J ) = X( J ) - SUMJ
                  XJ = ABS( X( J ) )
                  IF( NOUNIT ) THEN
!
!                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
!
                     TJJS = AB( MAIND, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                     IF( TSCAL.EQ.ONE ) &
                        GO TO 150
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.SMLNUM ) THEN
!
!                       abs(A(j,j)) > SMLNUM:
!
                     IF( TJJ.LT.ONE ) THEN
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                             Scale X by 1/abs(x(j)).
!
                           REC = ONE / XJ
                           CALL DSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE IF( TJJ.GT.ZERO ) THEN
!
!                       0 < abs(A(j,j)) <= SMLNUM:
!
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
!
                        REC = ( TJJ*BIGNUM ) / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE
!
!                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                       scale = 0, and compute a solution to A'*x = 0.
!
                     DO 140 I = 1, N
                        X( I ) = ZERO
  140                CONTINUE
                     X( J ) = ONE
                     SCALE = ZERO
                     XMAX = ZERO
                  END IF
  150             CONTINUE
               ELSE
!
!                 Compute x(j) := x(j) / A(j,j) - sumj if the dot
!                 product has already been divided by 1/A(j,j).
!
                  X( J ) = X( J ) / TJJS - SUMJ
               END IF
               XMAX = MAX( XMAX, ABS( X( J ) ) )
  160       CONTINUE
         END IF
         SCALE = SCALE / TSCAL
      END IF
!
!     Scale the column norms by 1/TSCAL for return.
!
      IF( TSCAL.NE.ONE ) THEN
         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
      END IF
!
      RETURN
!
!     End of DLATBS
!
      END
      SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, &
                         JPIV )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IJOB, LDZ, N
      DOUBLE PRECISION   RDSCAL, RDSUM
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   RHS( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DLATDF uses the LU factorization of the n-by-n matrix Z computed by
!  DGETC2 and computes a contribution to the reciprocal Dif-estimate
!  by solving Z * x = b for x, and choosing the r.h.s. b such that
!  the norm of x is as large as possible. On entry RHS = b holds the
!  contribution from earlier solved sub-systems, and on return RHS = x.
!
!  The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
!  where P and Q are permutation matrices. L is lower triangular with
!  unit diagonal elements and U is upper triangular.
!
!  Arguments
!  =========
!
!  IJOB    (input) INTEGER
!          IJOB = 2: First compute an approximative null-vector e
!              of Z using DGECON, e is normalized and solve for
!              Zx = +-e - f with the sign giving the greater value
!              of 2-norm(x). About 5 times as expensive as Default.
!          IJOB .ne. 2: Local look ahead strategy where all entries of
!              the r.h.s. b is choosen as either +1 or -1 (Default).
!
!  N       (input) INTEGER
!          The number of columns of the matrix Z.
!
!  Z       (input) DOUBLE PRECISION array, dimension (LDZ, N)
!          On entry, the LU part of the factorization of the n-by-n
!          matrix Z computed by DGETC2:  Z = P * L * U * Q
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDA >= max(1, N).
!
!  RHS     (input/output) DOUBLE PRECISION array, dimension N.
!          On entry, RHS contains contributions from other subsystems.
!          On exit, RHS contains the solution of the subsystem with
!          entries acoording to the value of IJOB (see above).
!
!  RDSUM   (input/output) DOUBLE PRECISION
!          On entry, the sum of squares of computed contributions to
!          the Dif-estimate under computation by DTGSYL, where the
!          scaling factor RDSCAL (see below) has been factored out.
!          On exit, the corresponding sum of squares updated with the
!          contributions from the current sub-system.
!          If TRANS = 'T' RDSUM is not touched.
!          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
!
!  RDSCAL  (input/output) DOUBLE PRECISION
!          On entry, scaling factor used to prevent overflow in RDSUM.
!          On exit, RDSCAL is updated w.r.t. the current contributions
!          in RDSUM.
!          If TRANS = 'T', RDSCAL is not touched.
!          NOTE: RDSCAL only makes sense when DTGSY2 is called by
!                DTGSYL.
!
!  IPIV    (input) INTEGER array, dimension (N).
!          The pivot indices; for 1 <= i <= N, row i of the
!          matrix has been interchanged with row IPIV(i).
!
!  JPIV    (input) INTEGER array, dimension (N).
!          The pivot indices; for 1 <= j <= N, column j of the
!          matrix has been interchanged with column JPIV(j).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  This routine is a further developed implementation of algorithm
!  BSOLVE in [1] using complete pivoting in the LU factorization.
!
!  [1] Bo Kagstrom and Lars Westin,
!      Generalized Schur Methods with Condition Estimators for
!      Solving the Generalized Sylvester Equation, IEEE Transactions
!      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
!
!  [2] Peter Poromaa,
!      On Efficient and Robust Estimators for the Separation
!      between two Regular Matrix Pairs with Applications in
!      Condition Estimation. Report IMINF-95.05, Departement of
!      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MAXDIM
      PARAMETER          ( MAXDIM = 8 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, INFO, J, K
      DOUBLE PRECISION   BM, BP, PMONE, SMINU, SPLUS, TEMP
!     ..
!     .. Local Arrays ..
      INTEGER            IWORK( MAXDIM )
      DOUBLE PRECISION   WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP, &
                         DSCAL
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DASUM, DDOT
      EXTERNAL           DASUM, DDOT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
!     ..
!     .. Executable Statements ..
!
      IF( IJOB.NE.2 ) THEN
!
!        Apply permutations IPIV to RHS
!
         CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
!
!        Solve for L-part choosing RHS either to +1 or -1.
!
         PMONE = -ONE
!
         DO 10 J = 1, N - 1
            BP = RHS( J ) + ONE
            BM = RHS( J ) - ONE
            SPLUS = ONE
!
!           Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
!           SMIN computed more efficiently than in BSOLVE [1].
!
            SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
            SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
            SPLUS = SPLUS*RHS( J )
            IF( SPLUS.GT.SMINU ) THEN
               RHS( J ) = BP
            ELSE IF( SMINU.GT.SPLUS ) THEN
               RHS( J ) = BM
            ELSE
!
!              In this case the updating sums are equal and we can
!              choose RHS(J) +1 or -1. The first time this happens
!              we choose -1, thereafter +1. This is a simple way to
!              get good estimates of matrices like Byers well-known
!              example (see [1]). (Not done in BSOLVE.)
!
               RHS( J ) = RHS( J ) + PMONE
               PMONE = ONE
            END IF
!
!           Compute the remaining r.h.s.
!
            TEMP = -RHS( J )
            CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
!
   10    CONTINUE
!
!        Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
!        in BSOLVE and will hopefully give us a better estimate because
!        any ill-conditioning of the original matrix is transfered to U
!        and not to L. U(N, N) is an approximation to sigma_min(LU).
!
         CALL DCOPY( N-1, RHS, 1, XP, 1 )
         XP( N ) = RHS( N ) + ONE
         RHS( N ) = RHS( N ) - ONE
         SPLUS = ZERO
         SMINU = ZERO
         DO 30 I = N, 1, -1
            TEMP = ONE / Z( I, I )
            XP( I ) = XP( I )*TEMP
            RHS( I ) = RHS( I )*TEMP
            DO 20 K = I + 1, N
               XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
               RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
   20       CONTINUE
            SPLUS = SPLUS + ABS( XP( I ) )
            SMINU = SMINU + ABS( RHS( I ) )
   30    CONTINUE
         IF( SPLUS.GT.SMINU ) &
            CALL DCOPY( N, XP, 1, RHS, 1 )
!
!        Apply the permutations JPIV to the computed solution (RHS)
!
         CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
!
!        Compute the sum of squares
!
         CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
!
      ELSE
!
!        IJOB = 2, Compute approximate nullvector XM of Z
!
         CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
         CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 )
!
!        Compute RHS
!
         CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
         TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) )
         CALL DSCAL( N, TEMP, XM, 1 )
         CALL DCOPY( N, XM, 1, XP, 1 )
         CALL DAXPY( N, ONE, RHS, 1, XP, 1 )
         CALL DAXPY( N, -ONE, XM, 1, RHS, 1 )
         CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
         CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
         IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) ) &
            CALL DCOPY( N, XP, 1, RHS, 1 )
!
!        Compute the sum of squares
!
         CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
!
      END IF
!
      RETURN
!
!     End of DLATDF
!
      END
      SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, &
                         CNORM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORMIN, TRANS, UPLO
      INTEGER            INFO, N
      DOUBLE PRECISION   SCALE
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), CNORM( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLATPS solves one of the triangular systems
!
!     A *x = s*b  or  A'*x = s*b
!
!  with scaling to prevent overflow, where A is an upper or lower
!  triangular matrix stored in packed form.  Here A' denotes the
!  transpose of A, x and b are n-element vectors, and s is a scaling
!  factor, usually less than or equal to 1, chosen so that the
!  components of x will be less than the overflow threshold.  If the
!  unscaled problem will not cause overflow, the Level 2 BLAS routine
!  DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  TRANS   (input) CHARACTER*1
!          Specifies the operation applied to A.
!          = 'N':  Solve A * x = s*b  (No transpose)
!          = 'T':  Solve A'* x = s*b  (Transpose)
!          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  NORMIN  (input) CHARACTER*1
!          Specifies whether CNORM has been set or not.
!          = 'Y':  CNORM contains the column norms on entry
!          = 'N':  CNORM is not set on entry.  On exit, the norms will
!                  be computed and stored in CNORM.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangular matrix A, packed columnwise in
!          a linear array.  The j-th column of A is stored in the array
!          AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!  X       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the right hand side b of the triangular system.
!          On exit, X is overwritten by the solution vector x.
!
!  SCALE   (output) DOUBLE PRECISION
!          The scaling factor s for the triangular system
!             A * x = s*b  or  A'* x = s*b.
!          If SCALE = 0, the matrix A is singular or badly scaled, and
!          the vector x is an exact or approximate solution to A*x = 0.
!
!  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
!
!          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!          contains the norm of the off-diagonal part of the j-th column
!          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!          must be greater than or equal to the 1-norm.
!
!          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!          returns the 1-norm of the offdiagonal part of the j-th column
!          of A.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -k, the k-th argument had an illegal value
!
!  Further Details
!  ======= =======
!
!  A rough bound on x is computed; if that is less than overflow, DTPSV
!  is called, otherwise, specific code is used which checks for possible
!  overflow or divide-by-zero at every operation.
!
!  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!  if A is lower triangular is
!
!       x[1:n] := b[1:n]
!       for j = 1, ..., n
!            x(j) := x(j) / A(j,j)
!            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!       end
!
!  Define bounds on the components of x after j iterations of the loop:
!     M(j) = bound on x[1:j]
!     G(j) = bound on x[j+1:n]
!  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!
!  Then for iteration j+1 we have
!     M(j+1) <= G(j) / | A(j+1,j+1) |
!     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!
!  where CNORM(j+1) is greater than or equal to the infinity-norm of
!  column j+1 of A, not counting the diagonal.  Hence
!
!     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!                  1<=i<=j
!  and
!
!     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!                                   1<=i< j
!
!  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the
!  reciprocal of the largest M(j), j=1,..,n, is larger than
!  max(underflow, 1/overflow).
!
!  The bound on x(j) is also used to determine when a step in the
!  columnwise method can be performed without fear of overflow.  If
!  the computed bound is greater than a large constant, x is scaled to
!  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!
!  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
!  algorithm for A upper triangular is
!
!       for j = 1, ..., n
!            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!       end
!
!  We simultaneously compute two bounds
!       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
!       M(j) = bound on x(i), 1<=i<=j
!
!  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!  Then the bound on x(j) is
!
!       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!
!            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!                      1<=i<=j
!
!  and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater
!  than max(underflow, 1/overflow).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      INTEGER            I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, &
                         TMAX, TSCAL, USCAL, XBND, XJ, XMAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Test the input parameters.
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. &
               LSAME( NORMIN, 'N' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLATPS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine machine dependent parameters to control overflow.
!
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      SCALE = ONE
!
      IF( LSAME( NORMIN, 'N' ) ) THEN
!
!        Compute the 1-norm of each column, not including the diagonal.
!
         IF( UPPER ) THEN
!
!           A is upper triangular.
!
            IP = 1
            DO 10 J = 1, N
               CNORM( J ) = DASUM( J-1, AP( IP ), 1 )
               IP = IP + J
   10       CONTINUE
         ELSE
!
!           A is lower triangular.
!
            IP = 1
            DO 20 J = 1, N - 1
               CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 )
               IP = IP + N - J + 1
   20       CONTINUE
            CNORM( N ) = ZERO
         END IF
      END IF
!
!     Scale the column norms by TSCAL if the maximum element in CNORM is
!     greater than BIGNUM.
!
      IMAX = IDAMAX( N, CNORM, 1 )
      TMAX = CNORM( IMAX )
      IF( TMAX.LE.BIGNUM ) THEN
         TSCAL = ONE
      ELSE
         TSCAL = ONE / ( SMLNUM*TMAX )
         CALL DSCAL( N, TSCAL, CNORM, 1 )
      END IF
!
!     Compute a bound on the computed solution vector to see if the
!     Level 2 BLAS routine DTPSV can be used.
!
      J = IDAMAX( N, X, 1 )
      XMAX = ABS( X( J ) )
      XBND = XMAX
      IF( NOTRAN ) THEN
!
!        Compute the growth in A * x = b.
!
         IF( UPPER ) THEN
            JFIRST = N
            JLAST = 1
            JINC = -1
         ELSE
            JFIRST = 1
            JLAST = N
            JINC = 1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 50
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, G(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            IP = JFIRST*( JFIRST+1 ) / 2
            JLEN = N
            DO 30 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              M(j) = G(j-1) / abs(A(j,j))
!
               TJJ = ABS( AP( IP ) )
               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
!
!                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
!
                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
               ELSE
!
!                 G(j) could overflow, set GROW to 0.
!
                  GROW = ZERO
               END IF
               IP = IP + JINC*JLEN
               JLEN = JLEN - 1
   30       CONTINUE
            GROW = XBND
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 40 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              G(j) = G(j-1)*( 1 + CNORM(j) )
!
               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
   40       CONTINUE
         END IF
   50    CONTINUE
!
      ELSE
!
!        Compute the growth in A' * x = b.
!
         IF( UPPER ) THEN
            JFIRST = 1
            JLAST = N
            JINC = 1
         ELSE
            JFIRST = N
            JLAST = 1
            JINC = -1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 80
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, M(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            IP = JFIRST*( JFIRST+1 ) / 2
            JLEN = 1
            DO 60 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
!
               XJ = ONE + CNORM( J )
               GROW = MIN( GROW, XBND / XJ )
!
!              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
!
               TJJ = ABS( AP( IP ) )
               IF( XJ.GT.TJJ ) &
                  XBND = XBND*( TJJ / XJ )
               JLEN = JLEN + 1
               IP = IP + JINC*JLEN
   60       CONTINUE
            GROW = MIN( GROW, XBND )
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 70 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = ( 1 + CNORM(j) )*G(j-1)
!
               XJ = ONE + CNORM( J )
               GROW = GROW / XJ
   70       CONTINUE
         END IF
   80    CONTINUE
      END IF
!
      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
!
!        Use the Level 2 BLAS solve if the reciprocal of the bound on
!        elements of X is not too small.
!
         CALL DTPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
      ELSE
!
!        Use a Level 1 BLAS solve, scaling intermediate results.
!
         IF( XMAX.GT.BIGNUM ) THEN
!
!           Scale X so that its components are less than or equal to
!           BIGNUM in absolute value.
!
            SCALE = BIGNUM / XMAX
            CALL DSCAL( N, SCALE, X, 1 )
            XMAX = BIGNUM
         END IF
!
         IF( NOTRAN ) THEN
!
!           Solve A * x = b
!
            IP = JFIRST*( JFIRST+1 ) / 2
            DO 110 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
!
               XJ = ABS( X( J ) )
               IF( NOUNIT ) THEN
                  TJJS = AP( IP )*TSCAL
               ELSE
                  TJJS = TSCAL
                  IF( TSCAL.EQ.ONE ) &
                     GO TO 100
               END IF
               TJJ = ABS( TJJS )
               IF( TJJ.GT.SMLNUM ) THEN
!
!                    abs(A(j,j)) > SMLNUM:
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by 1/b(j).
!
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE IF( TJJ.GT.ZERO ) THEN
!
!                    0 < abs(A(j,j)) <= SMLNUM:
!
                  IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
!                       to avoid overflow when dividing by A(j,j).
!
                     REC = ( TJJ*BIGNUM ) / XJ
                     IF( CNORM( J ).GT.ONE ) THEN
!
!                          Scale by 1/CNORM(j) to avoid overflow when
!                          multiplying x(j) times column j.
!
                        REC = REC / CNORM( J )
                     END IF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE
!
!                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                    scale = 0, and compute a solution to A*x = 0.
!
                  DO 90 I = 1, N
                     X( I ) = ZERO
   90             CONTINUE
                  X( J ) = ONE
                  XJ = ONE
                  SCALE = ZERO
                  XMAX = ZERO
               END IF
  100          CONTINUE
!
!              Scale x if necessary to avoid overflow when adding a
!              multiple of column j of A.
!
               IF( XJ.GT.ONE ) THEN
                  REC = ONE / XJ
                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
!
!                    Scale x by 1/(2*abs(x(j))).
!
                     REC = REC*HALF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                  END IF
               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
!
!                 Scale x by 1/2.
!
                  CALL DSCAL( N, HALF, X, 1 )
                  SCALE = SCALE*HALF
               END IF
!
               IF( UPPER ) THEN
                  IF( J.GT.1 ) THEN
!
!                    Compute the update
!                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
!
                     CALL DAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X, &
                                 1 )
                     I = IDAMAX( J-1, X, 1 )
                     XMAX = ABS( X( I ) )
                  END IF
                  IP = IP - J
               ELSE
                  IF( J.LT.N ) THEN
!
!                    Compute the update
!                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
!
                     CALL DAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1, &
                                 X( J+1 ), 1 )
                     I = J + IDAMAX( N-J, X( J+1 ), 1 )
                     XMAX = ABS( X( I ) )
                  END IF
                  IP = IP + N - J + 1
               END IF
  110       CONTINUE
!
         ELSE
!
!           Solve A' * x = b
!
            IP = JFIRST*( JFIRST+1 ) / 2
            JLEN = 1
            DO 160 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) - sum A(k,j)*x(k).
!                                    k<>j
!
               XJ = ABS( X( J ) )
               USCAL = TSCAL
               REC = ONE / MAX( XMAX, ONE )
               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
!
!                 If x(j) could overflow, scale x by 1/(2*XMAX).
!
                  REC = REC*HALF
                  IF( NOUNIT ) THEN
                     TJJS = AP( IP )*TSCAL
                  ELSE
                     TJJS = TSCAL
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.ONE ) THEN
!
!                       Divide by A(j,j) when scaling x if A(j,j) > 1.
!
                     REC = MIN( ONE, REC*TJJ )
                     USCAL = USCAL / TJJS
                  END IF
                  IF( REC.LT.ONE ) THEN
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
               END IF
!
               SUMJ = ZERO
               IF( USCAL.EQ.ONE ) THEN
!
!                 If the scaling needed for A in the dot product is 1,
!                 call DDOT to perform the dot product.
!
                  IF( UPPER ) THEN
                     SUMJ = DDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
                  ELSE IF( J.LT.N ) THEN
                     SUMJ = DDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
                  END IF
               ELSE
!
!                 Otherwise, use in-line code for the dot product.
!
                  IF( UPPER ) THEN
                     DO 120 I = 1, J - 1
                        SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
  120                CONTINUE
                  ELSE IF( J.LT.N ) THEN
                     DO 130 I = 1, N - J
                        SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
  130                CONTINUE
                  END IF
               END IF
!
               IF( USCAL.EQ.TSCAL ) THEN
!
!                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
!                 was not used to scale the dotproduct.
!
                  X( J ) = X( J ) - SUMJ
                  XJ = ABS( X( J ) )
                  IF( NOUNIT ) THEN
!
!                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
!
                     TJJS = AP( IP )*TSCAL
                  ELSE
                     TJJS = TSCAL
                     IF( TSCAL.EQ.ONE ) &
                        GO TO 150
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.SMLNUM ) THEN
!
!                       abs(A(j,j)) > SMLNUM:
!
                     IF( TJJ.LT.ONE ) THEN
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                             Scale X by 1/abs(x(j)).
!
                           REC = ONE / XJ
                           CALL DSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE IF( TJJ.GT.ZERO ) THEN
!
!                       0 < abs(A(j,j)) <= SMLNUM:
!
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
!
                        REC = ( TJJ*BIGNUM ) / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE
!
!                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                       scale = 0, and compute a solution to A'*x = 0.
!
                     DO 140 I = 1, N
                        X( I ) = ZERO
  140                CONTINUE
                     X( J ) = ONE
                     SCALE = ZERO
                     XMAX = ZERO
                  END IF
  150             CONTINUE
               ELSE
!
!                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
!                 product has already been divided by 1/A(j,j).
!
                  X( J ) = X( J ) / TJJS - SUMJ
               END IF
               XMAX = MAX( XMAX, ABS( X( J ) ) )
               JLEN = JLEN + 1
               IP = IP + JINC*JLEN
  160       CONTINUE
         END IF
         SCALE = SCALE / TSCAL
      END IF
!
!     Scale the column norms by 1/TSCAL for return.
!
      IF( TSCAL.NE.ONE ) THEN
         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
      END IF
!
      RETURN
!
!     End of DLATPS
!
      END
      SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDW, N, NB
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
!     ..
!
!  Purpose
!  =======
!
!  DLATRD reduces NB rows and columns of a real symmetric matrix A to
!  symmetric tridiagonal form by an orthogonal similarity
!  transformation Q' * A * Q, and returns the matrices V and W which are
!  needed to apply the transformation to the unreduced part of A.
!
!  If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
!  matrix, of which the upper triangle is supplied;
!  if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
!  matrix, of which the lower triangle is supplied.
!
!  This is an auxiliary routine called by DSYTRD.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored:
!          = 'U': Upper triangular
!          = 'L': Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.
!
!  NB      (input) INTEGER
!          The number of rows and columns to be reduced.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n-by-n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n-by-n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!          On exit:
!          if UPLO = 'U', the last NB columns have been reduced to
!            tridiagonal form, with the diagonal elements overwriting
!            the diagonal elements of A; the elements above the diagonal
!            with the array TAU, represent the orthogonal matrix Q as a
!            product of elementary reflectors;
!          if UPLO = 'L', the first NB columns have been reduced to
!            tridiagonal form, with the diagonal elements overwriting
!            the diagonal elements of A; the elements below the diagonal
!            with the array TAU, represent the  orthogonal matrix Q as a
!            product of elementary reflectors.
!          See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= (1,N).
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
!          elements of the last NB columns of the reduced matrix;
!          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
!          the first NB columns of the reduced matrix.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors, stored in
!          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
!          See Further Details.
!
!  W       (output) DOUBLE PRECISION array, dimension (LDW,NB)
!          The n-by-nb matrix W required to update the unreduced part
!          of A.
!
!  LDW     (input) INTEGER
!          The leading dimension of the array W. LDW >= max(1,N).
!
!  Further Details
!  ===============
!
!  If UPLO = 'U', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(n) H(n-1) . . . H(n-nb+1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
!  and tau in TAU(i-1).
!
!  If UPLO = 'L', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(1) H(2) . . . H(nb).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!  and tau in TAU(i).
!
!  The elements of the vectors v together form the n-by-nb matrix V
!  which is needed, with W, to apply the transformation to the unreduced
!  part of the matrix, using a symmetric rank-2k update of the form:
!  A := A - V*W' - W*V'.
!
!  The contents of A on exit are illustrated by the following examples
!  with n = 5 and nb = 2:
!
!  if UPLO = 'U':                       if UPLO = 'L':
!
!    (  a   a   a   v4  v5 )              (  d                  )
!    (      a   a   v4  v5 )              (  1   d              )
!    (          a   1   v5 )              (  v1  1   a          )
!    (              d   1  )              (  v1  v2  a   a      )
!    (                  d  )              (  v1  v2  a   a   a  )
!
!  where d denotes a diagonal element of the reduced matrix, a denotes
!  an element of the original matrix that is unchanged, and vi denotes
!  an element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IW
      DOUBLE PRECISION   ALPHA
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
      IF( LSAME( UPLO, 'U' ) ) THEN
!
!        Reduce last NB columns of upper triangle
!
         DO 10 I = N, N - NB + 1, -1
            IW = I - N + NB
            IF( I.LT.N ) THEN
!
!              Update A(1:i,i)
!
               CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), &
                           LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
               CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), &
                           LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
            END IF
            IF( I.GT.1 ) THEN
!
!              Generate elementary reflector H(i) to annihilate
!              A(1:i-2,i)
!
               CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
               E( I-1 ) = A( I-1, I )
               A( I-1, I ) = ONE
!
!              Compute W(1:i-1,i)
!
               CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, &
                           ZERO, W( 1, IW ), 1 )
               IF( I.LT.N ) THEN
                  CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), &
                              LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
                  CALL DGEMV( 'No transpose', I-1, N-I, -ONE, &
                              A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, &
                              W( 1, IW ), 1 )
                  CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), &
                              LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
                  CALL DGEMV( 'No transpose', I-1, N-I, -ONE, &
                              W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, &
                              W( 1, IW ), 1 )
               END IF
               CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
               ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, &
                       A( 1, I ), 1 )
               CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
            END IF
!
   10    CONTINUE
      ELSE
!
!        Reduce first NB columns of lower triangle
!
         DO 20 I = 1, NB
!
!           Update A(i:n,i)
!
            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), &
                        LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), &
                        LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
            IF( I.LT.N ) THEN
!
!              Generate elementary reflector H(i) to annihilate
!              A(i+2:n,i)
!
               CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, &
                            TAU( I ) )
               E( I ) = A( I+1, I )
               A( I+1, I ) = ONE
!
!              Compute W(i+1:n,i)
!
               CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, &
                           A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, &
                           A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), &
                           LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
               CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, &
                           A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), &
                           LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
               CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
               ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, &
                       A( I+1, I ), 1 )
               CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
            END IF
!
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DLATRD
!
      END
      SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, &
                         CNORM, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORMIN, TRANS, UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   SCALE
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), CNORM( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DLATRS solves one of the triangular systems
!
!     A *x = s*b  or  A'*x = s*b
!
!  with scaling to prevent overflow.  Here A is an upper or lower
!  triangular matrix, A' denotes the transpose of A, x and b are
!  n-element vectors, and s is a scaling factor, usually less than
!  or equal to 1, chosen so that the components of x will be less than
!  the overflow threshold.  If the unscaled problem will not cause
!  overflow, the Level 2 BLAS routine DTRSV is called.  If the matrix A
!  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!  non-trivial solution to A*x = 0 is returned.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  TRANS   (input) CHARACTER*1
!          Specifies the operation applied to A.
!          = 'N':  Solve A * x = s*b  (No transpose)
!          = 'T':  Solve A'* x = s*b  (Transpose)
!          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  NORMIN  (input) CHARACTER*1
!          Specifies whether CNORM has been set or not.
!          = 'Y':  CNORM contains the column norms on entry
!          = 'N':  CNORM is not set on entry.  On exit, the norms will
!                  be computed and stored in CNORM.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular matrix A.  If UPLO = 'U', the leading n by n
!          upper triangular part of the array A contains the upper
!          triangular matrix, and the strictly lower triangular part of
!          A is not referenced.  If UPLO = 'L', the leading n by n lower
!          triangular part of the array A contains the lower triangular
!          matrix, and the strictly upper triangular part of A is not
!          referenced.  If DIAG = 'U', the diagonal elements of A are
!          also not referenced and are assumed to be 1.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max (1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the right hand side b of the triangular system.
!          On exit, X is overwritten by the solution vector x.
!
!  SCALE   (output) DOUBLE PRECISION
!          The scaling factor s for the triangular system
!             A * x = s*b  or  A'* x = s*b.
!          If SCALE = 0, the matrix A is singular or badly scaled, and
!          the vector x is an exact or approximate solution to A*x = 0.
!
!  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
!
!          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!          contains the norm of the off-diagonal part of the j-th column
!          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!          must be greater than or equal to the 1-norm.
!
!          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!          returns the 1-norm of the offdiagonal part of the j-th column
!          of A.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -k, the k-th argument had an illegal value
!
!  Further Details
!  ======= =======
!
!  A rough bound on x is computed; if that is less than overflow, DTRSV
!  is called, otherwise, specific code is used which checks for possible
!  overflow or divide-by-zero at every operation.
!
!  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!  if A is lower triangular is
!
!       x[1:n] := b[1:n]
!       for j = 1, ..., n
!            x(j) := x(j) / A(j,j)
!            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!       end
!
!  Define bounds on the components of x after j iterations of the loop:
!     M(j) = bound on x[1:j]
!     G(j) = bound on x[j+1:n]
!  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!
!  Then for iteration j+1 we have
!     M(j+1) <= G(j) / | A(j+1,j+1) |
!     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!
!  where CNORM(j+1) is greater than or equal to the infinity-norm of
!  column j+1 of A, not counting the diagonal.  Hence
!
!     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!                  1<=i<=j
!  and
!
!     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!                                   1<=i< j
!
!  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
!  reciprocal of the largest M(j), j=1,..,n, is larger than
!  max(underflow, 1/overflow).
!
!  The bound on x(j) is also used to determine when a step in the
!  columnwise method can be performed without fear of overflow.  If
!  the computed bound is greater than a large constant, x is scaled to
!  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!
!  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
!  algorithm for A upper triangular is
!
!       for j = 1, ..., n
!            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!       end
!
!  We simultaneously compute two bounds
!       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
!       M(j) = bound on x(i), 1<=i<=j
!
!  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!  Then the bound on x(j) is
!
!       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!
!            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!                      1<=i<=j
!
!  and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
!  than max(underflow, 1/overflow).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, &
                         TMAX, TSCAL, USCAL, XBND, XJ, XMAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DTRSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Test the input parameters.
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. &
               LSAME( NORMIN, 'N' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLATRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine machine dependent parameters to control overflow.
!
      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      SCALE = ONE
!
      IF( LSAME( NORMIN, 'N' ) ) THEN
!
!        Compute the 1-norm of each column, not including the diagonal.
!
         IF( UPPER ) THEN
!
!           A is upper triangular.
!
            DO 10 J = 1, N
               CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
   10       CONTINUE
         ELSE
!
!           A is lower triangular.
!
            DO 20 J = 1, N - 1
               CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
   20       CONTINUE
            CNORM( N ) = ZERO
         END IF
      END IF
!
!     Scale the column norms by TSCAL if the maximum element in CNORM is
!     greater than BIGNUM.
!
      IMAX = IDAMAX( N, CNORM, 1 )
      TMAX = CNORM( IMAX )
      IF( TMAX.LE.BIGNUM ) THEN
         TSCAL = ONE
      ELSE
         TSCAL = ONE / ( SMLNUM*TMAX )
         CALL DSCAL( N, TSCAL, CNORM, 1 )
      END IF
!
!     Compute a bound on the computed solution vector to see if the
!     Level 2 BLAS routine DTRSV can be used.
!
      J = IDAMAX( N, X, 1 )
      XMAX = ABS( X( J ) )
      XBND = XMAX
      IF( NOTRAN ) THEN
!
!        Compute the growth in A * x = b.
!
         IF( UPPER ) THEN
            JFIRST = N
            JLAST = 1
            JINC = -1
         ELSE
            JFIRST = 1
            JLAST = N
            JINC = 1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 50
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, G(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 30 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              M(j) = G(j-1) / abs(A(j,j))
!
               TJJ = ABS( A( J, J ) )
               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
!
!                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
!
                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
               ELSE
!
!                 G(j) could overflow, set GROW to 0.
!
                  GROW = ZERO
               END IF
   30       CONTINUE
            GROW = XBND
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 40 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 50
!
!              G(j) = G(j-1)*( 1 + CNORM(j) )
!
               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
   40       CONTINUE
         END IF
   50    CONTINUE
!
      ELSE
!
!        Compute the growth in A' * x = b.
!
         IF( UPPER ) THEN
            JFIRST = 1
            JLAST = N
            JINC = 1
         ELSE
            JFIRST = N
            JLAST = 1
            JINC = -1
         END IF
!
         IF( TSCAL.NE.ONE ) THEN
            GROW = ZERO
            GO TO 80
         END IF
!
         IF( NOUNIT ) THEN
!
!           A is non-unit triangular.
!
!           Compute GROW = 1/G(j) and XBND = 1/M(j).
!           Initially, M(0) = max{x(i), i=1,...,n}.
!
            GROW = ONE / MAX( XBND, SMLNUM )
            XBND = GROW
            DO 60 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
!
               XJ = ONE + CNORM( J )
               GROW = MIN( GROW, XBND / XJ )
!
!              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
!
               TJJ = ABS( A( J, J ) )
               IF( XJ.GT.TJJ ) &
                  XBND = XBND*( TJJ / XJ )
   60       CONTINUE
            GROW = MIN( GROW, XBND )
         ELSE
!
!           A is unit triangular.
!
!           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
!
            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
            DO 70 J = JFIRST, JLAST, JINC
!
!              Exit the loop if the growth factor is too small.
!
               IF( GROW.LE.SMLNUM ) &
                  GO TO 80
!
!              G(j) = ( 1 + CNORM(j) )*G(j-1)
!
               XJ = ONE + CNORM( J )
               GROW = GROW / XJ
   70       CONTINUE
         END IF
   80    CONTINUE
      END IF
!
      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
!
!        Use the Level 2 BLAS solve if the reciprocal of the bound on
!        elements of X is not too small.
!
         CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
      ELSE
!
!        Use a Level 1 BLAS solve, scaling intermediate results.
!
         IF( XMAX.GT.BIGNUM ) THEN
!
!           Scale X so that its components are less than or equal to
!           BIGNUM in absolute value.
!
            SCALE = BIGNUM / XMAX
            CALL DSCAL( N, SCALE, X, 1 )
            XMAX = BIGNUM
         END IF
!
         IF( NOTRAN ) THEN
!
!           Solve A * x = b
!
            DO 110 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
!
               XJ = ABS( X( J ) )
               IF( NOUNIT ) THEN
                  TJJS = A( J, J )*TSCAL
               ELSE
                  TJJS = TSCAL
                  IF( TSCAL.EQ.ONE ) &
                     GO TO 100
               END IF
               TJJ = ABS( TJJS )
               IF( TJJ.GT.SMLNUM ) THEN
!
!                    abs(A(j,j)) > SMLNUM:
!
                  IF( TJJ.LT.ONE ) THEN
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by 1/b(j).
!
                        REC = ONE / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE IF( TJJ.GT.ZERO ) THEN
!
!                    0 < abs(A(j,j)) <= SMLNUM:
!
                  IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
!                       to avoid overflow when dividing by A(j,j).
!
                     REC = ( TJJ*BIGNUM ) / XJ
                     IF( CNORM( J ).GT.ONE ) THEN
!
!                          Scale by 1/CNORM(j) to avoid overflow when
!                          multiplying x(j) times column j.
!
                        REC = REC / CNORM( J )
                     END IF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
                  X( J ) = X( J ) / TJJS
                  XJ = ABS( X( J ) )
               ELSE
!
!                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                    scale = 0, and compute a solution to A*x = 0.
!
                  DO 90 I = 1, N
                     X( I ) = ZERO
   90             CONTINUE
                  X( J ) = ONE
                  XJ = ONE
                  SCALE = ZERO
                  XMAX = ZERO
               END IF
  100          CONTINUE
!
!              Scale x if necessary to avoid overflow when adding a
!              multiple of column j of A.
!
               IF( XJ.GT.ONE ) THEN
                  REC = ONE / XJ
                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
!
!                    Scale x by 1/(2*abs(x(j))).
!
                     REC = REC*HALF
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                  END IF
               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
!
!                 Scale x by 1/2.
!
                  CALL DSCAL( N, HALF, X, 1 )
                  SCALE = SCALE*HALF
               END IF
!
               IF( UPPER ) THEN
                  IF( J.GT.1 ) THEN
!
!                    Compute the update
!                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
!
                     CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, &
                                 1 )
                     I = IDAMAX( J-1, X, 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               ELSE
                  IF( J.LT.N ) THEN
!
!                    Compute the update
!                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
!
                     CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, &
                                 X( J+1 ), 1 )
                     I = J + IDAMAX( N-J, X( J+1 ), 1 )
                     XMAX = ABS( X( I ) )
                  END IF
               END IF
  110       CONTINUE
!
         ELSE
!
!           Solve A' * x = b
!
            DO 160 J = JFIRST, JLAST, JINC
!
!              Compute x(j) = b(j) - sum A(k,j)*x(k).
!                                    k<>j
!
               XJ = ABS( X( J ) )
               USCAL = TSCAL
               REC = ONE / MAX( XMAX, ONE )
               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
!
!                 If x(j) could overflow, scale x by 1/(2*XMAX).
!
                  REC = REC*HALF
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                  END IF
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.ONE ) THEN
!
!                       Divide by A(j,j) when scaling x if A(j,j) > 1.
!
                     REC = MIN( ONE, REC*TJJ )
                     USCAL = USCAL / TJJS
                  END IF
                  IF( REC.LT.ONE ) THEN
                     CALL DSCAL( N, REC, X, 1 )
                     SCALE = SCALE*REC
                     XMAX = XMAX*REC
                  END IF
               END IF
!
               SUMJ = ZERO
               IF( USCAL.EQ.ONE ) THEN
!
!                 If the scaling needed for A in the dot product is 1,
!                 call DDOT to perform the dot product.
!
                  IF( UPPER ) THEN
                     SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
                  ELSE IF( J.LT.N ) THEN
                     SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
                  END IF
               ELSE
!
!                 Otherwise, use in-line code for the dot product.
!
                  IF( UPPER ) THEN
                     DO 120 I = 1, J - 1
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  120                CONTINUE
                  ELSE IF( J.LT.N ) THEN
                     DO 130 I = J + 1, N
                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
  130                CONTINUE
                  END IF
               END IF
!
               IF( USCAL.EQ.TSCAL ) THEN
!
!                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
!                 was not used to scale the dotproduct.
!
                  X( J ) = X( J ) - SUMJ
                  XJ = ABS( X( J ) )
                  IF( NOUNIT ) THEN
                     TJJS = A( J, J )*TSCAL
                  ELSE
                     TJJS = TSCAL
                     IF( TSCAL.EQ.ONE ) &
                        GO TO 150
                  END IF
!
!                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
!
                  TJJ = ABS( TJJS )
                  IF( TJJ.GT.SMLNUM ) THEN
!
!                       abs(A(j,j)) > SMLNUM:
!
                     IF( TJJ.LT.ONE ) THEN
                        IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                             Scale X by 1/abs(x(j)).
!
                           REC = ONE / XJ
                           CALL DSCAL( N, REC, X, 1 )
                           SCALE = SCALE*REC
                           XMAX = XMAX*REC
                        END IF
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE IF( TJJ.GT.ZERO ) THEN
!
!                       0 < abs(A(j,j)) <= SMLNUM:
!
                     IF( XJ.GT.TJJ*BIGNUM ) THEN
!
!                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
!
                        REC = ( TJJ*BIGNUM ) / XJ
                        CALL DSCAL( N, REC, X, 1 )
                        SCALE = SCALE*REC
                        XMAX = XMAX*REC
                     END IF
                     X( J ) = X( J ) / TJJS
                  ELSE
!
!                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
!                       scale = 0, and compute a solution to A'*x = 0.
!
                     DO 140 I = 1, N
                        X( I ) = ZERO
  140                CONTINUE
                     X( J ) = ONE
                     SCALE = ZERO
                     XMAX = ZERO
                  END IF
  150             CONTINUE
               ELSE
!
!                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
!                 product has already been divided by 1/A(j,j).
!
                  X( J ) = X( J ) / TJJS - SUMJ
               END IF
               XMAX = MAX( XMAX, ABS( X( J ) ) )
  160       CONTINUE
         END IF
         SCALE = SCALE / TSCAL
      END IF
!
!     Scale the column norms by 1/TSCAL for return.
!
      IF( TSCAL.NE.ONE ) THEN
         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
      END IF
!
      RETURN
!
!     End of DLATRS
!
      END
      SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            L, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
!  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means
!  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal
!  matrix and, R and A1 are M-by-M upper triangular matrices.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  L       (input) INTEGER
!          The number of columns of the matrix A containing the
!          meaningful part of the Householder vectors. N-M >= L >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the leading M-by-N upper trapezoidal part of the
!          array A must contain the matrix to be factorized.
!          On exit, the leading M-by-M upper triangular part of A
!          contains the upper triangular matrix R, and elements N-L+1 to
!          N of the first M rows of A, with the array TAU, represent the
!          orthogonal matrix Z as a product of M elementary reflectors.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (M)
!          The scalar factors of the elementary reflectors.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  The factorization is obtained by Householder's method.  The kth
!  transformation matrix, Z( k ), which is used to introduce zeros into
!  the ( m - k + 1 )th row of A, is given in the form
!
!     Z( k ) = ( I     0   ),
!              ( 0  T( k ) )
!
!  where
!
!     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
!                                                 (   0    )
!                                                 ( z( k ) )
!
!  tau is a scalar and z( k ) is an l element vector. tau and z( k )
!  are chosen to annihilate the elements of the kth row of A2.
!
!  The scalar tau is returned in the kth element of TAU and the vector
!  u( k ) in the kth row of A2, such that the elements of z( k ) are
!  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
!  the upper triangular part of A1.
!
!  Z is given by
!
!     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFG, DLARZ
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
!     Quick return if possible
!
      IF( M.EQ.0 ) THEN
         RETURN
      ELSE IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      DO 20 I = M, 1, -1
!
!        Generate elementary reflector H(i) to annihilate
!        [ A(i,i) A(i,n-l+1:n) ]
!
         CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
!
!        Apply H(i) to A(1:i-1,i:n) from the right
!
         CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA, &
                     TAU( I ), A( 1, I ), LDA, WORK )
!
   20 CONTINUE
!
      RETURN
!
!     End of DLATRZ
!
      END
      SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      DOUBLE PRECISION   TAU
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DORMRZ.
!
!  DLATZM applies a Householder matrix generated by DTZRQF to a matrix.
!
!  Let P = I - tau*u*u',   u = ( 1 ),
!                              ( v )
!  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
!  SIDE = 'R'.
!
!  If SIDE equals 'L', let
!         C = [ C1 ] 1
!             [ C2 ] m-1
!               n
!  Then C is overwritten by P*C.
!
!  If SIDE equals 'R', let
!         C = [ C1, C2 ] m
!                1  n-1
!  Then C is overwritten by C*P.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': form P * C
!          = 'R': form C * P
!
!  M       (input) INTEGER
!          The number of rows of the matrix C.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C.
!
!  V       (input) DOUBLE PRECISION array, dimension
!                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'
!                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'
!          The vector v in the representation of P. V is not used
!          if TAU = 0.
!
!  INCV    (input) INTEGER
!          The increment between elements of v. INCV <> 0
!
!  TAU     (input) DOUBLE PRECISION
!          The value tau in the representation of P.
!
!  C1      (input/output) DOUBLE PRECISION array, dimension
!                         (LDC,N) if SIDE = 'L'
!                         (M,1)   if SIDE = 'R'
!          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
!          if SIDE = 'R'.
!
!          On exit, the first row of P*C if SIDE = 'L', or the first
!          column of C*P if SIDE = 'R'.
!
!  C2      (input/output) DOUBLE PRECISION array, dimension
!                         (LDC, N)   if SIDE = 'L'
!                         (LDC, N-1) if SIDE = 'R'
!          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
!          m x (n - 1) matrix C2 if SIDE = 'R'.
!
!          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
!          if SIDE = 'R'.
!
!  LDC     (input) INTEGER
!          The leading dimension of the arrays C1 and C2. LDC >= (1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                      (N) if SIDE = 'L'
!                      (M) if SIDE = 'R'
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
      IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) &
         RETURN
!
      IF( LSAME( SIDE, 'L' ) ) THEN
!
!        w := C1 + v' * C2
!
         CALL DCOPY( N, C1, LDC, WORK, 1 )
         CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, &
                     WORK, 1 )
!
!        [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
!        [ C2 ]    [ C2 ]        [ v ]
!
         CALL DAXPY( N, -TAU, WORK, 1, C1, LDC )
         CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
!
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
!
!        w := C1 + C2 * v
!
         CALL DCOPY( M, C1, 1, WORK, 1 )
         CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, &
                     WORK, 1 )
!
!        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
!
         CALL DAXPY( M, -TAU, WORK, 1, C1, 1 )
         CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
      END IF
!
      RETURN
!
!     End of DLATZM
!
      END
      SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAUU2 computes the product U * U' or L' * L, where the triangular
!  factor U or L is stored in the upper or lower triangular part of
!  the array A.
!
!  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!  overwriting the factor U in A.
!  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!  overwriting the factor L in A.
!
!  This is the unblocked form of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the triangular factor stored in the array A
!          is upper or lower triangular:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the triangular factor U or L.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the triangular factor U or L.
!          On exit, if UPLO = 'U', the upper triangle of A is
!          overwritten with the upper triangle of the product U * U';
!          if UPLO = 'L', the lower triangle of A is overwritten with
!          the lower triangle of the product L' * L.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAUU2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Compute the product U * U'.
!
         DO 10 I = 1, N
            AII = A( I, I )
            IF( I.LT.N ) THEN
               A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
               CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), &
                           LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
            ELSE
               CALL DSCAL( I, AII, A( 1, I ), 1 )
            END IF
   10    CONTINUE
!
      ELSE
!
!        Compute the product L' * L.
!
         DO 20 I = 1, N
            AII = A( I, I )
            IF( I.LT.N ) THEN
               A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
               CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, &
                           A( I+1, I ), 1, AII, A( I, 1 ), LDA )
            ELSE
               CALL DSCAL( I, AII, A( I, 1 ), LDA )
            END IF
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DLAUU2
!
      END
      SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLAUUM computes the product U * U' or L' * L, where the triangular
!  factor U or L is stored in the upper or lower triangular part of
!  the array A.
!
!  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!  overwriting the factor U in A.
!  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!  overwriting the factor L in A.
!
!  This is the blocked form of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the triangular factor stored in the array A
!          is upper or lower triangular:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the triangular factor U or L.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the triangular factor U or L.
!          On exit, if UPLO = 'U', the upper triangle of A is
!          overwritten with the upper triangle of the product U * U';
!          if UPLO = 'L', the lower triangle of A is overwritten with
!          the lower triangle of the product L' * L.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IB, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLAUUM', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 )
!
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
!
!        Use unblocked code
!
         CALL DLAUU2( UPLO, N, A, LDA, INFO )
      ELSE
!
!        Use blocked code
!
         IF( UPPER ) THEN
!
!           Compute the product U * U'.
!
            DO 10 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', &
                           I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), &
                           LDA )
               CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
               IF( I+IB.LE.N ) THEN
                  CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, &
                              N-I-IB+1, ONE, A( 1, I+IB ), LDA, &
                              A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
                  CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, &
                              ONE, A( I, I+IB ), LDA, ONE, A( I, I ), &
                              LDA )
               END IF
   10       CONTINUE
         ELSE
!
!           Compute the product L' * L.
!
            DO 20 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
               CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, &
                           I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
               CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
               IF( I+IB.LE.N ) THEN
                  CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, &
                              N-I-IB+1, ONE, A( I+IB, I ), LDA, &
                              A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
                  CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, &
                              A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
               END IF
   20       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DLAUUM
!
      END
subroutine dmat_print ( m, n, a, title )
!
!*******************************************************************************
!
!! DMAT_PRINT prints a double precision matrix.
!
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer M, the number of rows in A.
!
!    Input, integer N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title to be printed.
!
  implicit none
!
  integer m
  integer n
!
  real ( kind = 8 ) a(m,n)
  integer i
  integer j
  integer jhi
  integer jlo
  character ( len = * ) title
!
  call dmat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine dmat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )
!
!*******************************************************************************
!
!! DMAT_PRINT_SOME prints some of a double precision matrix.
!
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ILO, JLO, the first row and column to print.
!
!    Input, integer IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, an optional title.
!
  implicit none
!
  integer, parameter :: incx = 5
  integer m
  integer n
!
  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer i
  integer i2hi
  integer i2lo
  integer ihi
  integer ilo
  integer inc
  integer j
  integer j2
  integer j2hi
  integer j2lo
  integer jhi
  integer jlo
  logical d_is_int
  character ( len = * ) title
!
  if ( 0 < len_trim ( title ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  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), '(i7,7x)') 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 ( d_is_int ( a(i,j) ) ) 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

  write ( *, '(a)' ) ' '

  return
end

      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDQ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DOPGTR generates a real orthogonal matrix Q which is defined as the
!  product of n-1 elementary reflectors H(i) of order n, as returned by
!  DSPTRD using packed storage:
!
!  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!
!  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U': Upper triangular packed storage used in previous
!                 call to DSPTRD;
!          = 'L': Lower triangular packed storage used in previous
!                 call to DSPTRD.
!
!  N       (input) INTEGER
!          The order of the matrix Q. N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The vectors which define the elementary reflectors, as
!          returned by DSPTRD.
!
!  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DSPTRD.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
!          The N-by-N orthogonal matrix Q.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, IJ, J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORG2L, DORG2R, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DOPGTR', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Q was determined by a call to DSPTRD with UPLO = 'U'
!
!        Unpack the vectors which define the elementary reflectors and
!        set the last row and column of Q equal to those of the unit
!        matrix
!
         IJ = 2
         DO 20 J = 1, N - 1
            DO 10 I = 1, J - 1
               Q( I, J ) = AP( IJ )
               IJ = IJ + 1
   10       CONTINUE
            IJ = IJ + 2
            Q( N, J ) = ZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            Q( I, N ) = ZERO
   30    CONTINUE
         Q( N, N ) = ONE
!
!        Generate Q(1:n-1,1:n-1)
!
         CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
!
      ELSE
!
!        Q was determined by a call to DSPTRD with UPLO = 'L'.
!
!        Unpack the vectors which define the elementary reflectors and
!        set the first row and column of Q equal to those of the unit
!        matrix
!
         Q( 1, 1 ) = ONE
         DO 40 I = 2, N
            Q( I, 1 ) = ZERO
   40    CONTINUE
         IJ = 3
         DO 60 J = 2, N
            Q( 1, J ) = ZERO
            DO 50 I = J + 1, N
               Q( I, J ) = AP( IJ )
               IJ = IJ + 1
   50       CONTINUE
            IJ = IJ + 2
   60    CONTINUE
         IF( N.GT.1 ) THEN
!
!           Generate Q(2:n,2:n)
!
            CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, &
                         IINFO )
         END IF
      END IF
      RETURN
!
!     End of DOPGTR
!
      END
      SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, UPLO
      INTEGER            INFO, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DOPMTR overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix of order nq, with nq = m if
!  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!  nq-1 elementary reflectors, as returned by DSPTRD using packed
!  storage:
!
!  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!
!  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  UPLO    (input) CHARACTER*1
!          = 'U': Upper triangular packed storage used in previous
!                 call to DSPTRD;
!          = 'L': Lower triangular packed storage used in previous
!                 call to DSPTRD.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension
!                               (M*(M+1)/2) if SIDE = 'L'
!                               (N*(N+1)/2) if SIDE = 'R'
!          The vectors which define the elementary reflectors, as
!          returned by DSPTRD.  AP is modified by the routine but
!          restored on exit.
!
!  TAU     (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'
!                                     or (N-1) if SIDE = 'R'
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DSPTRD.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L'
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FORWRD, LEFT, NOTRAN, UPPER
      INTEGER            I, I1, I2, I3, IC, II, JC, MI, NI, NQ
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      UPPER = LSAME( UPLO, 'U' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DOPMTR', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Q was determined by a call to DSPTRD with UPLO = 'U'
!
         FORWRD = ( LEFT .AND. NOTRAN ) .OR. &
                  ( .NOT.LEFT .AND. .NOT.NOTRAN )
!
         IF( FORWRD ) THEN
            I1 = 1
            I2 = NQ - 1
            I3 = 1
            II = 2
         ELSE
            I1 = NQ - 1
            I2 = 1
            I3 = -1
            II = NQ*( NQ+1 ) / 2 - 1
         END IF
!
         IF( LEFT ) THEN
            NI = N
         ELSE
            MI = M
         END IF
!
         DO 10 I = I1, I2, I3
            IF( LEFT ) THEN
!
!              H(i) is applied to C(1:i,1:n)
!
               MI = I
            ELSE
!
!              H(i) is applied to C(1:m,1:i)
!
               NI = I
            END IF
!
!           Apply H(i)
!
            AII = AP( II )
            AP( II ) = ONE
            CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, &
                        WORK )
            AP( II ) = AII
!
            IF( FORWRD ) THEN
               II = II + I + 2
            ELSE
               II = II - I - 1
            END IF
   10    CONTINUE
      ELSE
!
!        Q was determined by a call to DSPTRD with UPLO = 'L'.
!
         FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. &
                  ( .NOT.LEFT .AND. NOTRAN )
!
         IF( FORWRD ) THEN
            I1 = 1
            I2 = NQ - 1
            I3 = 1
            II = 2
         ELSE
            I1 = NQ - 1
            I2 = 1
            I3 = -1
            II = NQ*( NQ+1 ) / 2 - 1
         END IF
!
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
!
         DO 20 I = I1, I2, I3
            AII = AP( II )
            AP( II ) = ONE
            IF( LEFT ) THEN
!
!              H(i) is applied to C(i+1:m,1:n)
!
               MI = M - I
               IC = I + 1
            ELSE
!
!              H(i) is applied to C(1:m,i+1:n)
!
               NI = N - I
               JC = I + 1
            END IF
!
!           Apply H(i)
!
            CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), &
                        C( IC, JC ), LDC, WORK )
            AP( II ) = AII
!
            IF( FORWRD ) THEN
               II = II + NQ - I + 1
            ELSE
               II = II - NQ + I - 2
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DOPMTR
!
      END
      SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORG2L generates an m by n real matrix Q with orthonormal columns,
!  which is defined as the last n columns of a product of k elementary
!  reflectors of order m
!
!        Q  =  H(k) . . . H(2) H(1)
!
!  as returned by DGEQLF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. M >= N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. N >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the (n-k+i)-th column must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGEQLF in the last k columns of its array
!          argument A.
!          On exit, the m by n matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQLF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, II, J, L
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORG2L', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
!     Initialise columns 1:n-k to columns of the unit matrix
!
      DO 20 J = 1, N - K
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( M-N+J, J ) = ONE
   20 CONTINUE
!
      DO 40 I = 1, K
         II = N - K + I
!
!        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
!
         A( M-N+II, II ) = ONE
         CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, &
                     LDA, WORK )
         CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
         A( M-N+II, II ) = ONE - TAU( I )
!
!        Set A(m-k+i+1:m,n-k+i) to zero
!
         DO 30 L = M - N + II + 1, M
            A( L, II ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
!
!     End of DORG2L
!
      END
      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORG2R generates an m by n real matrix Q with orthonormal columns,
!  which is defined as the first n columns of a product of k elementary
!  reflectors of order m
!
!        Q  =  H(1) H(2) . . . H(k)
!
!  as returned by DGEQRF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. M >= N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. N >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the i-th column must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGEQRF in the first k columns of its array
!          argument A.
!          On exit, the m-by-n matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQRF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, L
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORG2R', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
!     Initialise columns k+1:n to columns of the unit matrix
!
      DO 20 J = K + 1, N
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( J, J ) = ONE
   20 CONTINUE
!
      DO 40 I = K, 1, -1
!
!        Apply H(i) to A(i:m,i:n) from the left
!
         IF( I.LT.N ) THEN
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), &
                        A( I, I+1 ), LDA, WORK )
         END IF
         IF( I.LT.M ) &
            CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
         A( I, I ) = ONE - TAU( I )
!
!        Set A(1:i-1,i) to zero
!
         DO 30 L = 1, I - 1
            A( L, I ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
!
!     End of DORG2R
!
      END
      SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          VECT
      INTEGER            INFO, K, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGBR generates one of the real orthogonal matrices Q or P**T
!  determined by DGEBRD when reducing a real matrix A to bidiagonal
!  form: A = Q * B * P**T.  Q and P**T are defined as products of
!  elementary reflectors H(i) or G(i) respectively.
!
!  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
!  is of order M:
!  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
!  columns of Q, where m >= n >= k;
!  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
!  M-by-M matrix.
!
!  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
!  is of order N:
!  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
!  rows of P**T, where n >= m >= k;
!  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
!  an N-by-N matrix.
!
!  Arguments
!  =========
!
!  VECT    (input) CHARACTER*1
!          Specifies whether the matrix Q or the matrix P**T is
!          required, as defined in the transformation applied by DGEBRD:
!          = 'Q':  generate Q;
!          = 'P':  generate P**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q or P**T to be returned.
!          M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q or P**T to be returned.
!          N >= 0.
!          If VECT = 'Q', M >= N >= min(M,K);
!          if VECT = 'P', N >= M >= min(N,K).
!
!  K       (input) INTEGER
!          If VECT = 'Q', the number of columns in the original M-by-K
!          matrix reduced by DGEBRD.
!          If VECT = 'P', the number of rows in the original K-by-N
!          matrix reduced by DGEBRD.
!          K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the vectors which define the elementary reflectors,
!          as returned by DGEBRD.
!          On exit, the M-by-N matrix Q or P**T.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension
!                                (min(M,K)) if VECT = 'Q'
!                                (min(N,K)) if VECT = 'P'
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i) or G(i), which determines Q or P**T, as
!          returned by DGEBRD in its array argument TAUQ or TAUP.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
!          For optimum performance LWORK >= min(M,N)*NB, where NB
!          is the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, WANTQ
      INTEGER            I, IINFO, J, LWKOPT, MN, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORGLQ, DORGQR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      WANTQ = LSAME( VECT, 'Q' )
      MN = MIN( M, N )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, &
               K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. &
               MIN( N, K ) ) ) ) THEN
         INFO = -3
      ELSE IF( K.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
         INFO = -9
      END IF
!
      IF( INFO.EQ.0 ) THEN
         IF( WANTQ ) THEN
            NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
         ELSE
            NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
         END IF
         LWKOPT = MAX( 1, MN )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGBR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( WANTQ ) THEN
!
!        Form Q, determined by a call to DGEBRD to reduce an m-by-k
!        matrix
!
         IF( M.GE.K ) THEN
!
!           If m >= k, assume m >= n >= k
!
            CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
!
         ELSE
!
!           If m < k, assume m = n
!
!           Shift the vectors which define the elementary reflectors one
!           column to the right, and set the first row and column of Q
!           to those of the unit matrix
!
            DO 20 J = M, 2, -1
               A( 1, J ) = ZERO
               DO 10 I = J + 1, M
                  A( I, J ) = A( I, J-1 )
   10          CONTINUE
   20       CONTINUE
            A( 1, 1 ) = ONE
            DO 30 I = 2, M
               A( I, 1 ) = ZERO
   30       CONTINUE
            IF( M.GT.1 ) THEN
!
!              Form Q(2:m,2:m)
!
               CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, &
                            LWORK, IINFO )
            END IF
         END IF
      ELSE
!
!        Form P', determined by a call to DGEBRD to reduce a k-by-n
!        matrix
!
         IF( K.LT.N ) THEN
!
!           If k < n, assume k <= m <= n
!
            CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
!
         ELSE
!
!           If k >= n, assume m = n
!
!           Shift the vectors which define the elementary reflectors one
!           row downward, and set the first row and column of P' to
!           those of the unit matrix
!
            A( 1, 1 ) = ONE
            DO 40 I = 2, N
               A( I, 1 ) = ZERO
   40       CONTINUE
            DO 60 J = 2, N
               DO 50 I = J - 1, 2, -1
                  A( I, J ) = A( I-1, J )
   50          CONTINUE
               A( 1, J ) = ZERO
   60       CONTINUE
            IF( N.GT.1 ) THEN
!
!              Form P'(2:n,2:n)
!
               CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, &
                            LWORK, IINFO )
            END IF
         END IF
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORGBR
!
      END
      SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGHR generates a real orthogonal matrix Q which is defined as the
!  product of IHI-ILO elementary reflectors of order N, as returned by
!  DGEHRD:
!
!  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix Q. N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          ILO and IHI must have the same values as in the previous call
!          of DGEHRD. Q is equal to the unit matrix except in the
!          submatrix Q(ilo+1:ihi,ilo+1:ihi).
!          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the vectors which define the elementary reflectors,
!          as returned by DGEHRD.
!          On exit, the N-by-N orthogonal matrix Q.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEHRD.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= IHI-ILO.
!          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IINFO, J, LWKOPT, NB, NH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORGQR, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NH = IHI - ILO
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 )
         LWKOPT = MAX( 1, NH )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGHR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Shift the vectors which define the elementary reflectors one
!     column to the right, and set the first ilo and the last n-ihi
!     rows and columns to those of the unit matrix
!
      DO 40 J = IHI, ILO + 1, -1
         DO 10 I = 1, J - 1
            A( I, J ) = ZERO
   10    CONTINUE
         DO 20 I = J + 1, IHI
            A( I, J ) = A( I, J-1 )
   20    CONTINUE
         DO 30 I = IHI + 1, N
            A( I, J ) = ZERO
   30    CONTINUE
   40 CONTINUE
      DO 60 J = 1, ILO
         DO 50 I = 1, N
            A( I, J ) = ZERO
   50    CONTINUE
         A( J, J ) = ONE
   60 CONTINUE
      DO 80 J = IHI + 1, N
         DO 70 I = 1, N
            A( I, J ) = ZERO
   70    CONTINUE
         A( J, J ) = ONE
   80 CONTINUE
!
      IF( NH.GT.0 ) THEN
!
!        Generate Q(ilo+1:ihi,ilo+1:ihi)
!
         CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), &
                      WORK, LWORK, IINFO )
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORGHR
!
      END
      SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGL2 generates an m by n real matrix Q with orthonormal rows,
!  which is defined as the first m rows of a product of k elementary
!  reflectors of order n
!
!        Q  =  H(k) . . . H(2) H(1)
!
!  as returned by DGELQF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. N >= M.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. M >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the i-th row must contain the vector which defines
!          the elementary reflector H(i), for i = 1,2,...,k, as returned
!          by DGELQF in the first k rows of its array argument A.
!          On exit, the m-by-n matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGELQF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, L
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGL2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.LE.0 ) &
         RETURN
!
      IF( K.LT.M ) THEN
!
!        Initialise rows k+1:m to rows of the unit matrix
!
         DO 20 J = 1, N
            DO 10 L = K + 1, M
               A( L, J ) = ZERO
   10       CONTINUE
            IF( J.GT.K .AND. J.LE.M ) &
               A( J, J ) = ONE
   20    CONTINUE
      END IF
!
      DO 40 I = K, 1, -1
!
!        Apply H(i) to A(i:m,i:n) from the right
!
         IF( I.LT.N ) THEN
            IF( I.LT.M ) THEN
               A( I, I ) = ONE
               CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, &
                           TAU( I ), A( I+1, I ), LDA, WORK )
            END IF
            CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
         END IF
         A( I, I ) = ONE - TAU( I )
!
!        Set A(i,1:i-1) to zero
!
         DO 30 L = 1, I - 1
            A( I, L ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
!
!     End of DORGL2
!
      END
      SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
!  which is defined as the first M rows of a product of K elementary
!  reflectors of order N
!
!        Q  =  H(k) . . . H(2) H(1)
!
!  as returned by DGELQF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. N >= M.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. M >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the i-th row must contain the vector which defines
!          the elementary reflector H(i), for i = 1,2,...,k, as returned
!          by DGELQF in the first k rows of its array argument A.
!          On exit, the M-by-N matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGELQF.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,M).
!          For optimum performance LWORK >= M*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, &
                         LWKOPT, NB, NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORGL2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
      LWKOPT = MAX( 1, M )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGLQ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code after the last block.
!        The first kk rows are handled by the block method.
!
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
!
!        Set A(kk+1:m,1:kk) to zero.
!
         DO 20 J = 1, KK
            DO 10 I = KK + 1, M
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
!
!     Use unblocked code for the last or only block.
!
      IF( KK.LT.M ) &
         CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, &
                      TAU( KK+1 ), WORK, IINFO )
!
      IF( KK.GT.0 ) THEN
!
!        Use blocked code
!
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.M ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), &
                            LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H' to A(i+ib:m,i:n) from the right
!
               CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', &
                            M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, &
                            LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), &
                            LDWORK )
            END IF
!
!           Apply H' to columns i:n of current block
!
            CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, &
                         IINFO )
!
!           Set columns 1:i-1 of current block to zero
!
            DO 40 J = 1, I - 1
               DO 30 L = I, I + IB - 1
                  A( L, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
      END IF
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DORGLQ
!
      END
      SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGQL generates an M-by-N real matrix Q with orthonormal columns,
!  which is defined as the last N columns of a product of K elementary
!  reflectors of order M
!
!        Q  =  H(k) . . . H(2) H(1)
!
!  as returned by DGEQLF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. M >= N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. N >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the (n-k+i)-th column must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGEQLF in the last k columns of its array
!          argument A.
!          On exit, the M-by-N matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQLF.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N).
!          For optimum performance LWORK >= N*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, &
                         NB, NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORG2L, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
      LWKOPT = MAX( 1, N )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGQL', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code after the first block.
!        The last kk columns are handled by the block method.
!
         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
!
!        Set A(m-kk+1:m,1:n-kk) to zero.
!
         DO 20 J = 1, N - KK
            DO 10 I = M - KK + 1, M
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
!
!     Use unblocked code for the first or only block.
!
      CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
!
      IF( KK.GT.0 ) THEN
!
!        Use blocked code
!
         DO 50 I = K - KK + 1, K, NB
            IB = MIN( NB, K-I+1 )
            IF( N-K+I.GT.1 ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i+ib-1) . . . H(i+1) H(i)
!
               CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, &
                            A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
!
               CALL DLARFB( 'Left', 'No transpose', 'Backward', &
                            'Columnwise', M-K+I+IB-1, N-K+I-1, IB, &
                            A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, &
                            WORK( IB+1 ), LDWORK )
            END IF
!
!           Apply H to rows 1:m-k+i+ib-1 of current block
!
            CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, &
                         TAU( I ), WORK, IINFO )
!
!           Set rows m-k+i+ib:m of current block to zero
!
            DO 40 J = N - K + I, N - K + I + IB - 1
               DO 30 L = M - K + I + IB, M
                  A( L, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
      END IF
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DORGQL
!
      END
      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGQR generates an M-by-N real matrix Q with orthonormal columns,
!  which is defined as the first N columns of a product of K elementary
!  reflectors of order M
!
!        Q  =  H(1) H(2) . . . H(k)
!
!  as returned by DGEQRF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. M >= N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. N >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the i-th column must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGEQRF in the first k columns of its array
!          argument A.
!          On exit, the M-by-N matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQRF.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N).
!          For optimum performance LWORK >= N*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, &
                         LWKOPT, NB, NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORG2R, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
      LWKOPT = MAX( 1, N )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGQR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code after the last block.
!        The first kk columns are handled by the block method.
!
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
!
!        Set A(1:kk,kk+1:n) to zero.
!
         DO 20 J = KK + 1, N
            DO 10 I = 1, KK
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
!
!     Use unblocked code for the last or only block.
!
      IF( KK.LT.N ) &
         CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, &
                      TAU( KK+1 ), WORK, IINFO )
!
      IF( KK.GT.0 ) THEN
!
!        Use blocked code
!
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.N ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i) H(i+1) . . . H(i+ib-1)
!
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, &
                            A( I, I ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H to A(i:m,i+ib:n) from the left
!
               CALL DLARFB( 'Left', 'No transpose', 'Forward', &
                            'Columnwise', M-I+1, N-I-IB+1, IB, &
                            A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), &
                            LDA, WORK( IB+1 ), LDWORK )
            END IF
!
!           Apply H to rows i:m of current block
!
            CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, &
                         IINFO )
!
!           Set rows 1:i-1 of current block to zero
!
            DO 40 J = I, I + IB - 1
               DO 30 L = 1, I - 1
                  A( L, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
      END IF
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DORGQR
!
      END
      SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGR2 generates an m by n real matrix Q with orthonormal rows,
!  which is defined as the last m rows of a product of k elementary
!  reflectors of order n
!
!        Q  =  H(1) H(2) . . . H(k)
!
!  as returned by DGERQF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. N >= M.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. M >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the (m-k+i)-th row must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGERQF in the last k rows of its array argument
!          A.
!          On exit, the m by n matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGERQF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, II, J, L
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGR2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.LE.0 ) &
         RETURN
!
      IF( K.LT.M ) THEN
!
!        Initialise rows 1:m-k to rows of the unit matrix
!
         DO 20 J = 1, N
            DO 10 L = 1, M - K
               A( L, J ) = ZERO
   10       CONTINUE
            IF( J.GT.N-M .AND. J.LE.N-K ) &
               A( M-N+J, J ) = ONE
   20    CONTINUE
      END IF
!
      DO 40 I = 1, K
         II = M - K + I
!
!        Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
!
         A( II, N-M+II ) = ONE
         CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), &
                     A, LDA, WORK )
         CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
         A( II, N-M+II ) = ONE - TAU( I )
!
!        Set A(m-k+i,n-k+i+1:n) to zero
!
         DO 30 L = N - M + II + 1, N
            A( II, L ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
!
!     End of DORGR2
!
      END
      SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGRQ generates an M-by-N real matrix Q with orthonormal rows,
!  which is defined as the last M rows of a product of K elementary
!  reflectors of order N
!
!        Q  =  H(1) H(2) . . . H(k)
!
!  as returned by DGERQF.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix Q. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix Q. N >= M.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines the
!          matrix Q. M >= K >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the (m-k+i)-th row must contain the vector which
!          defines the elementary reflector H(i), for i = 1,2,...,k, as
!          returned by DGERQF in the last k rows of its array argument
!          A.
!          On exit, the M-by-N matrix Q.
!
!  LDA     (input) INTEGER
!          The first dimension of the array A. LDA >= max(1,M).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGERQF.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,M).
!          For optimum performance LWORK >= M*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument has an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, II, IINFO, IWS, J, KK, L, LDWORK, &
                         LWKOPT, NB, NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORGR2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 )
      LWKOPT = MAX( 1, M )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGRQ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 0
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGRQ', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
!
!        Use blocked code after the first block.
!        The last kk rows are handled by the block method.
!
         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
!
!        Set A(1:m-kk,n-kk+1:n) to zero.
!
         DO 20 J = N - KK + 1, N
            DO 10 I = 1, M - KK
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
!
!     Use unblocked code for the first or only block.
!
      CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
!
      IF( KK.GT.0 ) THEN
!
!        Use blocked code
!
         DO 50 I = K - KK + 1, K, NB
            IB = MIN( NB, K-I+1 )
            II = M - K + I
            IF( II.GT.1 ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i+ib-1) . . . H(i+1) H(i)
!
               CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB, &
                            A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
!
               CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise', &
                            II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK, &
                            LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
            END IF
!
!           Apply H' to columns 1:n-k+i+ib-1 of current block
!
            CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ), &
                         WORK, IINFO )
!
!           Set columns n-k+i+ib:n of current block to zero
!
            DO 40 L = N - K + I + IB, N
               DO 30 J = II, II + IB - 1
                  A( J, L ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
      END IF
!
      WORK( 1 ) = IWS
      RETURN
!
!     End of DORGRQ
!
      END
      SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORGTR generates a real orthogonal matrix Q which is defined as the
!  product of n-1 elementary reflectors of order N, as returned by
!  DSYTRD:
!
!  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!
!  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U': Upper triangle of A contains elementary reflectors
!                 from DSYTRD;
!          = 'L': Lower triangle of A contains elementary reflectors
!                 from DSYTRD.
!
!  N       (input) INTEGER
!          The order of the matrix Q. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the vectors which define the elementary reflectors,
!          as returned by DSYTRD.
!          On exit, the N-by-N orthogonal matrix Q.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DSYTRD.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= max(1,N-1).
!          For optimum performance LWORK >= (N-1)*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER
      INTEGER            I, IINFO, J, LWKOPT, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORGQL, DORGQR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
!
      IF( INFO.EQ.0 ) THEN
         IF( UPPER ) THEN
            NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
         ELSE
            NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
         END IF
         LWKOPT = MAX( 1, N-1 )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGTR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( UPPER ) THEN
!
!        Q was determined by a call to DSYTRD with UPLO = 'U'
!
!        Shift the vectors which define the elementary reflectors one
!        column to the left, and set the last row and column of Q to
!        those of the unit matrix
!
         DO 20 J = 1, N - 1
            DO 10 I = 1, J - 1
               A( I, J ) = A( I, J+1 )
   10       CONTINUE
            A( N, J ) = ZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            A( I, N ) = ZERO
   30    CONTINUE
         A( N, N ) = ONE
!
!        Generate Q(1:n-1,1:n-1)
!
         CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
!
      ELSE
!
!        Q was determined by a call to DSYTRD with UPLO = 'L'.
!
!        Shift the vectors which define the elementary reflectors one
!        column to the right, and set the first row and column of Q to
!        those of the unit matrix
!
         DO 50 J = N, 2, -1
            A( 1, J ) = ZERO
            DO 40 I = J + 1, N
               A( I, J ) = A( I, J-1 )
   40       CONTINUE
   50    CONTINUE
         A( 1, 1 ) = ONE
         DO 60 I = 2, N
            A( I, 1 ) = ZERO
   60    CONTINUE
         IF( N.GT.1 ) THEN
!
!           Generate Q(2:n,2:n)
!
            CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, &
                         LWORK, IINFO )
         END IF
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORGTR
!
      END
      SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORM2L overwrites the general real m by n matrix C with
!
!        Q * C  if SIDE = 'L' and TRANS = 'N', or
!
!        Q'* C  if SIDE = 'L' and TRANS = 'T', or
!
!        C * Q  if SIDE = 'R' and TRANS = 'N', or
!
!        C * Q' if SIDE = 'R' and TRANS = 'T',
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(k) . . . H(2) H(1)
!
!  as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q' from the Left
!          = 'R': apply Q or Q' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply Q  (No transpose)
!          = 'T': apply Q' (Transpose)
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
!          The i-th column must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGEQLF in the last k columns of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          If SIDE = 'L', LDA >= max(1,M);
!          if SIDE = 'R', LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQLF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L',
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, MI, NI, NQ
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORM2L', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) &
         RETURN
!
      IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) &
           THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
!
      IF( LEFT ) THEN
         NI = N
      ELSE
         MI = M
      END IF
!
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
!
!           H(i) is applied to C(1:m-k+i,1:n)
!
            MI = M - K + I
         ELSE
!
!           H(i) is applied to C(1:m,1:n-k+i)
!
            NI = N - K + I
         END IF
!
!        Apply H(i)
!
         AII = A( NQ-K+I, I )
         A( NQ-K+I, I ) = ONE
         CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, &
                     WORK )
         A( NQ-K+I, I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DORM2L
!
      END
      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORM2R overwrites the general real m by n matrix C with
!
!        Q * C  if SIDE = 'L' and TRANS = 'N', or
!
!        Q'* C  if SIDE = 'L' and TRANS = 'T', or
!
!        C * Q  if SIDE = 'R' and TRANS = 'N', or
!
!        C * Q' if SIDE = 'R' and TRANS = 'T',
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q' from the Left
!          = 'R': apply Q or Q' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply Q  (No transpose)
!          = 'T': apply Q' (Transpose)
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
!          The i-th column must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGEQRF in the first k columns of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          If SIDE = 'L', LDA >= max(1,M);
!          if SIDE = 'R', LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQRF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L',
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORM2R', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) &
         RETURN
!
      IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) &
           THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
!
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
!
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
!
!           H(i) is applied to C(i:m,1:n)
!
            MI = M - I + 1
            IC = I
         ELSE
!
!           H(i) is applied to C(1:m,i:n)
!
            NI = N - I + 1
            JC = I
         END IF
!
!        Apply H(i)
!
         AII = A( I, I )
         A( I, I ) = ONE
         CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), &
                     LDC, WORK )
         A( I, I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DORM2R
!
      END
      SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, &
                         LDC, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, VECT
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
!  with
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
!  with
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      P * C          C * P
!  TRANS = 'T':      P**T * C       C * P**T
!
!  Here Q and P**T are the orthogonal matrices determined by DGEBRD when
!  reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
!  P**T are defined as products of elementary reflectors H(i) and G(i)
!  respectively.
!
!  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
!  order of the orthogonal matrix Q or P**T that is applied.
!
!  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
!  if nq >= k, Q = H(1) H(2) . . . H(k);
!  if nq < k, Q = H(1) H(2) . . . H(nq-1).
!
!  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
!  if k < nq, P = G(1) G(2) . . . G(k);
!  if k >= nq, P = G(1) G(2) . . . G(nq-1).
!
!  Arguments
!  =========
!
!  VECT    (input) CHARACTER*1
!          = 'Q': apply Q or Q**T;
!          = 'P': apply P or P**T.
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q, Q**T, P or P**T from the Left;
!          = 'R': apply Q, Q**T, P or P**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q  or P;
!          = 'T':  Transpose, apply Q**T or P**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          If VECT = 'Q', the number of columns in the original
!          matrix reduced by DGEBRD.
!          If VECT = 'P', the number of rows in the original
!          matrix reduced by DGEBRD.
!          K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                                (LDA,min(nq,K)) if VECT = 'Q'
!                                (LDA,nq)        if VECT = 'P'
!          The vectors which define the elementary reflectors H(i) and
!          G(i), whose products determine the matrices Q and P, as
!          returned by DGEBRD.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          If VECT = 'Q', LDA >= max(1,nq);
!          if VECT = 'P', LDA >= max(1,min(nq,K)).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (min(nq,K))
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i) or G(i) which determines Q or P, as returned
!          by DGEBRD in the array argument TAUQ or TAUP.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
!          or P*C or P**T*C or C*P or C*P**T.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN
      CHARACTER          TRANST
      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORMLQ, DORMQR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      APPLYQ = LSAME( VECT, 'Q' )
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q or P and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( K.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. &
               ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) &
                THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
         IF( APPLYQ ) THEN
            IF( LEFT ) THEN
               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, &
                    -1 )
            ELSE
               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, &
                    -1 )
            END IF
         ELSE
            IF( LEFT ) THEN
               NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, &
                    -1 )
            ELSE
               NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, &
                    -1 )
            END IF
         END IF
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMBR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      WORK( 1 ) = 1
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
      IF( APPLYQ ) THEN
!
!        Apply Q
!
         IF( NQ.GE.K ) THEN
!
!           Q was determined by a call to DGEBRD with nq >= k
!
            CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
!
!           Q was determined by a call to DGEBRD with nq < k
!
            IF( LEFT ) THEN
               MI = M - 1
               NI = N
               I1 = 2
               I2 = 1
            ELSE
               MI = M
               NI = N - 1
               I1 = 1
               I2 = 2
            END IF
            CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, &
                         C( I1, I2 ), LDC, WORK, LWORK, IINFO )
         END IF
      ELSE
!
!        Apply P
!
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
         IF( NQ.GT.K ) THEN
!
!           P was determined by a call to DGEBRD with nq > k
!
            CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, IINFO )
         ELSE IF( NQ.GT.1 ) THEN
!
!           P was determined by a call to DGEBRD with nq <= k
!
            IF( LEFT ) THEN
               MI = M - 1
               NI = N
               I1 = 2
               I2 = 1
            ELSE
               MI = M
               NI = N - 1
               I1 = 1
               I2 = 2
            END IF
            CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, &
                         TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
         END IF
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMBR
!
      END
      SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, &
                         LDC, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            IHI, ILO, INFO, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMHR overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix of order nq, with nq = m if
!  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!  IHI-ILO elementary reflectors, as returned by DGEHRD:
!
!  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  ILO     (input) INTEGER
!  IHI     (input) INTEGER
!          ILO and IHI must have the same values as in the previous call
!          of DGEHRD. Q is equal to the unit matrix except in the
!          submatrix Q(ilo+1:ihi,ilo+1:ihi).
!          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
!          ILO = 1 and IHI = 0, if M = 0;
!          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
!          ILO = 1 and IHI = 0, if N = 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L'
!                               (LDA,N) if SIDE = 'R'
!          The vectors which define the elementary reflectors, as
!          returned by DGEHRD.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
!
!  TAU     (input) DOUBLE PRECISION array, dimension
!                               (M-1) if SIDE = 'L'
!                               (N-1) if SIDE = 'R'
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEHRD.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY
      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORMQR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      NH = IHI - ILO
      LEFT = LSAME( SIDE, 'L' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) &
                THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
         INFO = -5
      ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
         IF( LEFT ) THEN
            NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 )
         ELSE
            NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 )
         END IF
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMHR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( LEFT ) THEN
         MI = NH
         NI = N
         I1 = ILO + 1
         I2 = 1
      ELSE
         MI = M
         NI = NH
         I1 = 1
         I2 = ILO + 1
      END IF
!
      CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, &
                   TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
!
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMHR
!
      END
      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORML2 overwrites the general real m by n matrix C with
!
!        Q * C  if SIDE = 'L' and TRANS = 'N', or
!
!        Q'* C  if SIDE = 'L' and TRANS = 'T', or
!
!        C * Q  if SIDE = 'R' and TRANS = 'N', or
!
!        C * Q' if SIDE = 'R' and TRANS = 'T',
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(k) . . . H(2) H(1)
!
!  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q' from the Left
!          = 'R': apply Q or Q' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply Q  (No transpose)
!          = 'T': apply Q' (Transpose)
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGELQF in the first k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGELQF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L',
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORML2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) &
         RETURN
!
      IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) &
           THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
!
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
!
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
!
!           H(i) is applied to C(i:m,1:n)
!
            MI = M - I + 1
            IC = I
         ELSE
!
!           H(i) is applied to C(1:m,i:n)
!
            NI = N - I + 1
            JC = I
         END IF
!
!        Apply H(i)
!
         AII = A( I, I )
         A( I, I ) = ONE
         CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), &
                     C( IC, JC ), LDC, WORK )
         A( I, I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DORML2
!
      END
      SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMLQ overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(k) . . . H(2) H(1)
!
!  as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGELQF in the first k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGELQF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, NOTRAN
      CHARACTER          TRANST
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, &
                         LWKOPT, MI, NB, NBMIN, NI, NQ, NW
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORML2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.  NB may be at most NBMAX, where NBMAX
!        is used to define the local array T.
!
         NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, &
              -1 ) )
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMLQ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, &
                    -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
!
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
!
!        Use unblocked code
!
         CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, &
                      IINFO )
      ELSE
!
!        Use blocked code
!
         IF( ( LEFT .AND. NOTRAN ) .OR. &
             ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
!
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
!
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
!
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
!
!           Form the triangular factor of the block reflector
!           H = H(i) H(i+1) . . . H(i+ib-1)
!
            CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), &
                         LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
!
!              H or H' is applied to C(i:m,1:n)
!
               MI = M - I + 1
               IC = I
            ELSE
!
!              H or H' is applied to C(1:m,i:n)
!
               NI = N - I + 1
               JC = I
            END IF
!
!           Apply H or H'
!
            CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, &
                         A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, &
                         LDWORK )
   10    CONTINUE
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMLQ
!
      END
      SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMQL overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(k) . . . H(2) H(1)
!
!  as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
!          The i-th column must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGEQLF in the last k columns of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          If SIDE = 'L', LDA >= max(1,M);
!          if SIDE = 'R', LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQLF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, NOTRAN
      INTEGER            I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, &
                         MI, NB, NBMIN, NI, NQ, NW
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORM2L, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.  NB may be at most NBMAX, where NBMAX
!        is used to define the local array T.
!
         NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K, &
              -1 ) )
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMQL', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, &
                    -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
!
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
!
!        Use unblocked code
!
         CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, &
                      IINFO )
      ELSE
!
!        Use blocked code
!
         IF( ( LEFT .AND. NOTRAN ) .OR. &
             ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
!
         IF( LEFT ) THEN
            NI = N
         ELSE
            MI = M
         END IF
!
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
!
!           Form the triangular factor of the block reflector
!           H = H(i+ib-1) . . . H(i+1) H(i)
!
            CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, &
                         A( 1, I ), LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
!
!              H or H' is applied to C(1:m-k+i+ib-1,1:n)
!
               MI = M - K + I + IB - 1
            ELSE
!
!              H or H' is applied to C(1:m,1:n-k+i+ib-1)
!
               NI = N - K + I + IB - 1
            END IF
!
!           Apply H or H'
!
            CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, &
                         IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, &
                         LDWORK )
   10    CONTINUE
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMQL
!
      END
      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMQR overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
!          The i-th column must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGEQRF in the first k columns of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          If SIDE = 'L', LDA >= max(1,M);
!          if SIDE = 'R', LDA >= max(1,N).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGEQRF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, NOTRAN
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, &
                         LWKOPT, MI, NB, NBMIN, NI, NQ, NW
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORM2R, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.  NB may be at most NBMAX, where NBMAX
!        is used to define the local array T.
!
         NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, &
              -1 ) )
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMQR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, &
                    -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
!
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
!
!        Use unblocked code
!
         CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, &
                      IINFO )
      ELSE
!
!        Use blocked code
!
         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. &
             ( .NOT.LEFT .AND. NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
!
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
!
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
!
!           Form the triangular factor of the block reflector
!           H = H(i) H(i+1) . . . H(i+ib-1)
!
            CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), &
                         LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
!
!              H or H' is applied to C(i:m,1:n)
!
               MI = M - I + 1
               IC = I
            ELSE
!
!              H or H' is applied to C(1:m,i:n)
!
               NI = N - I + 1
               JC = I
            END IF
!
!           Apply H or H'
!
            CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, &
                         IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, &
                         WORK, LDWORK )
   10    CONTINUE
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMQR
!
      END
      SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMR2 overwrites the general real m by n matrix C with
!
!        Q * C  if SIDE = 'L' and TRANS = 'N', or
!
!        Q'* C  if SIDE = 'L' and TRANS = 'T', or
!
!        C * Q  if SIDE = 'R' and TRANS = 'N', or
!
!        C * Q' if SIDE = 'R' and TRANS = 'T',
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q' from the Left
!          = 'R': apply Q or Q' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply Q  (No transpose)
!          = 'T': apply Q' (Transpose)
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGERQF in the last k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGERQF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m by n matrix C.
!          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L',
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, MI, NI, NQ
      DOUBLE PRECISION   AII
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMR2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) &
         RETURN
!
      IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) &
           THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
!
      IF( LEFT ) THEN
         NI = N
      ELSE
         MI = M
      END IF
!
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
!
!           H(i) is applied to C(1:m-k+i,1:n)
!
            MI = M - K + I
         ELSE
!
!           H(i) is applied to C(1:m,1:n-k+i)
!
            NI = N - K + I
         END IF
!
!        Apply H(i)
!
         AII = A( I, NQ-K+I )
         A( I, NQ-K+I ) = ONE
         CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, &
                     WORK )
         A( I, NQ-K+I ) = AII
   10 CONTINUE
      RETURN
!
!     End of DORMR2
!
      END
      SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, L, LDA, LDC, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMR3 overwrites the general real m by n matrix C with
!
!        Q * C  if SIDE = 'L' and TRANS = 'N', or
!
!        Q'* C  if SIDE = 'L' and TRANS = 'T', or
!
!        C * Q  if SIDE = 'R' and TRANS = 'N', or
!
!        C * Q' if SIDE = 'R' and TRANS = 'T',
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q' from the Left
!          = 'R': apply Q or Q' from the Right
!
!  TRANS   (input) CHARACTER*1
!          = 'N': apply Q  (No transpose)
!          = 'T': apply Q' (Transpose)
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  L       (input) INTEGER
!          The number of columns of the matrix A containing
!          the meaningful part of the Householder reflectors.
!          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DTZRZF in the last k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DTZRZF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the m-by-n matrix C.
!          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension
!                                   (N) if SIDE = 'L',
!                                   (M) if SIDE = 'R'
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARZ, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
!
!     NQ is the order of Q
!
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. &
               ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMR3', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) &
         RETURN
!
      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
!
      IF( LEFT ) THEN
         NI = N
         JA = M - L + 1
         JC = 1
      ELSE
         MI = M
         JA = N - L + 1
         IC = 1
      END IF
!
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
!
!           H(i) or H(i)' is applied to C(i:m,1:n)
!
            MI = M - I + 1
            IC = I
         ELSE
!
!           H(i) or H(i)' is applied to C(1:m,i:n)
!
            NI = N - I + 1
            JC = I
         END IF
!
!        Apply H(i) or H(i)'
!
         CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ), &
                     C( IC, JC ), LDC, WORK )
!
   10 CONTINUE
!
      RETURN
!
!     End of DORMR3
!
      END
      SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMRQ overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DGERQF in the last k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DGERQF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, NOTRAN
      CHARACTER          TRANST
      INTEGER            I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, &
                         MI, NB, NBMIN, NI, NQ, NW
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORMR2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.  NB may be at most NBMAX, where NBMAX
!        is used to define the local array T.
!
         NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, K, &
              -1 ) )
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMRQ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, &
                    -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
!
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
!
!        Use unblocked code
!
         CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, &
                      IINFO )
      ELSE
!
!        Use blocked code
!
         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. &
             ( .NOT.LEFT .AND. NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
!
         IF( LEFT ) THEN
            NI = N
         ELSE
            MI = M
         END IF
!
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
!
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
!
!           Form the triangular factor of the block reflector
!           H = H(i+ib-1) . . . H(i+1) H(i)
!
            CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB, &
                         A( I, 1 ), LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
!
!              H or H' is applied to C(1:m-k+i+ib-1,1:n)
!
               MI = M - K + I + IB - 1
            ELSE
!
!              H or H' is applied to C(1:m,1:n-k+i+ib-1)
!
               NI = N - K + I + IB - 1
            END IF
!
!           Apply H or H'
!
            CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, &
                         IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK, &
                         LDWORK )
   10    CONTINUE
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMRQ
!
      END
      SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, L, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMRZ overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix defined as the product of k
!  elementary reflectors
!
!        Q = H(1) H(2) . . . H(k)
!
!  as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
!  if SIDE = 'R'.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  K       (input) INTEGER
!          The number of elementary reflectors whose product defines
!          the matrix Q.
!          If SIDE = 'L', M >= K >= 0;
!          if SIDE = 'R', N >= K >= 0.
!
!  L       (input) INTEGER
!          The number of columns of the matrix A containing
!          the meaningful part of the Householder reflectors.
!          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L',
!                               (LDA,N) if SIDE = 'R'
!          The i-th row must contain the vector which defines the
!          elementary reflector H(i), for i = 1,2,...,k, as returned by
!          DTZRZF in the last k rows of its array argument A.
!          A is modified by the routine but restored on exit.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,K).
!
!  TAU     (input) DOUBLE PRECISION array, dimension (K)
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DTZRZF.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, NOTRAN
      CHARACTER          TRANST
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC, &
                         LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARZB, DLARZT, DORMR3, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR. &
               ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.  NB may be at most NBMAX, where NBMAX
!        is used to define the local array T.
!
         NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N, K, &
              -1 ) )
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMRZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K, &
                    -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
!
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
!
!        Use unblocked code
!
         CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, &
                      WORK, IINFO )
      ELSE
!
!        Use blocked code
!
         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. &
             ( .NOT.LEFT .AND. NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
!
         IF( LEFT ) THEN
            NI = N
            JC = 1
            JA = M - L + 1
         ELSE
            MI = M
            IC = 1
            JA = N - L + 1
         END IF
!
         IF( NOTRAN ) THEN
            TRANST = 'T'
         ELSE
            TRANST = 'N'
         END IF
!
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
!
!           Form the triangular factor of the block reflector
!           H = H(i+ib-1) . . . H(i+1) H(i)
!
            CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA, &
                         TAU( I ), T, LDT )
!
            IF( LEFT ) THEN
!
!              H or H' is applied to C(i:m,1:n)
!
               MI = M - I + 1
               IC = I
            ELSE
!
!              H or H' is applied to C(1:m,i:n)
!
               NI = N - I + 1
               JC = I
            END IF
!
!           Apply H or H'
!
            CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI, &
                         IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ), &
                         LDC, WORK, LDWORK )
   10    CONTINUE
!
      END IF
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DORMRZ
!
      END
      SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, &
                         WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, UPLO
      INTEGER            INFO, LDA, LDC, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DORMTR overwrites the general real M-by-N matrix C with
!
!                  SIDE = 'L'     SIDE = 'R'
!  TRANS = 'N':      Q * C          C * Q
!  TRANS = 'T':      Q**T * C       C * Q**T
!
!  where Q is a real orthogonal matrix of order nq, with nq = m if
!  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!  nq-1 elementary reflectors, as returned by DSYTRD:
!
!  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!
!  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'L': apply Q or Q**T from the Left;
!          = 'R': apply Q or Q**T from the Right.
!
!  UPLO    (input) CHARACTER*1
!          = 'U': Upper triangle of A contains elementary reflectors
!                 from DSYTRD;
!          = 'L': Lower triangle of A contains elementary reflectors
!                 from DSYTRD.
!
!  TRANS   (input) CHARACTER*1
!          = 'N':  No transpose, apply Q;
!          = 'T':  Transpose, apply Q**T.
!
!  M       (input) INTEGER
!          The number of rows of the matrix C. M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix C. N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension
!                               (LDA,M) if SIDE = 'L'
!                               (LDA,N) if SIDE = 'R'
!          The vectors which define the elementary reflectors, as
!          returned by DSYTRD.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
!
!  TAU     (input) DOUBLE PRECISION array, dimension
!                               (M-1) if SIDE = 'L'
!                               (N-1) if SIDE = 'R'
!          TAU(i) must contain the scalar factor of the elementary
!          reflector H(i), as returned by DSYTRD.
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N matrix C.
!          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If SIDE = 'L', LWORK >= max(1,N);
!          if SIDE = 'R', LWORK >= max(1,M).
!          For optimum performance LWORK >= N*NB if SIDE = 'L', and
!          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
!          blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LEFT, LQUERY, UPPER
      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DORMQL, DORMQR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 )
!
!     NQ is the order of Q and NW is the minimum dimension of WORK
!
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) &
                THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
         INFO = -12
      END IF
!
      IF( INFO.EQ.0 ) THEN
         IF( UPPER ) THEN
            IF( LEFT ) THEN
               NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, &
                    -1 )
            ELSE
               NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, &
                    -1 )
            END IF
         ELSE
            IF( LEFT ) THEN
               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, &
                    -1 )
            ELSE
               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, &
                    -1 )
            END IF
         END IF
         LWKOPT = MAX( 1, NW )*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMTR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( LEFT ) THEN
         MI = M - 1
         NI = N
      ELSE
         MI = M
         NI = N - 1
      END IF
!
      IF( UPPER ) THEN
!
!        Q was determined by a call to DSYTRD with UPLO = 'U'
!
         CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, &
                      LDC, WORK, LWORK, IINFO )
      ELSE
!
!        Q was determined by a call to DSYTRD with UPLO = 'L'
!
         IF( LEFT ) THEN
            I1 = 2
            I2 = 1
         ELSE
            I1 = 1
            I2 = 2
         END IF
         CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, &
                      C( I1, I2 ), LDC, WORK, LWORK, IINFO )
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DORMTR
!
      END
      SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DPBCON estimates the reciprocal of the condition number (in the
!  1-norm) of a real symmetric positive definite band matrix using the
!  Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangular factor stored in AB;
!          = 'L':  Lower triangular factor stored in AB.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T of the band matrix A, stored in the
!          first KD+1 rows of the array.  The j-th column of U or L is
!          stored in the j-th column of the array AB as follows:
!          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm (or infinity-norm) of the symmetric band matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE
      DOUBLE PRECISION   AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATBS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
      SMLNUM = DLAMCH( 'Safe minimum' )
!
!     Estimate the 1-norm of the inverse.
!
      KASE = 0
      NORMIN = 'N'
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( UPPER ) THEN
!
!           Multiply by inv(U').
!
            CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, &
                         KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), &
                         INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(U).
!
            CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, &
                         KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), &
                         INFO )
         ELSE
!
!           Multiply by inv(L).
!
            CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, &
                         KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ), &
                         INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(L').
!
            CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, &
                         KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ), &
                         INFO )
         END IF
!
!        Multiply by 1/SCALE if doing so will not cause overflow.
!
         SCALE = SCALEL*SCALEU
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) &
               GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
   20 CONTINUE
!
      RETURN
!
!     End of DPBCON
!
      END
      SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DPBEQU computes row and column scalings intended to equilibrate a
!  symmetric positive definite band matrix A and reduce its condition
!  number (with respect to the two-norm).  S contains the scale factors,
!  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
!  choice of S puts the condition number of B within a factor N of the
!  smallest possible condition number over all possible diagonal
!  scalings.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangular of A is stored;
!          = 'L':  Lower triangular of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangle of the symmetric band matrix A,
!          stored in the first KD+1 rows of the array.  The j-th column
!          of A is stored in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!  LDAB     (input) INTEGER
!          The leading dimension of the array A.  LDAB >= KD+1.
!
!  S       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, S contains the scale factors for A.
!
!  SCOND   (output) DOUBLE PRECISION
!          If INFO = 0, S contains the ratio of the smallest S(i) to
!          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!          large nor too small, it is not worth scaling by S.
!
!  AMAX    (output) DOUBLE PRECISION
!          Absolute value of largest matrix element.  If AMAX is very
!          close to overflow or very close to underflow, the matrix
!          should be scaled.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, J
      DOUBLE PRECISION   SMIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBEQU', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         RETURN
      END IF
!
      IF( UPPER ) THEN
         J = KD + 1
      ELSE
         J = 1
      END IF
!
!     Initialize SMIN and AMAX.
!
      S( 1 ) = AB( J, 1 )
      SMIN = S( 1 )
      AMAX = S( 1 )
!
!     Find the minimum and maximum diagonal elements.
!
      DO 10 I = 2, N
         S( I ) = AB( J, I )
         SMIN = MIN( SMIN, S( I ) )
         AMAX = MAX( AMAX, S( I ) )
   10 CONTINUE
!
      IF( SMIN.LE.ZERO ) THEN
!
!        Find the first non-positive diagonal element and return.
!
         DO 20 I = 1, N
            IF( S( I ).LE.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   20    CONTINUE
      ELSE
!
!        Set the scale factors to the reciprocals
!        of the diagonal elements.
!
         DO 30 I = 1, N
            S( I ) = ONE / SQRT( S( I ) )
   30    CONTINUE
!
!        Compute SCOND = min(S(I)) / max(S(I))
!
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
      END IF
      RETURN
!
!     End of DPBEQU
!
      END
      SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, &
                         LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric positive definite
!  and banded, and provides error bounds and backward error estimates
!  for the solution.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangle of the symmetric band matrix A,
!          stored in the first KD+1 rows of the array.  The j-th column
!          of A is stored in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T of the band matrix A as computed by
!          DPBTRF, in the same storage format as A (see AB).
!
!  LDAFB   (input) INTEGER
!          The leading dimension of the array AFB.  LDAFB >= KD+1.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DPBTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, J, K, KASE, L, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DPBTRS, DSBMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDAFB.LT.KD+1 ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = MIN( N+1, 2*KD+2 )
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE, &
                     WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(A)*abs(X) + abs(B).
!
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               L = KD + 1 - K
               DO 40 I = MAX( 1, K-KD ), K - 1
                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
               L = 1 - K
               DO 60 I = K + 1, MIN( N, K+KD )
                  WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
                  S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N, &
                         INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(A) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(A').
!
               CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N, &
                            INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( N+I )*WORK( I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
!
!              Multiply by inv(A)*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( N+I )*WORK( I )
  120          CONTINUE
               CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N, &
                            INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DPBRFS
!
      END
      SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBSTF computes a split Cholesky factorization of a real
!  symmetric positive definite band matrix A.
!
!  This routine is designed to be used in conjunction with DSBGST.
!
!  The factorization has the form  A = S**T*S  where S is a band matrix
!  of the same bandwidth as A and the following structure:
!
!    S = ( U    )
!        ( M  L )
!
!  where U is upper triangular of order m = (n+kd)/2, and L is lower
!  triangular of order n-m.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first kd+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, if INFO = 0, the factor S from the split Cholesky
!          factorization A = S**T*S. See Further Details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, the factorization could not be completed,
!               because the updated element a(i,i) was negative; the
!               matrix A is not positive definite.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 7, KD = 2:
!
!  S = ( s11  s12  s13                     )
!      (      s22  s23  s24                )
!      (           s33  s34                )
!      (                s44                )
!      (           s53  s54  s55           )
!      (                s64  s65  s66      )
!      (                     s75  s76  s77 )
!
!  If UPLO = 'U', the array AB holds:
!
!  on entry:                          on exit:
!
!   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75
!   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76
!  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
!
!  If UPLO = 'L', the array AB holds:
!
!  on entry:                          on exit:
!
!  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77
!  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *
!  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *
!
!  Array elements marked * are not used by the routine.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, KLD, KM, M
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSYR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBSTF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      KLD = MAX( 1, LDAB-1 )
!
!     Set the splitting point m.
!
      M = ( N+KD ) / 2
!
      IF( UPPER ) THEN
!
!        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
!
         DO 10 J = N, M + 1, -1
!
!           Compute s(j,j) and test for non-positive-definiteness.
!
            AJJ = AB( KD+1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 50
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
            KM = MIN( J-1, KD )
!
!           Compute elements j-km:j-1 of the j-th column and update the
!           the leading submatrix within the band.
!
            CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
            CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1, &
                       AB( KD+1, J-KM ), KLD )
   10    CONTINUE
!
!        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
!
         DO 20 J = 1, M
!
!           Compute s(j,j) and test for non-positive-definiteness.
!
            AJJ = AB( KD+1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 50
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
            KM = MIN( KD, M-J )
!
!           Compute elements j+1:j+km of the j-th row and update the
!           trailing submatrix within the band.
!
            IF( KM.GT.0 ) THEN
               CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
               CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD, &
                          AB( KD+1, J+1 ), KLD )
            END IF
   20    CONTINUE
      ELSE
!
!        Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
!
         DO 30 J = N, M + 1, -1
!
!           Compute s(j,j) and test for non-positive-definiteness.
!
            AJJ = AB( 1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 50
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
            KM = MIN( J-1, KD )
!
!           Compute elements j-km:j-1 of the j-th row and update the
!           trailing submatrix within the band.
!
            CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
            CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD, &
                       AB( 1, J-KM ), KLD )
   30    CONTINUE
!
!        Factorize the updated submatrix A(1:m,1:m) as U**T*U.
!
         DO 40 J = 1, M
!
!           Compute s(j,j) and test for non-positive-definiteness.
!
            AJJ = AB( 1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 50
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
            KM = MIN( KD, M-J )
!
!           Compute elements j+1:j+km of the j-th column and update the
!           trailing submatrix within the band.
!
            IF( KM.GT.0 ) THEN
               CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
               CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1, &
                          AB( 1, J+1 ), KLD )
            END IF
   40    CONTINUE
      END IF
      RETURN
!
   50 CONTINUE
      INFO = J
      RETURN
!
!     End of DPBSTF
!
      END
      SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBSV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite band matrix and X
!  and B are N-by-NRHS matrices.
!
!  The Cholesky decomposition is used to factor A as
!     A = U**T * U,  if UPLO = 'U', or
!     A = L * L**T,  if UPLO = 'L',
!  where U is an upper triangular band matrix, and L is a lower
!  triangular band matrix, with the same number of superdiagonals or
!  subdiagonals as A.  The factored form of A is then used to solve the
!  system of equations A * X = B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
!          See below for further details.
!
!          On exit, if INFO = 0, the triangular factor U or L from the
!          Cholesky factorization A = U**T*U or A = L*L**T of the band
!          matrix A, in the same storage format as A.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i of A is not
!                positive definite, so the factorization could not be
!                completed, and the solution has not been computed.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 6, KD = 2, and UPLO = 'U':
!
!  On entry:                       On exit:
!
!      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!
!  Similarly, if UPLO = 'L' the format of A is as follows:
!
!  On entry:                       On exit:
!
!     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!
!  Array elements marked * are not used by the routine.
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPBTRF, DPBTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBSV ', -INFO )
         RETURN
      END IF
!
!     Compute the Cholesky factorization A = U'*U or A = L*L'.
!
      CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
!
      END IF
      RETURN
!
!     End of DPBSV
!
      END
      SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, &
                         EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, &
                         WORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, UPLO
      INTEGER            INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), S( * ), WORK( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
!  compute the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite band matrix and X
!  and B are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'E', real scaling factors are computed to equilibrate
!     the system:
!        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
!     Whether or not the system will be equilibrated depends on the
!     scaling of the matrix A, but if equilibration is used, A is
!     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
!
!  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
!     factor the matrix A (after equilibration if FACT = 'E') as
!        A = U**T * U,  if UPLO = 'U', or
!        A = L * L**T,  if UPLO = 'L',
!     where U is an upper triangular band matrix, and L is a lower
!     triangular band matrix.
!
!  3. If the leading i-by-i principal minor is not positive definite,
!     then the routine returns with INFO = i. Otherwise, the factored
!     form of A is used to estimate the condition number of the matrix
!     A.  If the reciprocal of the condition number is less than machine
!     precision, INFO = N+1 is returned as a warning, but the routine
!     still goes on to solve for X and compute error bounds as
!     described below.
!
!  4. The system of equations is solved for X using the factored form
!     of A.
!
!  5. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  6. If equilibration was used, the matrix X is premultiplied by
!     diag(S) so that it solves the original system before
!     equilibration.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of the matrix A is
!          supplied on entry, and if not, whether the matrix A should be
!          equilibrated before it is factored.
!          = 'F':  On entry, AFB contains the factored form of A.
!                  If EQUED = 'Y', the matrix A has been equilibrated
!                  with scaling factors given by S.  AB and AFB will not
!                  be modified.
!          = 'N':  The matrix A will be copied to AFB and factored.
!          = 'E':  The matrix A will be equilibrated if necessary, then
!                  copied to AFB and factored.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right-hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array, except
!          if FACT = 'F' and EQUED = 'Y', then A must contain the
!          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A
!          is stored in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).
!          See below for further details.
!
!          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
!          diag(S)*A*diag(S).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array A.  LDAB >= KD+1.
!
!  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
!          If FACT = 'F', then AFB is an input argument and on entry
!          contains the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T of the band matrix
!          A, in the same storage format as A (see AB).  If EQUED = 'Y',
!          then AFB is the factored form of the equilibrated matrix A.
!
!          If FACT = 'N', then AFB is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T.
!
!          If FACT = 'E', then AFB is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T of the equilibrated
!          matrix A (see the description of A for the form of the
!          equilibrated matrix).
!
!  LDAFB   (input) INTEGER
!          The leading dimension of the array AFB.  LDAFB >= KD+1.
!
!  EQUED   (input or output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration (always true if FACT = 'N').
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!          output argument.
!
!  S       (input or output) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A; not accessed if EQUED = 'N'.  S is
!          an input argument if FACT = 'F'; otherwise, S is an output
!          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
!          must be positive.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
!          B is overwritten by diag(S) * B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
!          the original system of equations.  Note that if EQUED = 'Y',
!          A and B are modified on exit, and the solution to the
!          equilibrated system is inv(diag(S))*X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A after equilibration (if done).  If RCOND is less than the
!          machine precision (in particular, if RCOND = 0), the matrix
!          is singular to working precision.  This condition is
!          indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  the leading minor of order i of A is
!                       not positive definite, so the factorization
!                       could not be completed, and the solution has not
!                       been computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 6, KD = 2, and UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11  a12  a13
!          a22  a23  a24
!               a33  a34  a35
!                    a44  a45  a46
!                         a55  a56
!     (aij=conjg(aji))         a66
!
!  Band storage of the upper triangle of A:
!
!      *    *   a13  a24  a35  a46
!      *   a12  a23  a34  a45  a56
!     a11  a22  a33  a44  a55  a66
!
!  Similarly, if UPLO = 'L' the format of A is as follows:
!
!     a11  a22  a33  a44  a55  a66
!     a21  a32  a43  a54  a65   *
!     a31  a42  a53  a64   *    *
!
!  Array elements marked * are not used by the routine.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            EQUIL, NOFACT, RCEQU, UPPER
      INTEGER            I, INFEQU, J, J1, J2
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSB
      EXTERNAL           LSAME, DLAMCH, DLANSB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS, &
                         DPBTRF, DPBTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      UPPER = LSAME( UPLO, 'U' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         RCEQU = .FALSE.
      ELSE
         RCEQU = LSAME( EQUED, 'Y' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
!
!     Test the input parameters.
!
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KD.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -7
      ELSE IF( LDAFB.LT.KD+1 ) THEN
         INFO = -9
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. &
               ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -10
      ELSE
         IF( RCEQU ) THEN
            SMIN = BIGNUM
            SMAX = ZERO
            DO 10 J = 1, N
               SMIN = MIN( SMIN, S( J ) )
               SMAX = MAX( SMAX, S( J ) )
   10       CONTINUE
            IF( SMIN.LE.ZERO ) THEN
               INFO = -11
            ELSE IF( N.GT.0 ) THEN
               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
            ELSE
               SCOND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -13
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -15
            END IF
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBSVX', -INFO )
         RETURN
      END IF
!
      IF( EQUIL ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
            RCEQU = LSAME( EQUED, 'Y' )
         END IF
      END IF
!
!     Scale the right-hand side.
!
      IF( RCEQU ) THEN
         DO 30 J = 1, NRHS
            DO 20 I = 1, N
               B( I, J ) = S( I )*B( I, J )
   20       CONTINUE
   30    CONTINUE
      END IF
!
      IF( NOFACT .OR. EQUIL ) THEN
!
!        Compute the Cholesky factorization A = U'*U or A = L*L'.
!
         IF( UPPER ) THEN
            DO 40 J = 1, N
               J1 = MAX( J-KD, 1 )
               CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1, &
                           AFB( KD+1-J+J1, J ), 1 )
   40       CONTINUE
         ELSE
            DO 50 J = 1, N
               J2 = MIN( J+KD, N )
               CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
   50       CONTINUE
         END IF
!
         CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK, &
                   INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution matrix X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, &
                   LDX, FERR, BERR, WORK, IWORK, INFO )
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF( RCEQU ) THEN
         DO 70 J = 1, NRHS
            DO 60 I = 1, N
               X( I, J ) = S( I )*X( I, J )
   60       CONTINUE
   70    CONTINUE
         DO 80 J = 1, NRHS
            FERR( J ) = FERR( J ) / SCOND
   80    CONTINUE
      END IF
!
      RETURN
!
!     End of DPBSVX
!
      END
      SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBTF2 computes the Cholesky factorization of a real symmetric
!  positive definite band matrix A.
!
!  The factorization has the form
!     A = U' * U ,  if UPLO = 'U', or
!     A = L  * L',  if UPLO = 'L',
!  where U is an upper triangular matrix, U' is the transpose of U, and
!  L is lower triangular.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of super-diagonals of the matrix A if UPLO = 'U',
!          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, if INFO = 0, the triangular factor U or L from the
!          Cholesky factorization A = U'*U or A = L*L' of the band
!          matrix A, in the same storage format as A.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, the leading minor of order k is not
!               positive definite, and the factorization could not be
!               completed.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 6, KD = 2, and UPLO = 'U':
!
!  On entry:                       On exit:
!
!      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!
!  Similarly, if UPLO = 'L' the format of A is as follows:
!
!  On entry:                       On exit:
!
!     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!
!  Array elements marked * are not used by the routine.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, KLD, KN
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSYR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBTF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      KLD = MAX( 1, LDAB-1 )
!
      IF( UPPER ) THEN
!
!        Compute the Cholesky factorization A = U'*U.
!
         DO 10 J = 1, N
!
!           Compute U(J,J) and test for non-positive-definiteness.
!
            AJJ = AB( KD+1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 30
            AJJ = SQRT( AJJ )
            AB( KD+1, J ) = AJJ
!
!           Compute elements J+1:J+KN of row J and update the
!           trailing submatrix within the band.
!
            KN = MIN( KD, N-J )
            IF( KN.GT.0 ) THEN
               CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
               CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD, &
                          AB( KD+1, J+1 ), KLD )
            END IF
   10    CONTINUE
      ELSE
!
!        Compute the Cholesky factorization A = L*L'.
!
         DO 20 J = 1, N
!
!           Compute L(J,J) and test for non-positive-definiteness.
!
            AJJ = AB( 1, J )
            IF( AJJ.LE.ZERO ) &
               GO TO 30
            AJJ = SQRT( AJJ )
            AB( 1, J ) = AJJ
!
!           Compute elements J+1:J+KN of column J and update the
!           trailing submatrix within the band.
!
            KN = MIN( KD, N-J )
            IF( KN.GT.0 ) THEN
               CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
               CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1, &
                          AB( 1, J+1 ), KLD )
            END IF
   20    CONTINUE
      END IF
      RETURN
!
   30 CONTINUE
      INFO = J
      RETURN
!
!     End of DPBTF2
!
      END
      SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBTRF computes the Cholesky factorization of a real symmetric
!  positive definite band matrix A.
!
!  The factorization has the form
!     A = U**T * U,  if UPLO = 'U', or
!     A = L  * L**T,  if UPLO = 'L',
!  where U is an upper triangular matrix and L is lower triangular.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, if INFO = 0, the triangular factor U or L from the
!          Cholesky factorization A = U**T*U or A = L*L**T of the band
!          matrix A, in the same storage format as A.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i is not
!                positive definite, and the factorization could not be
!                completed.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  N = 6, KD = 2, and UPLO = 'U':
!
!  On entry:                       On exit:
!
!      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!
!  Similarly, if UPLO = 'L' the format of A is as follows:
!
!  On entry:                       On exit:
!
!     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
!     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
!     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
!
!  Array elements marked * are not used by the routine.
!
!  Contributed by
!  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I2, I3, IB, II, J, JJ, NB
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   WORK( LDWORK, NBMAX )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND. &
          ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment
!
      NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 )
!
!     The block size must not exceed the semi-bandwidth KD, and must not
!     exceed the limit set by the size of the local array WORK.
!
      NB = MIN( NB, NBMAX )
!
      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
!
!        Use unblocked code
!
         CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
      ELSE
!
!        Use blocked code
!
         IF( LSAME( UPLO, 'U' ) ) THEN
!
!           Compute the Cholesky factorization of a symmetric band
!           matrix, given the upper triangle of the matrix in band
!           storage.
!
!           Zero the upper triangle of the work array.
!
            DO 20 J = 1, NB
               DO 10 I = 1, J - 1
                  WORK( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
!
!           Process the band matrix one diagonal block at a time.
!
            DO 70 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
!
!              Factorize the diagonal block
!
               CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
               IF( II.NE.0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB.LE.N ) THEN
!
!                 Update the relevant part of the trailing submatrix.
!                 If A11 denotes the diagonal block which has just been
!                 factorized, then we need to update the remaining
!                 blocks in the diagram:
!
!                    A11   A12   A13
!                          A22   A23
!                                A33
!
!                 The numbers of rows and columns in the partitioning
!                 are IB, I2, I3 respectively. The blocks A12, A22 and
!                 A23 are empty if IB = KD. The upper triangle of A13
!                 lies outside the band.
!
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A12
!
                     CALL DTRSM( 'Left', 'Upper', 'Transpose', &
                                 'Non-unit', IB, I2, ONE, AB( KD+1, I ), &
                                 LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
!
!                    Update A22
!
                     CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE, &
                                 AB( KD+1-IB, I+IB ), LDAB-1, ONE, &
                                 AB( KD+1, I+IB ), LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Copy the lower triangle of A13 into the work array.
!
                     DO 40 JJ = 1, I3
                        DO 30 II = JJ, IB
                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
   30                   CONTINUE
   40                CONTINUE
!
!                    Update A13 (in the work array).
!
                     CALL DTRSM( 'Left', 'Upper', 'Transpose', &
                                 'Non-unit', IB, I3, ONE, AB( KD+1, I ), &
                                 LDAB-1, WORK, LDWORK )
!
!                    Update A23
!
                     IF( I2.GT.0 ) &
                        CALL DGEMM( 'Transpose', 'No Transpose', I2, I3, &
                                    IB, -ONE, AB( KD+1-IB, I+IB ), &
                                    LDAB-1, WORK, LDWORK, ONE, &
                                    AB( 1+IB, I+KD ), LDAB-1 )
!
!                    Update A33
!
                     CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE, &
                                 WORK, LDWORK, ONE, AB( KD+1, I+KD ), &
                                 LDAB-1 )
!
!                    Copy the lower triangle of A13 back into place.
!
                     DO 60 JJ = 1, I3
                        DO 50 II = JJ, IB
                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
   50                   CONTINUE
   60                CONTINUE
                  END IF
               END IF
   70       CONTINUE
         ELSE
!
!           Compute the Cholesky factorization of a symmetric band
!           matrix, given the lower triangle of the matrix in band
!           storage.
!
!           Zero the lower triangle of the work array.
!
            DO 90 J = 1, NB
               DO 80 I = J + 1, NB
                  WORK( I, J ) = ZERO
   80          CONTINUE
   90       CONTINUE
!
!           Process the band matrix one diagonal block at a time.
!
            DO 140 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
!
!              Factorize the diagonal block
!
               CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
               IF( II.NE.0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB.LE.N ) THEN
!
!                 Update the relevant part of the trailing submatrix.
!                 If A11 denotes the diagonal block which has just been
!                 factorized, then we need to update the remaining
!                 blocks in the diagram:
!
!                    A11
!                    A21   A22
!                    A31   A32   A33
!
!                 The numbers of rows and columns in the partitioning
!                 are IB, I2, I3 respectively. The blocks A21, A22 and
!                 A32 are empty if IB = KD. The lower triangle of A31
!                 lies outside the band.
!
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A21
!
                     CALL DTRSM( 'Right', 'Lower', 'Transpose', &
                                 'Non-unit', I2, IB, ONE, AB( 1, I ), &
                                 LDAB-1, AB( 1+IB, I ), LDAB-1 )
!
!                    Update A22
!
                     CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE, &
                                 AB( 1+IB, I ), LDAB-1, ONE, &
                                 AB( 1, I+IB ), LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Copy the upper triangle of A31 into the work array.
!
                     DO 110 JJ = 1, IB
                        DO 100 II = 1, MIN( JJ, I3 )
                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
  100                   CONTINUE
  110                CONTINUE
!
!                    Update A31 (in the work array).
!
                     CALL DTRSM( 'Right', 'Lower', 'Transpose', &
                                 'Non-unit', I3, IB, ONE, AB( 1, I ), &
                                 LDAB-1, WORK, LDWORK )
!
!                    Update A32
!
                     IF( I2.GT.0 ) &
                        CALL DGEMM( 'No transpose', 'Transpose', I3, I2, &
                                    IB, -ONE, WORK, LDWORK, &
                                    AB( 1+IB, I ), LDAB-1, ONE, &
                                    AB( 1+KD-IB, I+IB ), LDAB-1 )
!
!                    Update A33
!
                     CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE, &
                                 WORK, LDWORK, ONE, AB( 1, I+KD ), &
                                 LDAB-1 )
!
!                    Copy the upper triangle of A31 back into place.
!
                     DO 130 JJ = 1, IB
                        DO 120 II = 1, MIN( JJ, I3 )
                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
  120                   CONTINUE
  130                CONTINUE
                  END IF
               END IF
  140       CONTINUE
         END IF
      END IF
      RETURN
!
  150 CONTINUE
      RETURN
!
!     End of DPBTRF
!
      END
      SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPBTRS solves a system of linear equations A*X = B with a symmetric
!  positive definite band matrix A using the Cholesky factorization
!  A = U**T*U or A = L*L**T computed by DPBTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangular factor stored in AB;
!          = 'L':  Lower triangular factor stored in AB.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T of the band matrix A, stored in the
!          first KD+1 rows of the array.  The j-th column of U or L is
!          stored in the j-th column of the array AB as follows:
!          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTBSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPBTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Solve A*X = B where A = U'*U.
!
         DO 10 J = 1, NRHS
!
!           Solve U'*X = B, overwriting B with X.
!
            CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB, &
                        LDAB, B( 1, J ), 1 )
!
!           Solve U*X = B, overwriting B with X.
!
            CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB, &
                        LDAB, B( 1, J ), 1 )
   10    CONTINUE
      ELSE
!
!        Solve A*X = B where A = L*L'.
!
         DO 20 J = 1, NRHS
!
!           Solve L*X = B, overwriting B with X.
!
            CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB, &
                        LDAB, B( 1, J ), 1 )
!
!           Solve L'*X = B, overwriting B with X.
!
            CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB, &
                        LDAB, B( 1, J ), 1 )
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DPBTRS
!
      END
      SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DPOCON estimates the reciprocal of the condition number (in the
!  1-norm) of a real symmetric positive definite matrix using the
!  Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, as computed by DPOTRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm (or infinity-norm) of the symmetric matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE
      DOUBLE PRECISION   AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATRS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
      SMLNUM = DLAMCH( 'Safe minimum' )
!
!     Estimate the 1-norm of inv(A).
!
      KASE = 0
      NORMIN = 'N'
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( UPPER ) THEN
!
!           Multiply by inv(U').
!
            CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, &
                         LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(U).
!
            CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, &
                         A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
         ELSE
!
!           Multiply by inv(L).
!
            CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, &
                         A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(L').
!
            CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A, &
                         LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
         END IF
!
!        Multiply by 1/SCALE if doing so will not cause overflow.
!
         SCALE = SCALEL*SCALEU
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) &
               GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
   20 CONTINUE
      RETURN
!
!     End of DPOCON
!
      END
      SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DPOEQU computes row and column scalings intended to equilibrate a
!  symmetric positive definite matrix A and reduce its condition number
!  (with respect to the two-norm).  S contains the scale factors,
!  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
!  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
!  choice of S puts the condition number of B within a factor N of the
!  smallest possible condition number over all possible diagonal
!  scalings.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The N-by-N symmetric positive definite matrix whose scaling
!          factors are to be computed.  Only the diagonal elements of A
!          are referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  S       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, S contains the scale factors for A.
!
!  SCOND   (output) DOUBLE PRECISION
!          If INFO = 0, S contains the ratio of the smallest S(i) to
!          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!          large nor too small, it is not worth scaling by S.
!
!  AMAX    (output) DOUBLE PRECISION
!          Absolute value of largest matrix element.  If AMAX is very
!          close to overflow or very close to underflow, the matrix
!          should be scaled.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   SMIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOEQU', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         RETURN
      END IF
!
!     Find the minimum and maximum diagonal elements.
!
      S( 1 ) = A( 1, 1 )
      SMIN = S( 1 )
      AMAX = S( 1 )
      DO 10 I = 2, N
         S( I ) = A( I, I )
         SMIN = MIN( SMIN, S( I ) )
         AMAX = MAX( AMAX, S( I ) )
   10 CONTINUE
!
      IF( SMIN.LE.ZERO ) THEN
!
!        Find the first non-positive diagonal element and return.
!
         DO 20 I = 1, N
            IF( S( I ).LE.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   20    CONTINUE
      ELSE
!
!        Set the scale factors to the reciprocals
!        of the diagonal elements.
!
         DO 30 I = 1, N
            S( I ) = ONE / SQRT( S( I ) )
   30    CONTINUE
!
!        Compute SCOND = min(S(I)) / max(S(I))
!
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
      END IF
      RETURN
!
!     End of DPOEQU
!
      END
      SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, &
                         LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPORFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric positive definite,
!  and provides error bounds and backward error estimates for the
!  solution.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of A contains the upper triangular part
!          of the matrix A, and the strictly lower triangular part of A
!          is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of A contains the lower triangular part of
!          the matrix A, and the strictly upper triangular part of A is
!          not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, as computed by DPOTRF.
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DPOTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DPOTRS, DSYMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPORFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, &
                     WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(A)*abs(X) + abs(B).
!
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               DO 40 I = 1, K - 1
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
               DO 60 I = K + 1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(A) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(A').
!
               CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
!
!              Multiply by inv(A)*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DPORFS
!
      END
      SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOSV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite matrix and X and B
!  are N-by-NRHS matrices.
!
!  The Cholesky decomposition is used to factor A as
!     A = U**T* U,  if UPLO = 'U', or
!     A = L * L**T,  if UPLO = 'L',
!  where U is an upper triangular matrix and L is a lower triangular
!  matrix.  The factored form of A is then used to solve the system of
!  equations A * X = B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i of A is not
!                positive definite, so the factorization could not be
!                completed, and the solution has not been computed.
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPOTRF, DPOTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOSV ', -INFO )
         RETURN
      END IF
!
!     Compute the Cholesky factorization A = U'*U or A = L*L'.
!
      CALL DPOTRF( UPLO, N, A, LDA, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
!
      END IF
      RETURN
!
!     End of DPOSV
!
      END
      SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, &
                         S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), S( * ), WORK( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
!  compute the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite matrix and X and B
!  are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'E', real scaling factors are computed to equilibrate
!     the system:
!        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
!     Whether or not the system will be equilibrated depends on the
!     scaling of the matrix A, but if equilibration is used, A is
!     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
!
!  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
!     factor the matrix A (after equilibration if FACT = 'E') as
!        A = U**T* U,  if UPLO = 'U', or
!        A = L * L**T,  if UPLO = 'L',
!     where U is an upper triangular matrix and L is a lower triangular
!     matrix.
!
!  3. If the leading i-by-i principal minor is not positive definite,
!     then the routine returns with INFO = i. Otherwise, the factored
!     form of A is used to estimate the condition number of the matrix
!     A.  If the reciprocal of the condition number is less than machine
!     precision, INFO = N+1 is returned as a warning, but the routine
!     still goes on to solve for X and compute error bounds as
!     described below.
!
!  4. The system of equations is solved for X using the factored form
!     of A.
!
!  5. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  6. If equilibration was used, the matrix X is premultiplied by
!     diag(S) so that it solves the original system before
!     equilibration.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of the matrix A is
!          supplied on entry, and if not, whether the matrix A should be
!          equilibrated before it is factored.
!          = 'F':  On entry, AF contains the factored form of A.
!                  If EQUED = 'Y', the matrix A has been equilibrated
!                  with scaling factors given by S.  A and AF will not
!                  be modified.
!          = 'N':  The matrix A will be copied to AF and factored.
!          = 'E':  The matrix A will be equilibrated if necessary, then
!                  copied to AF and factored.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A, except if FACT = 'F' and
!          EQUED = 'Y', then A must contain the equilibrated matrix
!          diag(S)*A*diag(S).  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.  A is not modified if
!          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
!
!          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
!          diag(S)*A*diag(S).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
!          If FACT = 'F', then AF is an input argument and on entry
!          contains the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T, in the same storage
!          format as A.  If EQUED .ne. 'N', then AF is the factored form
!          of the equilibrated matrix diag(S)*A*diag(S).
!
!          If FACT = 'N', then AF is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T of the original
!          matrix A.
!
!          If FACT = 'E', then AF is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T of the equilibrated
!          matrix A (see the description of A for the form of the
!          equilibrated matrix).
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  EQUED   (input or output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration (always true if FACT = 'N').
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!          output argument.
!
!  S       (input or output) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A; not accessed if EQUED = 'N'.  S is
!          an input argument if FACT = 'F'; otherwise, S is an output
!          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
!          must be positive.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
!          B is overwritten by diag(S) * B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
!          the original system of equations.  Note that if EQUED = 'Y',
!          A and B are modified on exit, and the solution to the
!          equilibrated system is inv(diag(S))*X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A after equilibration (if done).  If RCOND is less than the
!          machine precision (in particular, if RCOND = 0), the matrix
!          is singular to working precision.  This condition is
!          indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, and i is
!                <= N:  the leading minor of order i of A is
!                       not positive definite, so the factorization
!                       could not be completed, and the solution has not
!                       been computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            EQUIL, NOFACT, RCEQU
      INTEGER            I, INFEQU, J
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF, &
                         DPOTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         RCEQU = .FALSE.
      ELSE
         RCEQU = LSAME( EQUED, 'Y' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
!
!     Test the input parameters.
!
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. &
               ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -9
      ELSE
         IF( RCEQU ) THEN
            SMIN = BIGNUM
            SMAX = ZERO
            DO 10 J = 1, N
               SMIN = MIN( SMIN, S( J ) )
               SMAX = MAX( SMAX, S( J ) )
   10       CONTINUE
            IF( SMIN.LE.ZERO ) THEN
               INFO = -10
            ELSE IF( N.GT.0 ) THEN
               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
            ELSE
               SCOND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -12
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -14
            END IF
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOSVX', -INFO )
         RETURN
      END IF
!
      IF( EQUIL ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
            RCEQU = LSAME( EQUED, 'Y' )
         END IF
      END IF
!
!     Scale the right hand side.
!
      IF( RCEQU ) THEN
         DO 30 J = 1, NRHS
            DO 20 I = 1, N
               B( I, J ) = S( I )*B( I, J )
   20       CONTINUE
   30    CONTINUE
      END IF
!
      IF( NOFACT .OR. EQUIL ) THEN
!
!        Compute the Cholesky factorization A = U'*U or A = L*L'.
!
         CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
         CALL DPOTRF( UPLO, N, AF, LDAF, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution matrix X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, &
                   FERR, BERR, WORK, IWORK, INFO )
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF( RCEQU ) THEN
         DO 50 J = 1, NRHS
            DO 40 I = 1, N
               X( I, J ) = S( I )*X( I, J )
   40       CONTINUE
   50    CONTINUE
         DO 60 J = 1, NRHS
            FERR( J ) = FERR( J ) / SCOND
   60    CONTINUE
      END IF
!
      RETURN
!
!     End of DPOSVX
!
      END
      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOTF2 computes the Cholesky factorization of a real symmetric
!  positive definite matrix A.
!
!  The factorization has the form
!     A = U' * U ,  if UPLO = 'U', or
!     A = L  * L',  if UPLO = 'L',
!  where U is an upper triangular matrix and L is lower triangular.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n by n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n by n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the factor U or L from the Cholesky
!          factorization A = U'*U  or A = L*L'.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, the leading minor of order k is not
!               positive definite, and the factorization could not be
!               completed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Compute the Cholesky factorization A = U'*U.
!
         DO 10 J = 1, N
!
!           Compute U(J,J) and test for non-positive-definiteness.
!
            AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
            IF( AJJ.LE.ZERO ) THEN
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
!
!           Compute elements J+1:N of row J.
!
            IF( J.LT.N ) THEN
               CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), &
                           LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
               CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
!
!        Compute the Cholesky factorization A = L*L'.
!
         DO 20 J = 1, N
!
!           Compute L(J,J) and test for non-positive-definiteness.
!
            AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), &
                  LDA )
            IF( AJJ.LE.ZERO ) THEN
               A( J, J ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            A( J, J ) = AJJ
!
!           Compute elements J+1:N of column J.
!
            IF( J.LT.N ) THEN
               CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), &
                           LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
               CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
      GO TO 40
!
   30 CONTINUE
      INFO = J
!
   40 CONTINUE
      RETURN
!
!     End of DPOTF2
!
      END
      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOTRF computes the Cholesky factorization of a real symmetric
!  positive definite matrix A.
!
!  The factorization has the form
!     A = U**T * U,  if UPLO = 'U', or
!     A = L  * L**T,  if UPLO = 'L',
!  where U is an upper triangular matrix and L is lower triangular.
!
!  This is the block version of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i is not
!                positive definite, and the factorization could not be
!                completed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JB, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
!
!        Use unblocked code.
!
         CALL DPOTF2( UPLO, N, A, LDA, INFO )
      ELSE
!
!        Use blocked code.
!
         IF( UPPER ) THEN
!
!           Compute the Cholesky factorization A = U'*U.
!
            DO 10 J = 1, N, NB
!
!              Update and factorize the current diagonal block and test
!              for non-positive-definiteness.
!
               JB = MIN( NB, N-J+1 )
               CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, &
                           A( 1, J ), LDA, ONE, A( J, J ), LDA )
               CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 ) &
                  GO TO 30
               IF( J+JB.LE.N ) THEN
!
!                 Compute the current block row.
!
                  CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, &
                              J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), &
                              LDA, ONE, A( J, J+JB ), LDA )
                  CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', &
                              JB, N-J-JB+1, ONE, A( J, J ), LDA, &
                              A( J, J+JB ), LDA )
               END IF
   10       CONTINUE
!
         ELSE
!
!           Compute the Cholesky factorization A = L*L'.
!
            DO 20 J = 1, N, NB
!
!              Update and factorize the current diagonal block and test
!              for non-positive-definiteness.
!
               JB = MIN( NB, N-J+1 )
               CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, &
                           A( J, 1 ), LDA, ONE, A( J, J ), LDA )
               CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
               IF( INFO.NE.0 ) &
                  GO TO 30
               IF( J+JB.LE.N ) THEN
!
!                 Compute the current block column.
!
                  CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, &
                              J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), &
                              LDA, ONE, A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', &
                              N-J-JB+1, JB, ONE, A( J, J ), LDA, &
                              A( J+JB, J ), LDA )
               END IF
   20       CONTINUE
         END IF
      END IF
      GO TO 40
!
   30 CONTINUE
      INFO = INFO + J - 1
!
   40 CONTINUE
      RETURN
!
!     End of DPOTRF
!
      END
      SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOTRI computes the inverse of a real symmetric positive definite
!  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!  computed by DPOTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T, as computed by
!          DPOTRF.
!          On exit, the upper or lower triangle of the (symmetric)
!          inverse of A, overwriting the input factor U or L.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the (i,i) element of the factor U or L is
!                zero, and the inverse could not be computed.
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAUUM, DTRTRI, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRI', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Invert the triangular Cholesky factor U or L.
!
      CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 ) &
         RETURN
!
!     Form inv(U)*inv(U)' or inv(L)'*inv(L).
!
      CALL DLAUUM( UPLO, N, A, LDA, INFO )
!
      RETURN
!
!     End of DPOTRI
!
      END
      SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPOTRS solves a system of linear equations A*X = B with a symmetric
!  positive definite matrix A using the Cholesky factorization
!  A = U**T*U or A = L*L**T computed by DPOTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, as computed by DPOTRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Solve A*X = B where A = U'*U.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, &
                     ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, &
                     NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A*X = B where A = L*L'.
!
!        Solve L*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, &
                     NRHS, ONE, A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, &
                     ONE, A, LDA, B, LDB )
      END IF
!
      RETURN
!
!     End of DPOTRS
!
      END
      SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DPPCON estimates the reciprocal of the condition number (in the
!  1-norm) of a real symmetric positive definite packed matrix using
!  the Cholesky factorization A = U**T*U or A = L*L**T computed by
!  DPPTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, packed columnwise in a linear
!          array.  The j-th column of U or L is stored in the array AP
!          as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm (or infinity-norm) of the symmetric matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE
      DOUBLE PRECISION   AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATPS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
      SMLNUM = DLAMCH( 'Safe minimum' )
!
!     Estimate the 1-norm of the inverse.
!
      KASE = 0
      NORMIN = 'N'
   10 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
         IF( UPPER ) THEN
!
!           Multiply by inv(U').
!
            CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, &
                         AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(U).
!
            CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, &
                         AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
         ELSE
!
!           Multiply by inv(L).
!
            CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N, &
                         AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
            NORMIN = 'Y'
!
!           Multiply by inv(L').
!
            CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, &
                         AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
         END IF
!
!        Multiply by 1/SCALE if doing so will not cause overflow.
!
         SCALE = SCALEL*SCALEU
         IF( SCALE.NE.ONE ) THEN
            IX = IDAMAX( N, WORK, 1 )
            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) &
               GO TO 20
            CALL DRSCL( N, SCALE, WORK, 1 )
         END IF
         GO TO 10
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
   20 CONTINUE
      RETURN
!
!     End of DPPCON
!
      END
      SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
      DOUBLE PRECISION   AMAX, SCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), S( * )
!     ..
!
!  Purpose
!  =======
!
!  DPPEQU computes row and column scalings intended to equilibrate a
!  symmetric positive definite matrix A in packed storage and reduce
!  its condition number (with respect to the two-norm).  S contains the
!  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
!  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
!  This choice of S puts the condition number of B within a factor N of
!  the smallest possible condition number over all possible diagonal
!  scalings.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangle of the symmetric matrix A, packed
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!  S       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, S contains the scale factors for A.
!
!  SCOND   (output) DOUBLE PRECISION
!          If INFO = 0, S contains the ratio of the smallest S(i) to
!          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
!          large nor too small, it is not worth scaling by S.
!
!  AMAX    (output) DOUBLE PRECISION
!          Absolute value of largest matrix element.  If AMAX is very
!          close to overflow or very close to underflow, the matrix
!          should be scaled.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, JJ
      DOUBLE PRECISION   SMIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPEQU', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         RETURN
      END IF
!
!     Initialize SMIN and AMAX.
!
      S( 1 ) = AP( 1 )
      SMIN = S( 1 )
      AMAX = S( 1 )
!
      IF( UPPER ) THEN
!
!        UPLO = 'U':  Upper triangle of A is stored.
!        Find the minimum and maximum diagonal elements.
!
         JJ = 1
         DO 10 I = 2, N
            JJ = JJ + I
            S( I ) = AP( JJ )
            SMIN = MIN( SMIN, S( I ) )
            AMAX = MAX( AMAX, S( I ) )
   10    CONTINUE
!
      ELSE
!
!        UPLO = 'L':  Lower triangle of A is stored.
!        Find the minimum and maximum diagonal elements.
!
         JJ = 1
         DO 20 I = 2, N
            JJ = JJ + N - I + 2
            S( I ) = AP( JJ )
            SMIN = MIN( SMIN, S( I ) )
            AMAX = MAX( AMAX, S( I ) )
   20    CONTINUE
      END IF
!
      IF( SMIN.LE.ZERO ) THEN
!
!        Find the first non-positive diagonal element and return.
!
         DO 30 I = 1, N
            IF( S( I ).LE.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   30    CONTINUE
      ELSE
!
!        Set the scale factors to the reciprocals
!        of the diagonal elements.
!
         DO 40 I = 1, N
            S( I ) = ONE / SQRT( S( I ) )
   40    CONTINUE
!
!        Compute SCOND = min(S(I)) / max(S(I))
!
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
      END IF
      RETURN
!
!     End of DPPEQU
!
      END
      SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, &
                         BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPPRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric positive definite
!  and packed, and provides error bounds and backward error estimates
!  for the solution.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangle of the symmetric matrix A, packed
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,
!          packed columnwise in a linear array in the same format as A
!          (see AP).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DPPTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DPPTRS, DSPMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), &
                     1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(A)*abs(X) + abs(B).
!
         KK = 1
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               IK = KK
               DO 40 I = 1, K - 1
                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
                  IK = IK + 1
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
               KK = KK + K
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
               IK = KK + 1
               DO 60 I = K + 1, N
                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
                  IK = IK + 1
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
               KK = KK + ( N-K+1 )
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(A) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(A').
!
               CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
!
!              Multiply by inv(A)*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DPPRFS
!
      END
      SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPPSV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite matrix stored in
!  packed format and X and B are N-by-NRHS matrices.
!
!  The Cholesky decomposition is used to factor A as
!     A = U**T* U,  if UPLO = 'U', or
!     A = L * L**T,  if UPLO = 'L',
!  where U is an upper triangular matrix and L is a lower triangular
!  matrix.  The factored form of A is then used to solve the system of
!  equations A * X = B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.
!
!          On exit, if INFO = 0, the factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T, in the same storage
!          format as A.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i of A is not
!                positive definite, so the factorization could not be
!                completed, and the solution has not been computed.
!
!  Further Details
!  ===============
!
!  The packed storage scheme is illustrated by the following example
!  when N = 4, UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11 a12 a13 a14
!         a22 a23 a24
!             a33 a34     (aij = conjg(aji))
!                 a44
!
!  Packed storage of the upper triangle of A:
!
!  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPPTRF, DPPTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPSV ', -INFO )
         RETURN
      END IF
!
!     Compute the Cholesky factorization A = U'*U or A = L*L'.
!
      CALL DPPTRF( UPLO, N, AP, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
!
      END IF
      RETURN
!
!     End of DPPSV
!
      END
      SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, &
                         X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          EQUED, FACT, UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ), &
                         FERR( * ), S( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
!  compute the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric positive definite matrix stored in
!  packed format and X and B are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'E', real scaling factors are computed to equilibrate
!     the system:
!        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
!     Whether or not the system will be equilibrated depends on the
!     scaling of the matrix A, but if equilibration is used, A is
!     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
!
!  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
!     factor the matrix A (after equilibration if FACT = 'E') as
!        A = U**T* U,  if UPLO = 'U', or
!        A = L * L**T,  if UPLO = 'L',
!     where U is an upper triangular matrix and L is a lower triangular
!     matrix.
!
!  3. If the leading i-by-i principal minor is not positive definite,
!     then the routine returns with INFO = i. Otherwise, the factored
!     form of A is used to estimate the condition number of the matrix
!     A.  If the reciprocal of the condition number is less than machine
!     precision, INFO = N+1 is returned as a warning, but the routine
!     still goes on to solve for X and compute error bounds as
!     described below.
!
!  4. The system of equations is solved for X using the factored form
!     of A.
!
!  5. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  6. If equilibration was used, the matrix X is premultiplied by
!     diag(S) so that it solves the original system before
!     equilibration.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of the matrix A is
!          supplied on entry, and if not, whether the matrix A should be
!          equilibrated before it is factored.
!          = 'F':  On entry, AFP contains the factored form of A.
!                  If EQUED = 'Y', the matrix A has been equilibrated
!                  with scaling factors given by S.  AP and AFP will not
!                  be modified.
!          = 'N':  The matrix A will be copied to AFP and factored.
!          = 'E':  The matrix A will be equilibrated if necessary, then
!                  copied to AFP and factored.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array, except if FACT = 'F'
!          and EQUED = 'Y', then A must contain the equilibrated matrix
!          diag(S)*A*diag(S).  The j-th column of A is stored in the
!          array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.  A is not modified if
!          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
!
!          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
!          diag(S)*A*diag(S).
!
!  AFP     (input or output) DOUBLE PRECISION array, dimension
!                            (N*(N+1)/2)
!          If FACT = 'F', then AFP is an input argument and on entry
!          contains the triangular factor U or L from the Cholesky
!          factorization A = U'*U or A = L*L', in the same storage
!          format as A.  If EQUED .ne. 'N', then AFP is the factored
!          form of the equilibrated matrix A.
!
!          If FACT = 'N', then AFP is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U'*U or A = L*L' of the original matrix A.
!
!          If FACT = 'E', then AFP is an output argument and on exit
!          returns the triangular factor U or L from the Cholesky
!          factorization A = U'*U or A = L*L' of the equilibrated
!          matrix A (see the description of AP for the form of the
!          equilibrated matrix).
!
!  EQUED   (input or output) CHARACTER*1
!          Specifies the form of equilibration that was done.
!          = 'N':  No equilibration (always true if FACT = 'N').
!          = 'Y':  Equilibration was done, i.e., A has been replaced by
!                  diag(S) * A * diag(S).
!          EQUED is an input argument if FACT = 'F'; otherwise, it is an
!          output argument.
!
!  S       (input or output) DOUBLE PRECISION array, dimension (N)
!          The scale factors for A; not accessed if EQUED = 'N'.  S is
!          an input argument if FACT = 'F'; otherwise, S is an output
!          argument.  If FACT = 'F' and EQUED = 'Y', each element of S
!          must be positive.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
!          B is overwritten by diag(S) * B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
!          the original system of equations.  Note that if EQUED = 'Y',
!          A and B are modified on exit, and the solution to the
!          equilibrated system is inv(diag(S))*X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A after equilibration (if done).  If RCOND is less than the
!          machine precision (in particular, if RCOND = 0), the matrix
!          is singular to working precision.  This condition is
!          indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  the leading minor of order i of A is
!                       not positive definite, so the factorization
!                       could not be completed, and the solution has not
!                       been computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  Further Details
!  ===============
!
!  The packed storage scheme is illustrated by the following example
!  when N = 4, UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11 a12 a13 a14
!         a22 a23 a24
!             a33 a34     (aij = conjg(aji))
!                 a44
!
!  Packed storage of the upper triangle of A:
!
!  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            EQUIL, NOFACT, RCEQU
      INTEGER            I, INFEQU, J
      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS, &
                         DPPTRF, DPPTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      EQUIL = LSAME( FACT, 'E' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         RCEQU = .FALSE.
      ELSE
         RCEQU = LSAME( EQUED, 'Y' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
!
!     Test the input parameters.
!
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. &
               ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -7
      ELSE
         IF( RCEQU ) THEN
            SMIN = BIGNUM
            SMAX = ZERO
            DO 10 J = 1, N
               SMIN = MIN( SMIN, S( J ) )
               SMAX = MAX( SMAX, S( J ) )
   10       CONTINUE
            IF( SMIN.LE.ZERO ) THEN
               INFO = -8
            ELSE IF( N.GT.0 ) THEN
               SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
            ELSE
               SCOND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -10
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -12
            END IF
         END IF
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPSVX', -INFO )
         RETURN
      END IF
!
      IF( EQUIL ) THEN
!
!        Compute row and column scalings to equilibrate the matrix A.
!
         CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
!
!           Equilibrate the matrix.
!
            CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
            RCEQU = LSAME( EQUED, 'Y' )
         END IF
      END IF
!
!     Scale the right-hand side.
!
      IF( RCEQU ) THEN
         DO 30 J = 1, NRHS
            DO 20 I = 1, N
               B( I, J ) = S( I )*B( I, J )
   20       CONTINUE
   30    CONTINUE
      END IF
!
      IF( NOFACT .OR. EQUIL ) THEN
!
!        Compute the Cholesky factorization A = U'*U or A = L*L'.
!
         CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
         CALL DPPTRF( UPLO, N, AFP, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution matrix X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solution and
!     compute error bounds and backward error estimates for it.
!
      CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, &
                   WORK, IWORK, INFO )
!
!     Transform the solution matrix X to a solution of the original
!     system.
!
      IF( RCEQU ) THEN
         DO 50 J = 1, NRHS
            DO 40 I = 1, N
               X( I, J ) = S( I )*X( I, J )
   40       CONTINUE
   50    CONTINUE
         DO 60 J = 1, NRHS
            FERR( J ) = FERR( J ) / SCOND
   60    CONTINUE
      END IF
!
      RETURN
!
!     End of DPPSVX
!
      END
      SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
!     ..
!
!  Purpose
!  =======
!
!  DPPTRF computes the Cholesky factorization of a real symmetric
!  positive definite matrix A stored in packed format.
!
!  The factorization has the form
!     A = U**T * U,  if UPLO = 'U', or
!     A = L  * L**T,  if UPLO = 'L',
!  where U is an upper triangular matrix and L is lower triangular.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.
!
!          On exit, if INFO = 0, the triangular factor U or L from the
!          Cholesky factorization A = U**T*U or A = L*L**T, in the same
!          storage format as A.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i is not
!                positive definite, and the factorization could not be
!                completed.
!
!  Further Details
!  ======= =======
!
!  The packed storage scheme is illustrated by the following example
!  when N = 4, UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11 a12 a13 a14
!         a22 a23 a24
!             a33 a34     (aij = aji)
!                 a44
!
!  Packed storage of the upper triangle of A:
!
!  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JC, JJ
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Compute the Cholesky factorization A = U'*U.
!
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
!
!           Compute elements 1:J-1 of column J.
!
            IF( J.GT.1 ) &
               CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP, &
                           AP( JC ), 1 )
!
!           Compute U(J,J) and test for non-positive-definiteness.
!
            AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AP( JJ ) = SQRT( AJJ )
   10    CONTINUE
      ELSE
!
!        Compute the Cholesky factorization A = L*L'.
!
         JJ = 1
         DO 20 J = 1, N
!
!           Compute L(J,J) and test for non-positive-definiteness.
!
            AJJ = AP( JJ )
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AJJ = SQRT( AJJ )
            AP( JJ ) = AJJ
!
!           Compute elements J+1:N of column J and update the trailing
!           submatrix.
!
            IF( J.LT.N ) THEN
               CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
               CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, &
                          AP( JJ+N-J+1 ) )
               JJ = JJ + N - J + 1
            END IF
   20    CONTINUE
      END IF
      GO TO 40
!
   30 CONTINUE
      INFO = J
!
   40 CONTINUE
      RETURN
!
!     End of DPPTRF
!
      END
      SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
!     ..
!
!  Purpose
!  =======
!
!  DPPTRI computes the inverse of a real symmetric positive definite
!  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
!  computed by DPPTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangular factor is stored in AP;
!          = 'L':  Lower triangular factor is stored in AP.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the triangular factor U or L from the Cholesky
!          factorization A = U**T*U or A = L*L**T, packed columnwise as
!          a linear array.  The j-th column of U or L is stored in the
!          array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!
!          On exit, the upper or lower triangle of the (symmetric)
!          inverse of A, overwriting the input factor U or L.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the (i,i) element of the factor U or L is
!                zero, and the inverse could not be computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JC, JJ, JJN
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRI', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Invert the triangular Cholesky factor U or L.
!
      CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
      IF( INFO.GT.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Compute the product inv(U) * inv(U)'.
!
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
            IF( J.GT.1 ) &
               CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
            AJJ = AP( JJ )
            CALL DSCAL( J, AJJ, AP( JC ), 1 )
   10    CONTINUE
!
      ELSE
!
!        Compute the product inv(L)' * inv(L).
!
         JJ = 1
         DO 20 J = 1, N
            JJN = JJ + N - J + 1
            AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
            IF( J.LT.N ) &
               CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, &
                           AP( JJN ), AP( JJ+1 ), 1 )
            JJ = JJN
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DPPTRI
!
      END
      SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DPPTRS solves a system of linear equations A*X = B with a symmetric
!  positive definite matrix A in packed storage using the Cholesky
!  factorization A = U**T*U or A = L*L**T computed by DPPTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The triangular factor U or L from the Cholesky factorization
!          A = U**T*U or A = L*L**T, packed columnwise in a linear
!          array.  The j-th column of U or L is stored in the array AP
!          as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Solve A*X = B where A = U'*U.
!
         DO 10 I = 1, NRHS
!
!           Solve U'*X = B, overwriting B with X.
!
            CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP, &
                        B( 1, I ), 1 )
!
!           Solve U*X = B, overwriting B with X.
!
            CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP, &
                        B( 1, I ), 1 )
   10    CONTINUE
      ELSE
!
!        Solve A*X = B where A = L*L'.
!
         DO 20 I = 1, NRHS
!
!           Solve L*Y = B, overwriting B with X.
!
            CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP, &
                        B( 1, I ), 1 )
!
!           Solve L'*X = Y, overwriting B with X.
!
            CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP, &
                        B( 1, I ), 1 )
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DPPTRS
!
      END
      SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DPTCON computes the reciprocal of the condition number (in the
!  1-norm) of a real symmetric positive definite tridiagonal matrix
!  using the factorization A = L*D*L**T or A = U**T*D*U computed by
!  DPTTRF.
!
!  Norm(inv(A)) is computed by a direct method, and the reciprocal of
!  the condition number is computed as
!               RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D from the
!          factorization of A, as computed by DPTTRF.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) off-diagonal elements of the unit bidiagonal factor
!          U or L from the factorization of A,  as computed by DPTTRF.
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
!          1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The method used is described in Nicholas J. Higham, "Efficient
!  Algorithms for Computing the Condition Number of a Tridiagonal
!  Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IX
      DOUBLE PRECISION   AINVNM
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.EQ.ZERO ) THEN
         RETURN
      END IF
!
!     Check that D(1:N) is positive.
!
      DO 10 I = 1, N
         IF( D( I ).LE.ZERO ) &
            RETURN
   10 CONTINUE
!
!     Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
!
!        m(i,j) =  abs(A(i,j)), i = j,
!        m(i,j) = -abs(A(i,j)), i .ne. j,
!
!     and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
!
!     Solve M(L) * x = e.
!
      WORK( 1 ) = ONE
      DO 20 I = 2, N
         WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
   20 CONTINUE
!
!     Solve D * M(L)' * x = b.
!
      WORK( N ) = WORK( N ) / D( N )
      DO 30 I = N - 1, 1, -1
         WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
   30 CONTINUE
!
!     Compute AINVNM = max(x(i)), 1<=i<=n.
!
      IX = IDAMAX( N, WORK, 1 )
      AINVNM = ABS( WORK( IX ) )
!
!     Compute the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
      RETURN
!
!     End of DPTCON
!
      END
      SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
!  symmetric positive definite tridiagonal matrix by first factoring the
!  matrix using DPTTRF, and then calling DBDSQR to compute the singular
!  values of the bidiagonal factor.
!
!  This routine computes the eigenvalues of the positive definite
!  tridiagonal matrix to high relative accuracy.  This means that if the
!  eigenvalues range over many orders of magnitude in size, then the
!  small eigenvalues and corresponding eigenvectors will be computed
!  more accurately than, for example, with the standard QR method.
!
!  The eigenvectors of a full or band symmetric positive definite matrix
!  can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
!  reduce this matrix to tridiagonal form. (The reduction to tridiagonal
!  form, however, may preclude the possibility of obtaining high
!  relative accuracy in the small eigenvalues of the original matrix, if
!  these eigenvalues range over many orders of magnitude.)
!
!  Arguments
!  =========
!
!  COMPZ   (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only.
!          = 'V':  Compute eigenvectors of original symmetric
!                  matrix also.  Array Z contains the orthogonal
!                  matrix used to reduce the original matrix to
!                  tridiagonal form.
!          = 'I':  Compute eigenvectors of tridiagonal matrix also.
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal
!          matrix.
!          On normal exit, D contains the eigenvalues, in descending
!          order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix.
!          On exit, E has been destroyed.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
!          On entry, if COMPZ = 'V', the orthogonal matrix used in the
!          reduction to tridiagonal form.
!          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
!          original symmetric matrix;
!          if COMPZ = 'I', the orthonormal eigenvectors of the
!          tridiagonal matrix.
!          If INFO > 0 on exit, Z contains the eigenvectors associated
!          with only the stored eigenvalues.
!          If  COMPZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          COMPZ = 'V' or 'I', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, and i is:
!                <= N  the Cholesky factorization of the matrix could
!                      not be performed because the i-th principal minor
!                      was not positive definite.
!                > N   the SVD algorithm failed to converge;
!                      if INFO = N+i, i off-diagonal elements of the
!                      bidiagonal factor did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DBDSQR, DLASET, DPTTRF, XERBLA
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   C( 1, 1 ), VT( 1, 1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ICOMPZ, NRU
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, &
               N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTEQR', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.GT.0 ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
      IF( ICOMPZ.EQ.2 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
!
!     Call DPTTRF to factor the matrix.
!
      CALL DPTTRF( N, D, E, INFO )
      IF( INFO.NE.0 ) &
         RETURN
      DO 10 I = 1, N
         D( I ) = SQRT( D( I ) )
   10 CONTINUE
      DO 20 I = 1, N - 1
         E( I ) = E( I )*D( I )
   20 CONTINUE
!
!     Call DBDSQR to compute the singular values/vectors of the
!     bidiagonal factor.
!
      IF( ICOMPZ.GT.0 ) THEN
         NRU = N
      ELSE
         NRU = 0
      END IF
      CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1, &
                   WORK, INFO )
!
!     Square the singular values.
!
      IF( INFO.EQ.0 ) THEN
         DO 30 I = 1, N
            D( I ) = D( I )*D( I )
   30    CONTINUE
      ELSE
         INFO = N + INFO
      END IF
!
      RETURN
!
!     End of DPTEQR
!
      END
      SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, &
                         BERR, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ), &
                         E( * ), EF( * ), FERR( * ), WORK( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPTRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric positive definite
!  and tridiagonal, and provides error bounds and backward error
!  estimates for the solution.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the tridiagonal matrix A.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!
!  DF      (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D from the
!          factorization computed by DPTTRF.
!
!  EF      (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the unit bidiagonal factor
!          L from the factorization computed by DPTTRF.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DPTTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            COUNT, I, IX, J, NZ
      DOUBLE PRECISION   BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2, &
                         SAFMIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DPTTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           IDAMAX, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = 4
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 90 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X.  Also compute
!        abs(A)*abs(x) + abs(b) for use in the backward error bound.
!
         IF( N.EQ.1 ) THEN
            BI = B( 1, J )
            DX = D( 1 )*X( 1, J )
            WORK( N+1 ) = BI - DX
            WORK( 1 ) = ABS( BI ) + ABS( DX )
         ELSE
            BI = B( 1, J )
            DX = D( 1 )*X( 1, J )
            EX = E( 1 )*X( 2, J )
            WORK( N+1 ) = BI - DX - EX
            WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
            DO 30 I = 2, N - 1
               BI = B( I, J )
               CX = E( I-1 )*X( I-1, J )
               DX = D( I )*X( I, J )
               EX = E( I )*X( I+1, J )
               WORK( N+I ) = BI - CX - DX - EX
               WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
   30       CONTINUE
            BI = B( N, J )
            CX = E( N-1 )*X( N-1, J )
            DX = D( N )*X( N, J )
            WORK( N+N ) = BI - CX - DX
            WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
         END IF
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         S = ZERO
         DO 40 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   40    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
         DO 50 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   50    CONTINUE
         IX = IDAMAX( N, WORK, 1 )
         FERR( J ) = WORK( IX )
!
!        Estimate the norm of inv(A).
!
!        Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
!
!           m(i,j) =  abs(A(i,j)), i = j,
!           m(i,j) = -abs(A(i,j)), i .ne. j,
!
!        and e = [ 1, 1, ..., 1 ]'.  Note M(A) = M(L)*D*M(L)'.
!
!        Solve M(L) * x = e.
!
         WORK( 1 ) = ONE
         DO 60 I = 2, N
            WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
   60    CONTINUE
!
!        Solve D * M(L)' * x = b.
!
         WORK( N ) = WORK( N ) / DF( N )
         DO 70 I = N - 1, 1, -1
            WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
   70    CONTINUE
!
!        Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
!
         IX = IDAMAX( N, WORK, 1 )
         FERR( J ) = FERR( J )*ABS( WORK( IX ) )
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 80 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
   80    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
   90 CONTINUE
!
      RETURN
!
!     End of DPTRFS
!
      END
      SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 25, 1997
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DPTSV computes the solution to a real system of linear equations
!  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
!  matrix, and X and B are N-by-NRHS matrices.
!
!  A is factored as A = L*D*L**T, and the factored form of A is then
!  used to solve the system of equations.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.  On exit, the n diagonal elements of the diagonal matrix
!          D from the factorization A = L*D*L**T.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A.  On exit, the (n-1) subdiagonal elements of the
!          unit bidiagonal factor L from the L*D*L**T factorization of
!          A.  (E can also be regarded as the superdiagonal of the unit
!          bidiagonal factor U from the U**T*D*U factorization of A.)
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the leading minor of order i is not
!                positive definite, and the solution has not been
!                computed.  The factorization has not been completed
!                unless i = N.
!
!  =====================================================================
!
!     .. External Subroutines ..
      EXTERNAL           DPTTRF, DPTTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTSV ', -INFO )
         RETURN
      END IF
!
!     Compute the L*D*L' (or U'*D*U) factorization of A.
!
      CALL DPTTRF( N, D, E, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO )
      END IF
      RETURN
!
!     End of DPTSV
!
      END
      SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, &
                         RCOND, FERR, BERR, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          FACT
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ), &
                         E( * ), EF( * ), FERR( * ), WORK( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DPTSVX uses the factorization A = L*D*L**T to compute the solution
!  to a real system of linear equations A*X = B, where A is an N-by-N
!  symmetric positive definite tridiagonal matrix and X and B are
!  N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
!     is a unit lower bidiagonal matrix and D is diagonal.  The
!     factorization can also be regarded as having the form
!     A = U**T*D*U.
!
!  2. If the leading i-by-i principal minor is not positive definite,
!     then the routine returns with INFO = i. Otherwise, the factored
!     form of A is used to estimate the condition number of the matrix
!     A.  If the reciprocal of the condition number is less than machine
!     precision, INFO = N+1 is returned as a warning, but the routine
!     still goes on to solve for X and compute error bounds as
!     described below.
!
!  3. The system of equations is solved for X using the factored form
!     of A.
!
!  4. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of A has been
!          supplied on entry.
!          = 'F':  On entry, DF and EF contain the factored form of A.
!                  D, E, DF, and EF will not be modified.
!          = 'N':  The matrix A will be copied to DF and EF and
!                  factored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the tridiagonal matrix A.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!
!  DF      (input or output) DOUBLE PRECISION array, dimension (N)
!          If FACT = 'F', then DF is an input argument and on entry
!          contains the n diagonal elements of the diagonal matrix D
!          from the L*D*L**T factorization of A.
!          If FACT = 'N', then DF is an output argument and on exit
!          contains the n diagonal elements of the diagonal matrix D
!          from the L*D*L**T factorization of A.
!
!  EF      (input or output) DOUBLE PRECISION array, dimension (N-1)
!          If FACT = 'F', then EF is an input argument and on entry
!          contains the (n-1) subdiagonal elements of the unit
!          bidiagonal factor L from the L*D*L**T factorization of A.
!          If FACT = 'N', then EF is an output argument and on exit
!          contains the (n-1) subdiagonal elements of the unit
!          bidiagonal factor L from the L*D*L**T factorization of A.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The N-by-NRHS right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal condition number of the matrix A.  If RCOND
!          is less than the machine precision (in particular, if
!          RCOND = 0), the matrix is singular to working precision.
!          This condition is indicated by a return code of INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in any
!          element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  the leading minor of order i of A is
!                       not positive definite, so the factorization
!                       could not be completed, and the solution has not
!                       been computed. RCOND = 0 is returned.
!                = N+1: U is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOFACT
      DOUBLE PRECISION   ANORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTSVX', -INFO )
         RETURN
      END IF
!
      IF( NOFACT ) THEN
!
!        Compute the L*D*L' (or U'*D*U) factorization of A.
!
         CALL DCOPY( N, D, 1, DF, 1 )
         IF( N.GT.1 ) &
            CALL DCOPY( N-1, E, 1, EF, 1 )
         CALL DPTTRF( N, DF, EF, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANST( '1', N, D, E )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution vectors X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solutions and
!     compute error bounds and backward error estimates for them.
!
      CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, &
                   WORK, INFO )
!
      RETURN
!
!     End of DPTSVX
!
      END
      SUBROUTINE DPTTRF( N, D, E, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DPTTRF computes the L*D*L' factorization of a real symmetric
!  positive definite tridiagonal matrix A.  The factorization may also
!  be regarded as having the form A = U'*D*U.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.  On exit, the n diagonal elements of the diagonal matrix
!          D from the L*D*L' factorization of A.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A.  On exit, the (n-1) subdiagonal elements of the
!          unit bidiagonal factor L from the L*D*L' factorization of A.
!          E can also be regarded as the superdiagonal of the unit
!          bidiagonal factor U from the U'*D*U factorization of A.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, the leading minor of order k is not
!               positive definite; if k < N, the factorization could not
!               be completed, while if k = N, the factorization was
!               completed, but D(N) = 0.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I4
      DOUBLE PRECISION   EI
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MOD
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DPTTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Compute the L*D*L' (or U'*D*U) factorization of A.
!
      I4 = MOD( N-1, 4 )
      DO 10 I = 1, I4
         IF( D( I ).LE.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
   10 CONTINUE
!
      DO 20 I = I4 + 1, N - 4, 4
!
!        Drop out of the loop if d(i) <= 0: the matrix is not positive
!        definite.
!
         IF( D( I ).LE.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
!
!        Solve for e(i) and d(i+1).
!
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
!
         IF( D( I+1 ).LE.ZERO ) THEN
            INFO = I + 1
            GO TO 30
         END IF
!
!        Solve for e(i+1) and d(i+2).
!
         EI = E( I+1 )
         E( I+1 ) = EI / D( I+1 )
         D( I+2 ) = D( I+2 ) - E( I+1 )*EI
!
         IF( D( I+2 ).LE.ZERO ) THEN
            INFO = I + 2
            GO TO 30
         END IF
!
!        Solve for e(i+2) and d(i+3).
!
         EI = E( I+2 )
         E( I+2 ) = EI / D( I+2 )
         D( I+3 ) = D( I+3 ) - E( I+2 )*EI
!
         IF( D( I+3 ).LE.ZERO ) THEN
            INFO = I + 3
            GO TO 30
         END IF
!
!        Solve for e(i+3) and d(i+4).
!
         EI = E( I+3 )
         E( I+3 ) = EI / D( I+3 )
         D( I+4 ) = D( I+4 ) - E( I+3 )*EI
   20 CONTINUE
!
!     Check d(n) for positive definiteness.
!
      IF( D( N ).LE.ZERO ) &
         INFO = N
!
   30 CONTINUE
      RETURN
!
!     End of DPTTRF
!
      END
      SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DPTTRS solves a tridiagonal system of the form
!     A * X = B
!  using the L*D*L' factorization of A computed by DPTTRF.  D is a
!  diagonal matrix specified in the vector D, L is a unit bidiagonal
!  matrix whose subdiagonal is specified in the vector E, and X and B
!  are N by NRHS matrices.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the tridiagonal matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D from the
!          L*D*L' factorization of A.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the unit bidiagonal factor
!          L from the L*D*L' factorization of A.  E can also be regarded
!          as the superdiagonal of the unit bidiagonal factor U from the
!          factorization A = U'*D*U.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side vectors B for the system of
!          linear equations.
!          On exit, the solution vectors, X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            J, JB, NB
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPTTS2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
!     Determine the number of right-hand sides to solve at a time.
!
      IF( NRHS.EQ.1 ) THEN
         NB = 1
      ELSE
         NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) )
      END IF
!
      IF( NB.GE.NRHS ) THEN
         CALL DPTTS2( N, NRHS, D, E, B, LDB )
      ELSE
         DO 10 J = 1, NRHS, NB
            JB = MIN( NRHS-J+1, NB )
            CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB )
   10    CONTINUE
      END IF
!
      RETURN
!
!     End of DPTTRS
!
      END
      SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DPTTS2 solves a tridiagonal system of the form
!     A * X = B
!  using the L*D*L' factorization of A computed by DPTTRF.  D is a
!  diagonal matrix specified in the vector D, L is a unit bidiagonal
!  matrix whose subdiagonal is specified in the vector E, and X and B
!  are N by NRHS matrices.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the tridiagonal matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the diagonal matrix D from the
!          L*D*L' factorization of A.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) subdiagonal elements of the unit bidiagonal factor
!          L from the L*D*L' factorization of A.  E can also be regarded
!          as the superdiagonal of the unit bidiagonal factor U from the
!          factorization A = U'*D*U.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side vectors B for the system of
!          linear equations.
!          On exit, the solution vectors, X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, J
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.1 ) THEN
         IF( N.EQ.1 ) &
            CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
         RETURN
      END IF
!
!     Solve A * X = B using the factorization A = L*D*L',
!     overwriting each right hand side vector with its solution.
!
      DO 30 J = 1, NRHS
!
!           Solve L * x = b.
!
         DO 10 I = 2, N
            B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
   10    CONTINUE
!
!           Solve D * L' * x = b.
!
         B( N, J ) = B( N, J ) / D( N )
         DO 20 I = N - 1, 1, -1
            B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
   20    CONTINUE
   30 CONTINUE
!
      RETURN
!
!     End of DPTTS2
!
      END
      SUBROUTINE DRSCL( N, SA, SX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SA
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   SX( * )
!     ..
!
!  Purpose
!  =======
!
!  DRSCL multiplies an n-element real vector x by the real scalar 1/a.
!  This is done without overflow or underflow as long as
!  the final result x/a does not overflow or underflow.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of components of the vector x.
!
!  SA      (input) DOUBLE PRECISION
!          The scalar a which is used to divide each component of x.
!          SA must be >= 0, or the subroutine will divide by zero.
!
!  SX      (input/output) DOUBLE PRECISION array, dimension
!                         (1+(N-1)*abs(INCX))
!          The n-element vector x.
!
!  INCX    (input) INTEGER
!          The increment between successive values of the vector SX.
!          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            DONE
      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
!     Get machine parameters
!
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
!     Initialize the denominator to SA and the numerator to 1.
!
      CDEN = SA
      CNUM = ONE
!
   10 CONTINUE
      CDEN1 = CDEN*SMLNUM
      CNUM1 = CNUM / BIGNUM
      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
!
!        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
!
         MUL = SMLNUM
         DONE = .FALSE.
         CDEN = CDEN1
      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
!
!        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
!
         MUL = BIGNUM
         DONE = .FALSE.
         CNUM = CNUM1
      ELSE
!
!        Multiply X by CNUM / CDEN and return.
!
         MUL = CNUM / CDEN
         DONE = .TRUE.
      END IF
!
!     Scale the vector X by MUL
!
      CALL DSCAL( N, MUL, SX, INCX )
!
      IF( .NOT.DONE ) &
         GO TO 10
!
      RETURN
!
!     End of DRSCL
!
      END
      SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, &
                        INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, KD, LDAB, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBEV computes all the eigenvalues and, optionally, eigenvectors of
!  a real symmetric band matrix A.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, AB is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the first
!          superdiagonal and the diagonal of the tridiagonal matrix T
!          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
!          the diagonal and first subdiagonal of T are returned in the
!          first two rows of AB.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD + 1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LOWER, WANTZ
      INTEGER            IINFO, IMAX, INDE, INDWRK, ISCALE
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSB
      EXTERNAL           LSAME, DLAMCH, DLANSB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KD.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -9
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBEV ', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( LOWER ) THEN
            W( 1 ) = AB( 1, 1 )
         ELSE
            W( 1 ) = AB( KD+1, 1 )
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         IF( LOWER ) THEN
            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         ELSE
            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         END IF
      END IF
!
!     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
!
      INDE = 1
      INDWRK = INDE + N
      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEQR.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
      RETURN
!
!     End of DSBEV
!
      END
      SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, &
                         LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
!  a real symmetric band matrix A. If eigenvectors are desired, it uses
!  a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, AB is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the first
!          superdiagonal and the diagonal of the tridiagonal matrix T
!          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
!          the diagonal and first subdiagonal of T are returned in the
!          first two rows of AB.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD + 1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array,
!                                         dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          IF N <= 1,                LWORK must be at least 1.
!          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N.
!          If JOBZ  = 'V' and N > 2, LWORK must be at least
!                         ( 1 + 5*N + 2*N**2 ).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array LIWORK.
!          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
!          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LOWER, LQUERY, WANTZ
      INTEGER            IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN, &
                         LLWRK2, LWMIN
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSB
      EXTERNAL           LSAME, DLAMCH, DLANSB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC, &
                         DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LIWMIN = 1
         LWMIN = 1
      ELSE
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 5*N + 2*N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N
         END IF
      END IF
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KD.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -9
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -11
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBEVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         W( 1 ) = AB( 1, 1 )
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         IF( LOWER ) THEN
            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         ELSE
            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         END IF
      END IF
!
!     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
!
      INDE = 1
      INDWRK = INDE + N
      INDWK2 = INDWRK + N*N
      LLWRK2 = LWORK - INDWK2 + 1
      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEDC.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, &
                      WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
         CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, &
                     ZERO, WORK( INDWK2 ), N )
         CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) &
         CALL DSCAL( N, ONE / SIGMA, W, 1 )
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
!
!     End of DSBEVD
!
      END
      SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, &
                         VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, &
                         IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBEVX computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can
!  be selected by specifying either a range of values or a range of
!  indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found;
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found;
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!
!          On exit, AB is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the first
!          superdiagonal and the diagonal of the tridiagonal matrix T
!          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
!          the diagonal and first subdiagonal of T are returned in the
!          first two rows of AB.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD + 1.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
!          If JOBZ = 'V', the N-by-N orthogonal matrix used in the
!                         reduction to tridiagonal form.
!          If JOBZ = 'N', the array Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  If JOBZ = 'V', then
!          LDQ >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing AB to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the selected eigenvalues in
!          ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (7*N)
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, then i eigenvectors failed to converge.
!                Their indices are stored in array IFAIL.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LOWER, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, &
                         INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, &
                         NSPLIT
      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, &
                         SIGMA, SMLNUM, TMP1, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSB
      EXTERNAL           LSAME, DLAMCH, DLANSB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL, &
                         DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
      LOWER = LSAME( UPLO, 'L' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( KD.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -7
      ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -11
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -12
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -13
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) &
            INFO = -18
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBEVX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         M = 1
         IF( LOWER ) THEN
            TMP1 = AB( 1, 1 )
         ELSE
            TMP1 = AB( KD+1, 1 )
         END IF
         IF( VALEIG ) THEN
            IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) ) &
               M = 0
         END IF
         IF( M.EQ.1 ) THEN
            W( 1 ) = TMP1
            IF( WANTZ ) &
               Z( 1, 1 ) = ONE
         END IF
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      ABSTLL = ABSTOL
      IF( VALEIG ) THEN
         VLL = VL
         VUU = VU
      ELSE
         VLL = ZERO
         VUU = ZERO
      END IF
      ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         IF( LOWER ) THEN
            CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         ELSE
            CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
         END IF
         IF( ABSTOL.GT.0 ) &
            ABSTLL = ABSTOL*SIGMA
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
!
      INDD = 1
      INDE = INDD + N
      INDWRK = INDE + N
      CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), &
                   WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
!
!     If all eigenvalues are desired and ABSTOL is less than or equal
!     to zero, then call DSTERF or SSTEQR.  If this fails for some
!     eigenvalue, then try DSTEBZ.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
         INDEE = INDWRK + 2*N
         IF( .NOT.WANTZ ) THEN
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTERF( N, W, WORK( INDEE ), INFO )
         ELSE
            CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, &
                         WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 10 I = 1, N
                  IFAIL( I ) = 0
   10          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 30
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, &
                   WORK( INDD ), WORK( INDE ), M, NSPLIT, W, &
                   IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, &
                      IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, &
                      WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         DO 20 J = 1, M
            CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
            CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, &
                        Z( 1, J ), 1 )
   20    CONTINUE
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   30 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 50 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 40 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   40       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of DSBEVX
!
      END
      SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, &
                         LDX, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO, VECT
      INTEGER            INFO, KA, KB, LDAB, LDBB, LDX, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), WORK( * ), &
                         X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBGST reduces a real symmetric-definite banded generalized
!  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,
!  such that C has the same bandwidth as A.
!
!  B must have been previously factorized as S**T*S by DPBSTF, using a
!  split Cholesky factorization. A is overwritten by C = X**T*A*X, where
!  X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
!  bandwidth of A.
!
!  Arguments
!  =========
!
!  VECT    (input) CHARACTER*1
!          = 'N':  do not form the transformation matrix X;
!          = 'V':  form X.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  KA      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
!
!  KB      (input) INTEGER
!          The number of superdiagonals of the matrix B if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first ka+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!
!          On exit, the transformed matrix X**T*A*X, stored in the same
!          format as A.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KA+1.
!
!  BB      (input) DOUBLE PRECISION array, dimension (LDBB,N)
!          The banded factor S from the split Cholesky factorization of
!          B, as returned by DPBSTF, stored in the first KB+1 rows of
!          the array.
!
!  LDBB    (input) INTEGER
!          The leading dimension of the array BB.  LDBB >= KB+1.
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,N)
!          If VECT = 'V', the n-by-n matrix X.
!          If VECT = 'N', the array X is not referenced.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.
!          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPDATE, UPPER, WANTX
      INTEGER            I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K, &
                         KA1, KB1, KBT, L, M, NR, NRT, NX
      DOUBLE PRECISION   BII, RA, RA1, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, &
                         DROT, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      WANTX = LSAME( VECT, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      KA1 = KA + 1
      KB1 = KB + 1
      INFO = 0
      IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KA.LT.0 ) THEN
         INFO = -4
      ELSE IF( KB.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KA+1 ) THEN
         INFO = -7
      ELSE IF( LDBB.LT.KB+1 ) THEN
         INFO = -9
      ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBGST', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      INCA = LDAB*KA1
!
!     Initialize X to the unit matrix, if needed
!
      IF( WANTX ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX )
!
!     Set M to the splitting point m. It must be the same value as is
!     used in DPBSTF. The chosen value allows the arrays WORK and RWORK
!     to be of dimension (N).
!
      M = ( N+KB ) / 2
!
!     The routine works in two phases, corresponding to the two halves
!     of the split Cholesky factorization of B as S**T*S where
!
!     S = ( U    )
!         ( M  L )
!
!     with U upper triangular of order m, and L lower triangular of
!     order n-m. S has the same bandwidth as B.
!
!     S is treated as a product of elementary matrices:
!
!     S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
!
!     where S(i) is determined by the i-th row of S.
!
!     In phase 1, the index i takes the values n, n-1, ... , m+1;
!     in phase 2, it takes the values 1, 2, ... , m.
!
!     For each value of i, the current matrix A is updated by forming
!     inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
!     the band of A. The bulge is then pushed down toward the bottom of
!     A in phase 1, and up toward the top of A in phase 2, by applying
!     plane rotations.
!
!     There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
!     of them are linearly independent, so annihilating a bulge requires
!     only 2*kb-1 plane rotations. The rotations are divided into a 1st
!     set of kb-1 rotations, and a 2nd set of kb rotations.
!
!     Wherever possible, rotations are generated and applied in vector
!     operations of length NR between the indices J1 and J2 (sometimes
!     replaced by modified values NRT, J1T or J2T).
!
!     The cosines and sines of the rotations are stored in the array
!     WORK. The cosines of the 1st set of rotations are stored in
!     elements n+2:n+m-kb-1 and the sines of the 1st set in elements
!     2:m-kb-1; the cosines of the 2nd set are stored in elements
!     n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
!
!     The bulges are not formed explicitly; nonzero elements outside the
!     band are created only when they are required for generating new
!     rotations; they are stored in the array WORK, in positions where
!     they are later overwritten by the sines of the rotations which
!     annihilate them.
!
!     **************************** Phase 1 *****************************
!
!     The logical structure of this phase is:
!
!     UPDATE = .TRUE.
!     DO I = N, M + 1, -1
!        use S(i) to update A and create a new bulge
!        apply rotations to push all bulges KA positions downward
!     END DO
!     UPDATE = .FALSE.
!     DO I = M + KA + 1, N - 1
!        apply rotations to push all bulges KA positions downward
!     END DO
!
!     To avoid duplicating code, the two loops are merged.
!
      UPDATE = .TRUE.
      I = N + 1
   10 CONTINUE
      IF( UPDATE ) THEN
         I = I - 1
         KBT = MIN( KB, I-1 )
         I0 = I - 1
         I1 = MIN( N, I+KA )
         I2 = I - KBT + KA1
         IF( I.LT.M+1 ) THEN
            UPDATE = .FALSE.
            I = I + 1
            I0 = M
            IF( KA.EQ.0 ) &
               GO TO 480
            GO TO 10
         END IF
      ELSE
         I = I + KA
         IF( I.GT.N-1 ) &
            GO TO 480
      END IF
!
      IF( UPPER ) THEN
!
!        Transform A, working with the upper triangle
!
         IF( UPDATE ) THEN
!
!           Form  inv(S(i))**T * A * inv(S(i))
!
            BII = BB( KB1, I )
            DO 20 J = I, I1
               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
   20       CONTINUE
            DO 30 J = MAX( 1, I-KA ), I
               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
   30       CONTINUE
            DO 60 K = I - KBT, I - 1
               DO 40 J = I - KBT, K
                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - &
                                     BB( J-I+KB1, I )*AB( K-I+KA1, I ) - &
                                     BB( K-I+KB1, I )*AB( J-I+KA1, I ) + &
                                     AB( KA1, I )*BB( J-I+KB1, I )* &
                                     BB( K-I+KB1, I )
   40          CONTINUE
               DO 50 J = MAX( 1, I-KA ), I - KBT - 1
                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - &
                                     BB( K-I+KB1, I )*AB( J-I+KA1, I )
   50          CONTINUE
   60       CONTINUE
            DO 80 J = I, I1
               DO 70 K = MAX( J-KA, I-KBT ), I - 1
                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - &
                                     BB( K-I+KB1, I )*AB( I-J+KA1, J )
   70          CONTINUE
   80       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by inv(S(i))
!
               CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
               IF( KBT.GT.0 ) &
                  CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, &
                             BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
            END IF
!
!           store a(i,i1) in RA1 for use in next loop over K
!
            RA1 = AB( I-I1+KA1, I1 )
         END IF
!
!        Generate and apply vectors of rotations to chase all the
!        existing bulges KA positions down toward the bottom of the
!        band
!
         DO 130 K = 1, KB - 1
            IF( UPDATE ) THEN
!
!              Determine the rotations which would annihilate the bulge
!              which has in theory just been created
!
               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
!
!                 generate rotation to annihilate a(i,i-k+ka+1)
!
                  CALL DLARTG( AB( K+1, I-K+KA ), RA1, &
                               WORK( N+I-K+KA-M ), WORK( I-K+KA-M ), &
                               RA )
!
!                 create nonzero element a(i-k,i-k+ka+1) outside the
!                 band and store it in WORK(i-k)
!
                  T = -BB( KB1-K, I )*RA1
                  WORK( I-K ) = WORK( N+I-K+KA-M )*T - &
                                WORK( I-K+KA-M )*AB( 1, I-K+KA )
                  AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T + &
                                    WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
                  RA1 = RA
               END IF
            END IF
            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            IF( UPDATE ) THEN
               J2T = MAX( J2, I+2*KA-K+1 )
            ELSE
               J2T = J2
            END IF
            NRT = ( N-J2T+KA ) / KA1
            DO 90 J = J2T, J1, KA1
!
!              create nonzero element a(j-ka,j+1) outside the band
!              and store it in WORK(j-m)
!
               WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
               AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
   90       CONTINUE
!
!           generate rotations in 1st set to annihilate elements which
!           have been created outside the band
!
            IF( NRT.GT.0 ) &
               CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1, &
                            WORK( N+J2T-M ), KA1 )
            IF( NR.GT.0 ) THEN
!
!              apply rotations in 1st set from the right
!
               DO 100 L = 1, KA - 1
                  CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, &
                               AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ), &
                               WORK( J2-M ), KA1 )
  100          CONTINUE
!
!              apply rotations in 1st set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), &
                            AB( KA, J2+1 ), INCA, WORK( N+J2-M ), &
                            WORK( J2-M ), KA1 )
!
            END IF
!
!           start applying rotations in 1st set from the left
!
            DO 110 L = KA - 1, KB - K + 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, &
                               AB( L+1, J2+KA1-L ), INCA, &
                               WORK( N+J2-M ), WORK( J2-M ), KA1 )
  110       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 1st set
!
               DO 120 J = J2, J1, KA1
                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, &
                             WORK( N+J-M ), WORK( J-M ) )
  120          CONTINUE
            END IF
  130    CONTINUE
!
         IF( UPDATE ) THEN
            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
!
!              create nonzero element a(i-kbt,i-kbt+ka+1) outside the
!              band and store it in WORK(i-kbt)
!
               WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
            END IF
         END IF
!
         DO 170 K = KB, 1, -1
            IF( UPDATE ) THEN
               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
            ELSE
               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
            END IF
!
!           finish applying rotations in 2nd set from the left
!
            DO 140 L = KB - K, 1, -1
               NRT = ( N-J2+KA+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA, &
                               AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ), &
                               WORK( J2-KA ), KA1 )
  140       CONTINUE
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            DO 150 J = J1, J2, -KA1
               WORK( J ) = WORK( J-KA )
               WORK( N+J ) = WORK( N+J-KA )
  150       CONTINUE
            DO 160 J = J2, J1, KA1
!
!              create nonzero element a(j-ka,j+1) outside the band
!              and store it in WORK(j)
!
               WORK( J ) = WORK( J )*AB( 1, J+1 )
               AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
  160       CONTINUE
            IF( UPDATE ) THEN
               IF( I-K.LT.N-KA .AND. K.LE.KBT ) &
                  WORK( I-K+KA ) = WORK( I-K )
            END IF
  170    CONTINUE
!
         DO 210 K = KB, 1, -1
            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            IF( NR.GT.0 ) THEN
!
!              generate rotations in 2nd set to annihilate elements
!              which have been created outside the band
!
               CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1, &
                            WORK( N+J2 ), KA1 )
!
!              apply rotations in 2nd set from the right
!
               DO 180 L = 1, KA - 1
                  CALL DLARTV( NR, AB( KA1-L, J2 ), INCA, &
                               AB( KA-L, J2+1 ), INCA, WORK( N+J2 ), &
                               WORK( J2 ), KA1 )
  180          CONTINUE
!
!              apply rotations in 2nd set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ), &
                            AB( KA, J2+1 ), INCA, WORK( N+J2 ), &
                            WORK( J2 ), KA1 )
!
            END IF
!
!           start applying rotations in 2nd set from the left
!
            DO 190 L = KA - 1, KB - K + 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, &
                               AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ), &
                               WORK( J2 ), KA1 )
  190       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 2nd set
!
               DO 200 J = J2, J1, KA1
                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, &
                             WORK( N+J ), WORK( J ) )
  200          CONTINUE
            END IF
  210    CONTINUE
!
         DO 230 K = 1, KB - 1
            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
!
!           finish applying rotations in 1st set from the left
!
            DO 220 L = KB - K, 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA, &
                               AB( L+1, J2+KA1-L ), INCA, &
                               WORK( N+J2-M ), WORK( J2-M ), KA1 )
  220       CONTINUE
  230    CONTINUE
!
         IF( KB.GT.1 ) THEN
            DO 240 J = N - 1, I - KB + 2*KA + 1, -1
               WORK( N+J-M ) = WORK( N+J-KA-M )
               WORK( J-M ) = WORK( J-KA-M )
  240       CONTINUE
         END IF
!
      ELSE
!
!        Transform A, working with the lower triangle
!
         IF( UPDATE ) THEN
!
!           Form  inv(S(i))**T * A * inv(S(i))
!
            BII = BB( 1, I )
            DO 250 J = I, I1
               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
  250       CONTINUE
            DO 260 J = MAX( 1, I-KA ), I
               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
  260       CONTINUE
            DO 290 K = I - KBT, I - 1
               DO 270 J = I - KBT, K
                  AB( K-J+1, J ) = AB( K-J+1, J ) - &
                                   BB( I-J+1, J )*AB( I-K+1, K ) - &
                                   BB( I-K+1, K )*AB( I-J+1, J ) + &
                                   AB( 1, I )*BB( I-J+1, J )* &
                                   BB( I-K+1, K )
  270          CONTINUE
               DO 280 J = MAX( 1, I-KA ), I - KBT - 1
                  AB( K-J+1, J ) = AB( K-J+1, J ) - &
                                   BB( I-K+1, K )*AB( I-J+1, J )
  280          CONTINUE
  290       CONTINUE
            DO 310 J = I, I1
               DO 300 K = MAX( J-KA, I-KBT ), I - 1
                  AB( J-K+1, K ) = AB( J-K+1, K ) - &
                                   BB( I-K+1, K )*AB( J-I+1, I )
  300          CONTINUE
  310       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by inv(S(i))
!
               CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
               IF( KBT.GT.0 ) &
                  CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1, &
                             BB( KBT+1, I-KBT ), LDBB-1, &
                             X( M+1, I-KBT ), LDX )
            END IF
!
!           store a(i1,i) in RA1 for use in next loop over K
!
            RA1 = AB( I1-I+1, I )
         END IF
!
!        Generate and apply vectors of rotations to chase all the
!        existing bulges KA positions down toward the bottom of the
!        band
!
         DO 360 K = 1, KB - 1
            IF( UPDATE ) THEN
!
!              Determine the rotations which would annihilate the bulge
!              which has in theory just been created
!
               IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
!
!                 generate rotation to annihilate a(i-k+ka+1,i)
!
                  CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ), &
                               WORK( I-K+KA-M ), RA )
!
!                 create nonzero element a(i-k+ka+1,i-k) outside the
!                 band and store it in WORK(i-k)
!
                  T = -BB( K+1, I-K )*RA1
                  WORK( I-K ) = WORK( N+I-K+KA-M )*T - &
                                WORK( I-K+KA-M )*AB( KA1, I-K )
                  AB( KA1, I-K ) = WORK( I-K+KA-M )*T + &
                                   WORK( N+I-K+KA-M )*AB( KA1, I-K )
                  RA1 = RA
               END IF
            END IF
            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            IF( UPDATE ) THEN
               J2T = MAX( J2, I+2*KA-K+1 )
            ELSE
               J2T = J2
            END IF
            NRT = ( N-J2T+KA ) / KA1
            DO 320 J = J2T, J1, KA1
!
!              create nonzero element a(j+1,j-ka) outside the band
!              and store it in WORK(j-m)
!
               WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
               AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
  320       CONTINUE
!
!           generate rotations in 1st set to annihilate elements which
!           have been created outside the band
!
            IF( NRT.GT.0 ) &
               CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ), &
                            KA1, WORK( N+J2T-M ), KA1 )
            IF( NR.GT.0 ) THEN
!
!              apply rotations in 1st set from the left
!
               DO 330 L = 1, KA - 1
                  CALL DLARTV( NR, AB( L+1, J2-L ), INCA, &
                               AB( L+2, J2-L ), INCA, WORK( N+J2-M ), &
                               WORK( J2-M ), KA1 )
  330          CONTINUE
!
!              apply rotations in 1st set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), &
                            INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
!
            END IF
!
!           start applying rotations in 1st set from the right
!
            DO 340 L = KA - 1, KB - K + 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, &
                               AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), &
                               WORK( J2-M ), KA1 )
  340       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 1st set
!
               DO 350 J = J2, J1, KA1
                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, &
                             WORK( N+J-M ), WORK( J-M ) )
  350          CONTINUE
            END IF
  360    CONTINUE
!
         IF( UPDATE ) THEN
            IF( I2.LE.N .AND. KBT.GT.0 ) THEN
!
!              create nonzero element a(i-kbt+ka+1,i-kbt) outside the
!              band and store it in WORK(i-kbt)
!
               WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
            END IF
         END IF
!
         DO 400 K = KB, 1, -1
            IF( UPDATE ) THEN
               J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
            ELSE
               J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
            END IF
!
!           finish applying rotations in 2nd set from the right
!
            DO 370 L = KB - K, 1, -1
               NRT = ( N-J2+KA+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA, &
                               AB( KA1-L, J2-KA+1 ), INCA, &
                               WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
  370       CONTINUE
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            DO 380 J = J1, J2, -KA1
               WORK( J ) = WORK( J-KA )
               WORK( N+J ) = WORK( N+J-KA )
  380       CONTINUE
            DO 390 J = J2, J1, KA1
!
!              create nonzero element a(j+1,j-ka) outside the band
!              and store it in WORK(j)
!
               WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
               AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
  390       CONTINUE
            IF( UPDATE ) THEN
               IF( I-K.LT.N-KA .AND. K.LE.KBT ) &
                  WORK( I-K+KA ) = WORK( I-K )
            END IF
  400    CONTINUE
!
         DO 440 K = KB, 1, -1
            J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
            NR = ( N-J2+KA ) / KA1
            J1 = J2 + ( NR-1 )*KA1
            IF( NR.GT.0 ) THEN
!
!              generate rotations in 2nd set to annihilate elements
!              which have been created outside the band
!
               CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1, &
                            WORK( N+J2 ), KA1 )
!
!              apply rotations in 2nd set from the left
!
               DO 410 L = 1, KA - 1
                  CALL DLARTV( NR, AB( L+1, J2-L ), INCA, &
                               AB( L+2, J2-L ), INCA, WORK( N+J2 ), &
                               WORK( J2 ), KA1 )
  410          CONTINUE
!
!              apply rotations in 2nd set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ), &
                            INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
!
            END IF
!
!           start applying rotations in 2nd set from the right
!
            DO 420 L = KA - 1, KB - K + 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, &
                               AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ), &
                               WORK( J2 ), KA1 )
  420       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 2nd set
!
               DO 430 J = J2, J1, KA1
                  CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1, &
                             WORK( N+J ), WORK( J ) )
  430          CONTINUE
            END IF
  440    CONTINUE
!
         DO 460 K = 1, KB - 1
            J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
!
!           finish applying rotations in 1st set from the right
!
            DO 450 L = KB - K, 1, -1
               NRT = ( N-J2+L ) / KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA, &
                               AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ), &
                               WORK( J2-M ), KA1 )
  450       CONTINUE
  460    CONTINUE
!
         IF( KB.GT.1 ) THEN
            DO 470 J = N - 1, I - KB + 2*KA + 1, -1
               WORK( N+J-M ) = WORK( N+J-KA-M )
               WORK( J-M ) = WORK( J-KA-M )
  470       CONTINUE
         END IF
!
      END IF
!
      GO TO 10
!
  480 CONTINUE
!
!     **************************** Phase 2 *****************************
!
!     The logical structure of this phase is:
!
!     UPDATE = .TRUE.
!     DO I = 1, M
!        use S(i) to update A and create a new bulge
!        apply rotations to push all bulges KA positions upward
!     END DO
!     UPDATE = .FALSE.
!     DO I = M - KA - 1, 2, -1
!        apply rotations to push all bulges KA positions upward
!     END DO
!
!     To avoid duplicating code, the two loops are merged.
!
      UPDATE = .TRUE.
      I = 0
  490 CONTINUE
      IF( UPDATE ) THEN
         I = I + 1
         KBT = MIN( KB, M-I )
         I0 = I + 1
         I1 = MAX( 1, I-KA )
         I2 = I + KBT - KA1
         IF( I.GT.M ) THEN
            UPDATE = .FALSE.
            I = I - 1
            I0 = M + 1
            IF( KA.EQ.0 ) &
               RETURN
            GO TO 490
         END IF
      ELSE
         I = I - KA
         IF( I.LT.2 ) &
            RETURN
      END IF
!
      IF( I.LT.M-KBT ) THEN
         NX = M
      ELSE
         NX = N
      END IF
!
      IF( UPPER ) THEN
!
!        Transform A, working with the upper triangle
!
         IF( UPDATE ) THEN
!
!           Form  inv(S(i))**T * A * inv(S(i))
!
            BII = BB( KB1, I )
            DO 500 J = I1, I
               AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
  500       CONTINUE
            DO 510 J = I, MIN( N, I+KA )
               AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
  510       CONTINUE
            DO 540 K = I + 1, I + KBT
               DO 520 J = K, I + KBT
                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - &
                                     BB( I-J+KB1, J )*AB( I-K+KA1, K ) - &
                                     BB( I-K+KB1, K )*AB( I-J+KA1, J ) + &
                                     AB( KA1, I )*BB( I-J+KB1, J )* &
                                     BB( I-K+KB1, K )
  520          CONTINUE
               DO 530 J = I + KBT + 1, MIN( N, I+KA )
                  AB( K-J+KA1, J ) = AB( K-J+KA1, J ) - &
                                     BB( I-K+KB1, K )*AB( I-J+KA1, J )
  530          CONTINUE
  540       CONTINUE
            DO 560 J = I1, I
               DO 550 K = I + 1, MIN( J+KA, I+KBT )
                  AB( J-K+KA1, K ) = AB( J-K+KA1, K ) - &
                                     BB( I-K+KB1, K )*AB( J-I+KA1, I )
  550          CONTINUE
  560       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by inv(S(i))
!
               CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
               IF( KBT.GT.0 ) &
                  CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ), &
                             LDBB-1, X( 1, I+1 ), LDX )
            END IF
!
!           store a(i1,i) in RA1 for use in next loop over K
!
            RA1 = AB( I1-I+KA1, I )
         END IF
!
!        Generate and apply vectors of rotations to chase all the
!        existing bulges KA positions up toward the top of the band
!
         DO 610 K = 1, KB - 1
            IF( UPDATE ) THEN
!
!              Determine the rotations which would annihilate the bulge
!              which has in theory just been created
!
               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
!
!                 generate rotation to annihilate a(i+k-ka-1,i)
!
                  CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ), &
                               WORK( I+K-KA ), RA )
!
!                 create nonzero element a(i+k-ka-1,i+k) outside the
!                 band and store it in WORK(m-kb+i+k)
!
                  T = -BB( KB1-K, I+K )*RA1
                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - &
                                     WORK( I+K-KA )*AB( 1, I+K )
                  AB( 1, I+K ) = WORK( I+K-KA )*T + &
                                 WORK( N+I+K-KA )*AB( 1, I+K )
                  RA1 = RA
               END IF
            END IF
            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            IF( UPDATE ) THEN
               J2T = MIN( J2, I-2*KA+K-1 )
            ELSE
               J2T = J2
            END IF
            NRT = ( J2T+KA-1 ) / KA1
            DO 570 J = J1, J2T, KA1
!
!              create nonzero element a(j-1,j+ka) outside the band
!              and store it in WORK(j)
!
               WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
               AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
  570       CONTINUE
!
!           generate rotations in 1st set to annihilate elements which
!           have been created outside the band
!
            IF( NRT.GT.0 ) &
               CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1, &
                            WORK( N+J1 ), KA1 )
            IF( NR.GT.0 ) THEN
!
!              apply rotations in 1st set from the left
!
               DO 580 L = 1, KA - 1
                  CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, &
                               AB( KA-L, J1+L ), INCA, WORK( N+J1 ), &
                               WORK( J1 ), KA1 )
  580          CONTINUE
!
!              apply rotations in 1st set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), &
                            AB( KA, J1 ), INCA, WORK( N+J1 ), &
                            WORK( J1 ), KA1 )
!
            END IF
!
!           start applying rotations in 1st set from the right
!
            DO 590 L = KA - 1, KB - K + 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J1T ), INCA, &
                               AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), &
                               WORK( J1T ), KA1 )
  590       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 1st set
!
               DO 600 J = J1, J2, KA1
                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, &
                             WORK( N+J ), WORK( J ) )
  600          CONTINUE
            END IF
  610    CONTINUE
!
         IF( UPDATE ) THEN
            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
!
!              create nonzero element a(i+kbt-ka-1,i+kbt) outside the
!              band and store it in WORK(m-kb+i+kbt)
!
               WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
            END IF
         END IF
!
         DO 650 K = KB, 1, -1
            IF( UPDATE ) THEN
               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
            ELSE
               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
            END IF
!
!           finish applying rotations in 2nd set from the right
!
            DO 620 L = KB - K, 1, -1
               NRT = ( J2+KA+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J1T+KA ), INCA, &
                               AB( L+1, J1T+KA-1 ), INCA, &
                               WORK( N+M-KB+J1T+KA ), &
                               WORK( M-KB+J1T+KA ), KA1 )
  620       CONTINUE
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            DO 630 J = J1, J2, KA1
               WORK( M-KB+J ) = WORK( M-KB+J+KA )
               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
  630       CONTINUE
            DO 640 J = J1, J2, KA1
!
!              create nonzero element a(j-1,j+ka) outside the band
!              and store it in WORK(m-kb+j)
!
               WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
               AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
  640       CONTINUE
            IF( UPDATE ) THEN
               IF( I+K.GT.KA1 .AND. K.LE.KBT ) &
                  WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
            END IF
  650    CONTINUE
!
         DO 690 K = KB, 1, -1
            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            IF( NR.GT.0 ) THEN
!
!              generate rotations in 2nd set to annihilate elements
!              which have been created outside the band
!
               CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ), &
                            KA1, WORK( N+M-KB+J1 ), KA1 )
!
!              apply rotations in 2nd set from the left
!
               DO 660 L = 1, KA - 1
                  CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA, &
                               AB( KA-L, J1+L ), INCA, &
                               WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
  660          CONTINUE
!
!              apply rotations in 2nd set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ), &
                            AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ), &
                            WORK( M-KB+J1 ), KA1 )
!
            END IF
!
!           start applying rotations in 2nd set from the right
!
            DO 670 L = KA - 1, KB - K + 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J1T ), INCA, &
                               AB( L+1, J1T-1 ), INCA, &
                               WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), &
                               KA1 )
  670       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 2nd set
!
               DO 680 J = J1, J2, KA1
                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, &
                             WORK( N+M-KB+J ), WORK( M-KB+J ) )
  680          CONTINUE
            END IF
  690    CONTINUE
!
         DO 710 K = 1, KB - 1
            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
!
!           finish applying rotations in 1st set from the right
!
            DO 700 L = KB - K, 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( L, J1T ), INCA, &
                               AB( L+1, J1T-1 ), INCA, WORK( N+J1T ), &
                               WORK( J1T ), KA1 )
  700       CONTINUE
  710    CONTINUE
!
         IF( KB.GT.1 ) THEN
            DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
               WORK( N+J ) = WORK( N+J+KA )
               WORK( J ) = WORK( J+KA )
  720       CONTINUE
         END IF
!
      ELSE
!
!        Transform A, working with the lower triangle
!
         IF( UPDATE ) THEN
!
!           Form  inv(S(i))**T * A * inv(S(i))
!
            BII = BB( 1, I )
            DO 730 J = I1, I
               AB( I-J+1, J ) = AB( I-J+1, J ) / BII
  730       CONTINUE
            DO 740 J = I, MIN( N, I+KA )
               AB( J-I+1, I ) = AB( J-I+1, I ) / BII
  740       CONTINUE
            DO 770 K = I + 1, I + KBT
               DO 750 J = K, I + KBT
                  AB( J-K+1, K ) = AB( J-K+1, K ) - &
                                   BB( J-I+1, I )*AB( K-I+1, I ) - &
                                   BB( K-I+1, I )*AB( J-I+1, I ) + &
                                   AB( 1, I )*BB( J-I+1, I )* &
                                   BB( K-I+1, I )
  750          CONTINUE
               DO 760 J = I + KBT + 1, MIN( N, I+KA )
                  AB( J-K+1, K ) = AB( J-K+1, K ) - &
                                   BB( K-I+1, I )*AB( J-I+1, I )
  760          CONTINUE
  770       CONTINUE
            DO 790 J = I1, I
               DO 780 K = I + 1, MIN( J+KA, I+KBT )
                  AB( K-J+1, J ) = AB( K-J+1, J ) - &
                                   BB( K-I+1, I )*AB( I-J+1, J )
  780          CONTINUE
  790       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by inv(S(i))
!
               CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
               IF( KBT.GT.0 ) &
                  CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1, &
                             X( 1, I+1 ), LDX )
            END IF
!
!           store a(i,i1) in RA1 for use in next loop over K
!
            RA1 = AB( I-I1+1, I1 )
         END IF
!
!        Generate and apply vectors of rotations to chase all the
!        existing bulges KA positions up toward the top of the band
!
         DO 840 K = 1, KB - 1
            IF( UPDATE ) THEN
!
!              Determine the rotations which would annihilate the bulge
!              which has in theory just been created
!
               IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
!
!                 generate rotation to annihilate a(i,i+k-ka-1)
!
                  CALL DLARTG( AB( KA1-K, I+K-KA ), RA1, &
                               WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
!
!                 create nonzero element a(i+k,i+k-ka-1) outside the
!                 band and store it in WORK(m-kb+i+k)
!
                  T = -BB( K+1, I )*RA1
                  WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T - &
                                     WORK( I+K-KA )*AB( KA1, I+K-KA )
                  AB( KA1, I+K-KA ) = WORK( I+K-KA )*T + &
                                      WORK( N+I+K-KA )*AB( KA1, I+K-KA )
                  RA1 = RA
               END IF
            END IF
            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            IF( UPDATE ) THEN
               J2T = MIN( J2, I-2*KA+K-1 )
            ELSE
               J2T = J2
            END IF
            NRT = ( J2T+KA-1 ) / KA1
            DO 800 J = J1, J2T, KA1
!
!              create nonzero element a(j+ka,j-1) outside the band
!              and store it in WORK(j)
!
               WORK( J ) = WORK( J )*AB( KA1, J-1 )
               AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
  800       CONTINUE
!
!           generate rotations in 1st set to annihilate elements which
!           have been created outside the band
!
            IF( NRT.GT.0 ) &
               CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1, &
                            WORK( N+J1 ), KA1 )
            IF( NR.GT.0 ) THEN
!
!              apply rotations in 1st set from the right
!
               DO 810 L = 1, KA - 1
                  CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), &
                               INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
  810          CONTINUE
!
!              apply rotations in 1st set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), &
                            AB( 2, J1-1 ), INCA, WORK( N+J1 ), &
                            WORK( J1 ), KA1 )
!
            END IF
!
!           start applying rotations in 1st set from the left
!
            DO 820 L = KA - 1, KB - K + 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, &
                               AB( KA1-L, J1T-KA1+L ), INCA, &
                               WORK( N+J1T ), WORK( J1T ), KA1 )
  820       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 1st set
!
               DO 830 J = J1, J2, KA1
                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, &
                             WORK( N+J ), WORK( J ) )
  830          CONTINUE
            END IF
  840    CONTINUE
!
         IF( UPDATE ) THEN
            IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
!
!              create nonzero element a(i+kbt,i+kbt-ka-1) outside the
!              band and store it in WORK(m-kb+i+kbt)
!
               WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
            END IF
         END IF
!
         DO 880 K = KB, 1, -1
            IF( UPDATE ) THEN
               J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
            ELSE
               J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
            END IF
!
!           finish applying rotations in 2nd set from the left
!
            DO 850 L = KB - K, 1, -1
               NRT = ( J2+KA+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA, &
                               AB( KA1-L, J1T+L-1 ), INCA, &
                               WORK( N+M-KB+J1T+KA ), &
                               WORK( M-KB+J1T+KA ), KA1 )
  850       CONTINUE
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            DO 860 J = J1, J2, KA1
               WORK( M-KB+J ) = WORK( M-KB+J+KA )
               WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
  860       CONTINUE
            DO 870 J = J1, J2, KA1
!
!              create nonzero element a(j+ka,j-1) outside the band
!              and store it in WORK(m-kb+j)
!
               WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
               AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
  870       CONTINUE
            IF( UPDATE ) THEN
               IF( I+K.GT.KA1 .AND. K.LE.KBT ) &
                  WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
            END IF
  880    CONTINUE
!
         DO 920 K = KB, 1, -1
            J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
            NR = ( J2+KA-1 ) / KA1
            J1 = J2 - ( NR-1 )*KA1
            IF( NR.GT.0 ) THEN
!
!              generate rotations in 2nd set to annihilate elements
!              which have been created outside the band
!
               CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ), &
                            KA1, WORK( N+M-KB+J1 ), KA1 )
!
!              apply rotations in 2nd set from the right
!
               DO 890 L = 1, KA - 1
                  CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ), &
                               INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), &
                               KA1 )
  890          CONTINUE
!
!              apply rotations in 2nd set from both sides to diagonal
!              blocks
!
               CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ), &
                            AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ), &
                            WORK( M-KB+J1 ), KA1 )
!
            END IF
!
!           start applying rotations in 2nd set from the left
!
            DO 900 L = KA - 1, KB - K + 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, &
                               AB( KA1-L, J1T-KA1+L ), INCA, &
                               WORK( N+M-KB+J1T ), WORK( M-KB+J1T ), &
                               KA1 )
  900       CONTINUE
!
            IF( WANTX ) THEN
!
!              post-multiply X by product of rotations in 2nd set
!
               DO 910 J = J1, J2, KA1
                  CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1, &
                             WORK( N+M-KB+J ), WORK( M-KB+J ) )
  910          CONTINUE
            END IF
  920    CONTINUE
!
         DO 940 K = 1, KB - 1
            J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
!
!           finish applying rotations in 1st set from the left
!
            DO 930 L = KB - K, 1, -1
               NRT = ( J2+L-1 ) / KA1
               J1T = J2 - ( NRT-1 )*KA1
               IF( NRT.GT.0 ) &
                  CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA, &
                               AB( KA1-L, J1T-KA1+L ), INCA, &
                               WORK( N+J1T ), WORK( J1T ), KA1 )
  930       CONTINUE
  940    CONTINUE
!
         IF( KB.GT.1 ) THEN
            DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
               WORK( N+J ) = WORK( N+J+KA )
               WORK( J ) = WORK( J+KA )
  950       CONTINUE
         END IF
!
      END IF
!
      GO TO 490
!
!     End of DSBGST
!
      END
      SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, &
                        LDZ, WORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, KA, KB, LDAB, LDBB, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), W( * ), &
                         WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBGV computes all the eigenvalues, and optionally, the eigenvectors
!  of a real generalized symmetric-definite banded eigenproblem, of
!  the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!  and banded, and B is also positive definite.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  KA      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
!
!  KB      (input) INTEGER
!          The number of superdiagonals of the matrix B if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first ka+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!
!          On exit, the contents of AB are destroyed.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KA+1.
!
!  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix B, stored in the first kb+1 rows of the array.  The
!          j-th column of B is stored in the j-th column of the array BB
!          as follows:
!          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
!          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
!
!          On exit, the factor S from the split Cholesky factorization
!          B = S**T*S, as returned by DPBSTF.
!
!  LDBB    (input) INTEGER
!          The leading dimension of the array BB.  LDBB >= KB+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!          eigenvectors, with the i-th column of Z holding the
!          eigenvector associated with W(i). The eigenvectors are
!          normalized so that Z**T*B*Z = I.
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= N.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is:
!             <= N:  the algorithm failed to converge:
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero;
!             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF
!                    returned INFO = i: B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            UPPER, WANTZ
      CHARACTER          VECT
      INTEGER            IINFO, INDE, INDWRK
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KA.LT.0 ) THEN
         INFO = -4
      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KA+1 ) THEN
         INFO = -7
      ELSE IF( LDBB.LT.KB+1 ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBGV ', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a split Cholesky factorization of B.
!
      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem.
!
      INDE = 1
      INDWRK = INDE + N
      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     Reduce to tridiagonal form.
!
      IF( WANTZ ) THEN
         VECT = 'U'
      ELSE
         VECT = 'N'
      END IF
      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, call SSTEQR.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), &
                      INFO )
      END IF
      RETURN
!
!     End of DSBGV
!
      END
      SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, &
                         Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), W( * ), &
                         WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
!  of a real generalized symmetric-definite banded eigenproblem, of the
!  form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric and
!  banded, and B is also positive definite.  If eigenvectors are
!  desired, it uses a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  KA      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
!
!  KB      (input) INTEGER
!          The number of superdiagonals of the matrix B if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first ka+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!
!          On exit, the contents of AB are destroyed.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KA+1.
!
!  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix B, stored in the first kb+1 rows of the array.  The
!          j-th column of B is stored in the j-th column of the array BB
!          as follows:
!          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
!          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
!
!          On exit, the factor S from the split Cholesky factorization
!          B = S**T*S, as returned by DPBSTF.
!
!  LDBB    (input) INTEGER
!          The leading dimension of the array BB.  LDBB >= KB+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!          eigenvectors, with the i-th column of Z holding the
!          eigenvector associated with W(i).  The eigenvectors are
!          normalized so Z**T*B*Z = I.
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If N <= 1,               LWORK >= 1.
!          If JOBZ = 'N' and N > 1, LWORK >= 3*N.
!          If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
!          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is:
!             <= N:  the algorithm failed to converge:
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero;
!             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF
!                    returned INFO = i: B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER, WANTZ
      CHARACTER          VECT
      INTEGER            IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2, &
                         LWMIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC, &
                         DSTERF, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LIWMIN = 1
         LWMIN = 1
      ELSE
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 5*N + 2*N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N
         END IF
      END IF
!
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KA.LT.0 ) THEN
         INFO = -4
      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KA+1 ) THEN
         INFO = -7
      ELSE IF( LDBB.LT.KB+1 ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -14
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -16
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBGVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a split Cholesky factorization of B.
!
      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem.
!
      INDE = 1
      INDWRK = INDE + N
      INDWK2 = INDWRK + N*N
      LLWRK2 = LWORK - INDWK2 + 1
      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     Reduce to tridiagonal form.
!
      IF( WANTZ ) THEN
         VECT = 'U'
      ELSE
         VECT = 'N'
      END IF
      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ, &
                   WORK( INDWRK ), IINFO )
!
!     For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, &
                      WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
         CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N, &
                     ZERO, WORK( INDWK2 ), N )
         CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
      END IF
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DSBGVD
!
      END
      SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, &
                         LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, &
                         LDZ, WORK, IWORK, IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M, &
                         N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ), &
                         W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSBGVX computes selected eigenvalues, and optionally, eigenvectors
!  of a real generalized symmetric-definite banded eigenproblem, of
!  the form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric
!  and banded, and B is also positive definite.  Eigenvalues and
!  eigenvectors can be selected by specifying either all eigenvalues,
!  a range of values or a range of indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  KA      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.
!
!  KB      (input) INTEGER
!          The number of superdiagonals of the matrix B if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first ka+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!
!          On exit, the contents of AB are destroyed.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KA+1.
!
!  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix B, stored in the first kb+1 rows of the array.  The
!          j-th column of B is stored in the j-th column of the array BB
!          as follows:
!          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
!          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
!
!          On exit, the factor S from the split Cholesky factorization
!          B = S**T*S, as returned by DPBSTF.
!
!  LDBB    (input) INTEGER
!          The leading dimension of the array BB.  LDBB >= KB+1.
!
!  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
!          If JOBZ = 'V', the n-by-n matrix used in the reduction of
!          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
!          and consequently C to tridiagonal form.
!          If JOBZ = 'N', the array Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  If JOBZ = 'N',
!          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!          eigenvectors, with the i-th column of Z holding the
!          eigenvector associated with W(i).  The eigenvectors are
!          normalized so Z**T*B*Z = I.
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (7N)
!
!  IWORK   (workspace/output) INTEGER array, dimension (5N)
!
!  IFAIL   (input) INTEGER array, dimension (M)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvalues that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0 : successful exit
!          < 0 : if INFO = -i, the i-th argument had an illegal value
!          <= N: if INFO = i, then i eigenvectors failed to converge.
!                  Their indices are stored in IFAIL.
!          > N : DPBSTF returned an error code; i.e.,
!                if INFO = N + i, for 1 <= i <= N, then the leading
!                minor of order i of B is not positive definite.
!                The factorization of B could not be completed and
!                no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
      CHARACTER          ORDER, VECT
      INTEGER            I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP, &
                         INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
      DOUBLE PRECISION   TMP1
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD, &
                         DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( KA.LT.0 ) THEN
         INFO = -5
      ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KA+1 ) THEN
         INFO = -8
      ELSE IF( LDBB.LT.KB+1 ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 ) THEN
         INFO = -12
      ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
         INFO = -14
      ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
         INFO = -15
      ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
         INFO = -16
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -21
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBGVX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Form a split Cholesky factorization of B.
!
      CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem.
!
      CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, &
                   WORK, IINFO )
!
!     Reduce symmetric band matrix to tridiagonal form.
!
      INDD = 1
      INDE = INDD + N
      INDWRK = INDE + N
      IF( WANTZ ) THEN
         VECT = 'U'
      ELSE
         VECT = 'N'
      END IF
      CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ), &
                   WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
!
!     If all eigenvalues are desired and ABSTOL is less than or equal
!     to zero, then call DSTERF or SSTEQR.  If this fails for some
!     eigenvalue, then try DSTEBZ.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
         INDEE = INDWRK + 2*N
         CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
         IF( .NOT.WANTZ ) THEN
            CALL DSTERF( N, W, WORK( INDEE ), INFO )
         ELSE
            CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, &
                         WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 10 I = 1, N
                  IFAIL( I ) = 0
   10          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 30
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired,
!     call DSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, &
                   WORK( INDD ), WORK( INDE ), M, NSPLIT, W, &
                   IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, &
                      IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, &
                      WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
!
!        Apply transformation matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         DO 20 J = 1, M
            CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
            CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO, &
                        Z( 1, J ), 1 )
   20    CONTINUE
      END IF
!
   30 CONTINUE
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 50 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 40 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   40       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of DSBGVX
!
      END
      SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, &
                         WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO, VECT
      INTEGER            INFO, KD, LDAB, LDQ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSBTRD reduces a real symmetric band matrix A to symmetric
!  tridiagonal form T by an orthogonal similarity transformation:
!  Q**T * A * Q = T.
!
!  Arguments
!  =========
!
!  VECT    (input) CHARACTER*1
!          = 'N':  do not form Q;
!          = 'V':  form Q;
!          = 'U':  update a matrix X, by forming X*Q.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals of the matrix A if UPLO = 'U',
!          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!
!  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
!          On entry, the upper or lower triangle of the symmetric band
!          matrix A, stored in the first KD+1 rows of the array.  The
!          j-th column of A is stored in the j-th column of the array AB
!          as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!          On exit, the diagonal elements of AB are overwritten by the
!          diagonal elements of the tridiagonal matrix T; if KD > 0, the
!          elements on the first superdiagonal (if UPLO = 'U') or the
!          first subdiagonal (if UPLO = 'L') are overwritten by the
!          off-diagonal elements of T; the rest of AB is overwritten by
!          values generated during the reduction.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T.
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          The off-diagonal elements of the tridiagonal matrix T:
!          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if VECT = 'U', then Q must contain an N-by-N
!          matrix X; if VECT = 'N' or 'V', then Q need not be set.
!
!          On exit:
!          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
!          if VECT = 'U', Q contains the product X*Q;
!          if VECT = 'N', the array Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.
!          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  Modified by Linda Kaufman, Bell Labs.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            INITQ, UPPER, WANTQ
      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J, &
                         J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1, &
                         KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
      DOUBLE PRECISION   TEMP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INITQ = LSAME( VECT, 'V' )
      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
      UPPER = LSAME( UPLO, 'U' )
      KD1 = KD + 1
      KDM1 = KD - 1
      INCX = LDAB - 1
      IQEND = 1
!
      INFO = 0
      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KD.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD1 ) THEN
         INFO = -6
      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSBTRD', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Initialize Q to the unit matrix, if needed
!
      IF( INITQ ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
!
!     Wherever possible, plane rotations are generated and applied in
!     vector operations of length NR over the index set J1:J2:KD1.
!
!     The cosines and sines of the plane rotations are stored in the
!     arrays D and WORK.
!
      INCA = KD1*LDAB
      KDN = MIN( N-1, KD )
      IF( UPPER ) THEN
!
         IF( KD.GT.1 ) THEN
!
!           Reduce to tridiagonal form, working with upper triangle
!
            NR = 0
            J1 = KDN + 2
            J2 = 1
!
            DO 90 I = 1, N - 2
!
!              Reduce i-th row of matrix to tridiagonal form
!
               DO 80 K = KDN + 1, 2, -1
                  J1 = J1 + KDN
                  J2 = J2 + KDN
!
                  IF( NR.GT.0 ) THEN
!
!                    generate plane rotations to annihilate nonzero
!                    elements which have been created outside the band
!
                     CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ), &
                                  KD1, D( J1 ), KD1 )
!
!                    apply rotations from the right
!
!
!                    Dependent on the the number of diagonals either
!                    DLARTV or DROT is used
!
                     IF( NR.GE.2*KD-1 ) THEN
                        DO 10 L = 1, KD - 1
                           CALL DLARTV( NR, AB( L+1, J1-1 ), INCA, &
                                        AB( L, J1 ), INCA, D( J1 ), &
                                        WORK( J1 ), KD1 )
   10                   CONTINUE
!
                     ELSE
                        JEND = J1 + ( NR-1 )*KD1
                        DO 20 JINC = J1, JEND, KD1
                           CALL DROT( KDM1, AB( 2, JINC-1 ), 1, &
                                      AB( 1, JINC ), 1, D( JINC ), &
                                      WORK( JINC ) )
   20                   CONTINUE
                     END IF
                  END IF
!
!
                  IF( K.GT.2 ) THEN
                     IF( K.LE.N-I+1 ) THEN
!
!                       generate plane rotation to annihilate a(i,i+k-1)
!                       within the band
!
                        CALL DLARTG( AB( KD-K+3, I+K-2 ), &
                                     AB( KD-K+2, I+K-1 ), D( I+K-1 ), &
                                     WORK( I+K-1 ), TEMP )
                        AB( KD-K+3, I+K-2 ) = TEMP
!
!                       apply rotation from the right
!
                        CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1, &
                                   AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ), &
                                   WORK( I+K-1 ) )
                     END IF
                     NR = NR + 1
                     J1 = J1 - KDN - 1
                  END IF
!
!                 apply plane rotations from both sides to diagonal
!                 blocks
!
                  IF( NR.GT.0 ) &
                     CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ), &
                                  AB( KD, J1 ), INCA, D( J1 ), &
                                  WORK( J1 ), KD1 )
!
!                 apply plane rotations from the left
!
                  IF( NR.GT.0 ) THEN
                     IF( 2*KD-1.LT.NR ) THEN
!
!                    Dependent on the the number of diagonals either
!                    DLARTV or DROT is used
!
                        DO 30 L = 1, KD - 1
                           IF( J2+L.GT.N ) THEN
                              NRT = NR - 1
                           ELSE
                              NRT = NR
                           END IF
                           IF( NRT.GT.0 ) &
                              CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA, &
                                           AB( KD-L+1, J1+L ), INCA, &
                                           D( J1 ), WORK( J1 ), KD1 )
   30                   CONTINUE
                     ELSE
                        J1END = J1 + KD1*( NR-2 )
                        IF( J1END.GE.J1 ) THEN
                           DO 40 JIN = J1, J1END, KD1
                              CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX, &
                                         AB( KD, JIN+1 ), INCX, &
                                         D( JIN ), WORK( JIN ) )
   40                      CONTINUE
                        END IF
                        LEND = MIN( KDM1, N-J2 )
                        LAST = J1END + KD1
                        IF( LEND.GT.0 ) &
                           CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX, &
                                      AB( KD, LAST+1 ), INCX, D( LAST ), &
                                      WORK( LAST ) )
                     END IF
                  END IF
!
                  IF( WANTQ ) THEN
!
!                    accumulate product of plane rotations in Q
!
                     IF( INITQ ) THEN
!
!                 take advantage of the fact that Q was
!                 initially the Identity matrix
!
                        IQEND = MAX( IQEND, J2 )
                        I2 = MAX( 0, K-3 )
                        IQAEND = 1 + I*KD
                        IF( K.EQ.2 ) &
                           IQAEND = IQAEND + KD
                        IQAEND = MIN( IQAEND, IQEND )
                        DO 50 J = J1, J2, KD1
                           IBL = I - I2 / KDM1
                           I2 = I2 + 1
                           IQB = MAX( 1, J-IBL )
                           NQ = 1 + IQAEND - IQB
                           IQAEND = MIN( IQAEND+KD, IQEND )
                           CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), &
                                      1, D( J ), WORK( J ) )
   50                   CONTINUE
                     ELSE
!
                        DO 60 J = J1, J2, KD1
                           CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, &
                                      D( J ), WORK( J ) )
   60                   CONTINUE
                     END IF
!
                  END IF
!
                  IF( J2+KDN.GT.N ) THEN
!
!                    adjust J2 to keep within the bounds of the matrix
!
                     NR = NR - 1
                     J2 = J2 - KDN - 1
                  END IF
!
                  DO 70 J = J1, J2, KD1
!
!                    create nonzero element a(j-1,j+kd) outside the band
!                    and store it in WORK
!
                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
         END IF
!
         IF( KD.GT.0 ) THEN
!
!           copy off-diagonal elements to E
!
            DO 100 I = 1, N - 1
               E( I ) = AB( KD, I+1 )
  100       CONTINUE
         ELSE
!
!           set E to zero if original matrix was diagonal
!
            DO 110 I = 1, N - 1
               E( I ) = ZERO
  110       CONTINUE
         END IF
!
!        copy diagonal elements to D
!
         DO 120 I = 1, N
            D( I ) = AB( KD1, I )
  120    CONTINUE
!
      ELSE
!
         IF( KD.GT.1 ) THEN
!
!           Reduce to tridiagonal form, working with lower triangle
!
            NR = 0
            J1 = KDN + 2
            J2 = 1
!
            DO 210 I = 1, N - 2
!
!              Reduce i-th column of matrix to tridiagonal form
!
               DO 200 K = KDN + 1, 2, -1
                  J1 = J1 + KDN
                  J2 = J2 + KDN
!
                  IF( NR.GT.0 ) THEN
!
!                    generate plane rotations to annihilate nonzero
!                    elements which have been created outside the band
!
                     CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA, &
                                  WORK( J1 ), KD1, D( J1 ), KD1 )
!
!                    apply plane rotations from one side
!
!
!                    Dependent on the the number of diagonals either
!                    DLARTV or DROT is used
!
                     IF( NR.GT.2*KD-1 ) THEN
                        DO 130 L = 1, KD - 1
                           CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA, &
                                        AB( KD1-L+1, J1-KD1+L ), INCA, &
                                        D( J1 ), WORK( J1 ), KD1 )
  130                   CONTINUE
                     ELSE
                        JEND = J1 + KD1*( NR-1 )
                        DO 140 JINC = J1, JEND, KD1
                           CALL DROT( KDM1, AB( KD, JINC-KD ), INCX, &
                                      AB( KD1, JINC-KD ), INCX, &
                                      D( JINC ), WORK( JINC ) )
  140                   CONTINUE
                     END IF
!
                  END IF
!
                  IF( K.GT.2 ) THEN
                     IF( K.LE.N-I+1 ) THEN
!
!                       generate plane rotation to annihilate a(i+k-1,i)
!                       within the band
!
                        CALL DLARTG( AB( K-1, I ), AB( K, I ), &
                                     D( I+K-1 ), WORK( I+K-1 ), TEMP )
                        AB( K-1, I ) = TEMP
!
!                       apply rotation from the left
!
                        CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1, &
                                   AB( K-1, I+1 ), LDAB-1, D( I+K-1 ), &
                                   WORK( I+K-1 ) )
                     END IF
                     NR = NR + 1
                     J1 = J1 - KDN - 1
                  END IF
!
!                 apply plane rotations from both sides to diagonal
!                 blocks
!
                  IF( NR.GT.0 ) &
                     CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ), &
                                  AB( 2, J1-1 ), INCA, D( J1 ), &
                                  WORK( J1 ), KD1 )
!
!                 apply plane rotations from the right
!
!
!                    Dependent on the the number of diagonals either
!                    DLARTV or DROT is used
!
                  IF( NR.GT.0 ) THEN
                     IF( NR.GT.2*KD-1 ) THEN
                        DO 150 L = 1, KD - 1
                           IF( J2+L.GT.N ) THEN
                              NRT = NR - 1
                           ELSE
                              NRT = NR
                           END IF
                           IF( NRT.GT.0 ) &
                              CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA, &
                                           AB( L+1, J1 ), INCA, D( J1 ), &
                                           WORK( J1 ), KD1 )
  150                   CONTINUE
                     ELSE
                        J1END = J1 + KD1*( NR-2 )
                        IF( J1END.GE.J1 ) THEN
                           DO 160 J1INC = J1, J1END, KD1
                              CALL DROT( KDM1, AB( 3, J1INC-1 ), 1, &
                                         AB( 2, J1INC ), 1, D( J1INC ), &
                                         WORK( J1INC ) )
  160                      CONTINUE
                        END IF
                        LEND = MIN( KDM1, N-J2 )
                        LAST = J1END + KD1
                        IF( LEND.GT.0 ) &
                           CALL DROT( LEND, AB( 3, LAST-1 ), 1, &
                                      AB( 2, LAST ), 1, D( LAST ), &
                                      WORK( LAST ) )
                     END IF
                  END IF
!
!
!
                  IF( WANTQ ) THEN
!
!                    accumulate product of plane rotations in Q
!
                     IF( INITQ ) THEN
!
!                 take advantage of the fact that Q was
!                 initially the Identity matrix
!
                        IQEND = MAX( IQEND, J2 )
                        I2 = MAX( 0, K-3 )
                        IQAEND = 1 + I*KD
                        IF( K.EQ.2 ) &
                           IQAEND = IQAEND + KD
                        IQAEND = MIN( IQAEND, IQEND )
                        DO 170 J = J1, J2, KD1
                           IBL = I - I2 / KDM1
                           I2 = I2 + 1
                           IQB = MAX( 1, J-IBL )
                           NQ = 1 + IQAEND - IQB
                           IQAEND = MIN( IQAEND+KD, IQEND )
                           CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ), &
                                      1, D( J ), WORK( J ) )
  170                   CONTINUE
                     ELSE
!
                        DO 180 J = J1, J2, KD1
                           CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1, &
                                      D( J ), WORK( J ) )
  180                   CONTINUE
                     END IF
                  END IF
!
                  IF( J2+KDN.GT.N ) THEN
!
!                    adjust J2 to keep within the bounds of the matrix
!
                     NR = NR - 1
                     J2 = J2 - KDN - 1
                  END IF
!
                  DO 190 J = J1, J2, KD1
!
!                    create nonzero element a(j+kd,j-1) outside the
!                    band and store it in WORK
!
                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
                     AB( KD1, J ) = D( J )*AB( KD1, J )
  190             CONTINUE
  200          CONTINUE
  210       CONTINUE
         END IF
!
         IF( KD.GT.0 ) THEN
!
!           copy off-diagonal elements to E
!
            DO 220 I = 1, N - 1
               E( I ) = AB( 2, I )
  220       CONTINUE
         ELSE
!
!           set E to zero if original matrix was diagonal
!
            DO 230 I = 1, N - 1
               E( I ) = ZERO
  230       CONTINUE
         END IF
!
!        copy diagonal elements to D
!
         DO 240 I = 1, N
            D( I ) = AB( 1, I )
  240    CONTINUE
      END IF
!
      RETURN
!
!     End of DSBTRD
!
      END
      DOUBLE PRECISION FUNCTION DSECND( )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!  Purpose
!  =======
!
!  DSECND returns the user time for a process in seconds.
!  This version gets the time from the system function ETIME.
!
! =====================================================================
!
!     .. Local Scalars ..
      REAL               T1
!     ..
!     .. Local Arrays ..
      REAL               TARRAY( 2 )
!     ..
!     .. External Functions ..
      REAL               ETIME
      EXTERNAL           ETIME
!     ..
!     .. Executable Statements ..
!
      call cpu_time ( dsecnd )
!     T1 = ETIME( TARRAY )
!     DSECND = TARRAY( 1 )
      RETURN
!
!     End of DSECND
!
      END
      SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPCON estimates the reciprocal of the condition number (in the
!  1-norm) of a real symmetric packed matrix A using the factorization
!  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The block diagonal matrix D and the multipliers used to
!          obtain the factor U or L as computed by DSPTRF, stored as a
!          packed triangular matrix.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSPTRF.
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  IWORK    (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IP, KASE
      DOUBLE PRECISION   AINVNM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DSPTRS, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.LE.ZERO ) THEN
         RETURN
      END IF
!
!     Check that the diagonal matrix D is nonsingular.
!
      IF( UPPER ) THEN
!
!        Upper triangular storage: examine D from bottom to top
!
         IP = N*( N+1 ) / 2
         DO 10 I = N, 1, -1
            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) &
               RETURN
            IP = IP - I
   10    CONTINUE
      ELSE
!
!        Lower triangular storage: examine D from top to bottom.
!
         IP = 1
         DO 20 I = 1, N
            IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO ) &
               RETURN
            IP = IP + N - I + 1
   20    CONTINUE
      END IF
!
!     Estimate the 1-norm of the inverse.
!
      KASE = 0
   30 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
!
!        Multiply by inv(L*D*L') or inv(U*D*U').
!
         CALL DSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
         GO TO 30
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
      RETURN
!
!     End of DSPCON
!
      END
      SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
!  real symmetric matrix A in packed storage.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, AP is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
!          and first superdiagonal of the tridiagonal matrix T overwrite
!          the corresponding elements of A, and if UPLO = 'L', the
!          diagonal and first subdiagonal of T overwrite the
!          corresponding elements of A.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            WANTZ
      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -7
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPEV ', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         W( 1 ) = AP( 1 )
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
      END IF
!
!     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
!
      INDE = 1
      INDTAU = INDE + N
      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, first call
!     DOPGTR to generate the orthogonal matrix, then call DSTEQR.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         INDWRK = INDTAU + N
         CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, &
                      WORK( INDWRK ), IINFO )
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
      RETURN
!
!     End of DSPEV
!
      END
      SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, &
                         IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPEVD computes all the eigenvalues and, optionally, eigenvectors
!  of a real symmetric matrix A in packed storage. If eigenvectors are
!  desired, it uses a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, AP is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
!          and first superdiagonal of the tridiagonal matrix T overwrite
!          the corresponding elements of A, and if UPLO = 'L', the
!          diagonal and first subdiagonal of T overwrite the
!          corresponding elements of A.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array,
!                                         dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If N <= 1,               LWORK must be at least 1.
!          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
!          If JOBZ = 'V' and N > 1, LWORK must be at least
!                                                 1 + 6*N + N**2.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.
!          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, WANTZ
      INTEGER            IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN, &
                         LLWORK, LWMIN
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LIWMIN = 1
         LWMIN = 1
      ELSE
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 6*N + N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N
         END IF
      END IF
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -9
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPEVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         W( 1 ) = AP( 1 )
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
      END IF
!
!     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
!
      INDE = 1
      INDTAU = INDE + N
      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, first call
!     DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
!     tridiagonal matrix, then call DOPMTR to multiply it by the
!     Householder transformations represented in AP.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         INDWRK = INDTAU + N
         LLWORK = LWORK - INDWRK + 1
         CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), &
                      LLWORK, IWORK, LIWORK, INFO )
         CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ, &
                      WORK( INDWRK ), IINFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) &
         CALL DSCAL( N, ONE / SIGMA, W, 1 )
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
!
!     End of DSPEVD
!
      END
      SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, &
                         ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, &
                         INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, LDZ, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPEVX computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors
!  can be selected by specifying either a range of values or a range of
!  indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found;
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found;
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, AP is overwritten by values generated during the
!          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
!          and first superdiagonal of the tridiagonal matrix T overwrite
!          the corresponding elements of A, and if UPLO = 'L', the
!          diagonal and first subdiagonal of T overwrite the
!          corresponding elements of A.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing AP to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the selected eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (8*N)
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, then i eigenvectors failed to converge.
!                Their indices are stored in array IFAIL.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, &
                         INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, &
                         J, JJ, NSPLIT
      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, &
                         SIGMA, SMLNUM, TMP1, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ, &
                         DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) &
                THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -7
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -8
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -9
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) &
            INFO = -14
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPEVX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = AP( 1 )
         ELSE
            IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
               M = 1
               W( 1 ) = AP( 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      ABSTLL = ABSTOL
      IF( VALEIG ) THEN
         VLL = VL
         VUU = VU
      ELSE
         VLL = ZERO
         VUU = ZERO
      END IF
      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
         IF( ABSTOL.GT.0 ) &
            ABSTLL = ABSTOL*SIGMA
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
!
      INDTAU = 1
      INDE = INDTAU + N
      INDD = INDE + N
      INDWRK = INDD + N
      CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ), &
                   WORK( INDTAU ), IINFO )
!
!     If all eigenvalues are desired and ABSTOL is less than or equal
!     to zero, then call DSTERF or DOPGTR and SSTEQR.  If this fails
!     for some eigenvalue, then try DSTEBZ.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
         INDEE = INDWRK + 2*N
         IF( .NOT.WANTZ ) THEN
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTERF( N, W, WORK( INDEE ), INFO )
         ELSE
            CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, &
                         WORK( INDWRK ), IINFO )
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, &
                         WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 10 I = 1, N
                  IFAIL( I ) = 0
   10          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 20
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, &
                   WORK( INDD ), WORK( INDE ), M, NSPLIT, W, &
                   IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, &
                      IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, &
                      WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, &
                      WORK( INDWRK ), INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   20 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 40 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 30 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   30       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DSPEVX
!
      END
      SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, ITYPE, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), BP( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPGST reduces a real symmetric-definite generalized eigenproblem
!  to standard form, using packed storage.
!
!  If ITYPE = 1, the problem is A*x = lambda*B*x,
!  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
!
!  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
!
!  B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
!          = 2 or 3: compute U*A*U**T or L**T*A*L.
!
!  UPLO    (input) CHARACTER
!          = 'U':  Upper triangle of A is stored and B is factored as
!                  U**T*U;
!          = 'L':  Lower triangle of A is stored and B is factored as
!                  L*L**T.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, if INFO = 0, the transformed matrix, stored in the
!          same format as A.
!
!  BP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The triangular factor from the Cholesky factorization of B,
!          stored in the same format as A, as returned by DPPTRF.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, HALF
      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
      DOUBLE PRECISION   AJJ, AKK, BJJ, BKK, CT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV, &
                         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPGST', -INFO )
         RETURN
      END IF
!
      IF( ITYPE.EQ.1 ) THEN
         IF( UPPER ) THEN
!
!           Compute inv(U')*A*inv(U)
!
!           J1 and JJ are the indices of A(1,j) and A(j,j)
!
            JJ = 0
            DO 10 J = 1, N
               J1 = JJ + 1
               JJ = JJ + J
!
!              Compute the j-th column of the upper triangle of A
!
               BJJ = BP( JJ )
               CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP, &
                           AP( J1 ), 1 )
               CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE, &
                           AP( J1 ), 1 )
               CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
               AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ), &
                          1 ) ) / BJJ
   10       CONTINUE
         ELSE
!
!           Compute inv(L)*A*inv(L')
!
!           KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
!
            KK = 1
            DO 20 K = 1, N
               K1K1 = KK + N - K + 1
!
!              Update the lower triangle of A(k:n,k:n)
!
               AKK = AP( KK )
               BKK = BP( KK )
               AKK = AKK / BKK**2
               AP( KK ) = AKK
               IF( K.LT.N ) THEN
                  CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
                  CT = -HALF*AKK
                  CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
                  CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1, &
                              BP( KK+1 ), 1, AP( K1K1 ) )
                  CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
                  CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K, &
                              BP( K1K1 ), AP( KK+1 ), 1 )
               END IF
               KK = K1K1
   20       CONTINUE
         END IF
      ELSE
         IF( UPPER ) THEN
!
!           Compute U*A*U'
!
!           K1 and KK are the indices of A(1,k) and A(k,k)
!
            KK = 0
            DO 30 K = 1, N
               K1 = KK + 1
               KK = KK + K
!
!              Update the upper triangle of A(1:k,1:k)
!
               AKK = AP( KK )
               BKK = BP( KK )
               CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP, &
                           AP( K1 ), 1 )
               CT = HALF*AKK
               CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
               CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1, &
                           AP )
               CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
               CALL DSCAL( K-1, BKK, AP( K1 ), 1 )
               AP( KK ) = AKK*BKK**2
   30       CONTINUE
         ELSE
!
!           Compute L'*A*L
!
!           JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
!
            JJ = 1
            DO 40 J = 1, N
               J1J1 = JJ + N - J + 1
!
!              Compute the j-th column of the lower triangle of A
!
               AJJ = AP( JJ )
               BJJ = BP( JJ )
               AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1, &
                          BP( JJ+1 ), 1 )
               CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
               CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1, &
                           ONE, AP( JJ+1 ), 1 )
               CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1, &
                           BP( JJ ), AP( JJ ), 1 )
               JJ = J1J1
   40       CONTINUE
         END IF
      END IF
      RETURN
!
!     End of DSPGST
!
      END
      SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, &
                        INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, ITYPE, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPGV computes all the eigenvalues and, optionally, the eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.
!  Here A and B are assumed to be symmetric, stored in packed format,
!  and B is also positive definite.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension
!                            (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, the contents of AP are destroyed.
!
!  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          B, packed columnwise in a linear array.  The j-th column of B
!          is stored in the array BP as follows:
!          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
!          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
!
!          On exit, the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T, in the same storage
!          format as B.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!          eigenvectors.  The eigenvectors are normalized as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPPTRF or DSPEV returned an error code:
!             <= N:  if INFO = i, DSPEV failed to converge;
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero.
!             > N:   if INFO = n + i, for 1 <= i <= n, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            UPPER, WANTZ
      CHARACTER          TRANS
      INTEGER            J, NEIG
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
!
      INFO = 0
      IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPGV ', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a Cholesky factorization of B.
!
      CALL DPPTRF( UPLO, N, BP, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
      CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         NEIG = N
         IF( INFO.GT.0 ) &
            NEIG = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            DO 10 J = 1, NEIG
               CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   10       CONTINUE
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            DO 20 J = 1, NEIG
               CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   20       CONTINUE
         END IF
      END IF
      RETURN
!
!     End of DSPGV
!
      END
      SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, &
                         LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, ITYPE, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
!  B are assumed to be symmetric, stored in packed format, and B is also
!  positive definite.
!  If eigenvectors are desired, it uses a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, the contents of AP are destroyed.
!
!  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          B, packed columnwise in a linear array.  The j-th column of B
!          is stored in the array BP as follows:
!          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
!          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
!
!          On exit, the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T, in the same storage
!          format as B.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!          eigenvectors.  The eigenvectors are normalized as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If N <= 1,               LWORK >= 1.
!          If JOBZ = 'N' and N > 1, LWORK >= 2*N.
!          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.
!          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPPTRF or DSPEVD returned an error code:
!             <= N:  if INFO = i, DSPEVD failed to converge;
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero;
!             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER, WANTZ
      CHARACTER          TRANS
      INTEGER            J, LGN, LIWMIN, LWMIN, NEIG
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, LOG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LGN = 0
         LIWMIN = 1
         LWMIN = 1
      ELSE
         LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 5*N + 2*N*LGN + 2*N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N
         END IF
      END IF
!
      IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -11
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPGVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a Cholesky factorization of BP.
!
      CALL DPPTRF( UPLO, N, BP, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
      CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, &
                   LIWORK, INFO )
      LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) )
      LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         NEIG = N
         IF( INFO.GT.0 ) &
            NEIG = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            DO 10 J = 1, NEIG
               CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   10       CONTINUE
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            DO 20 J = 1, NEIG
               CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   20       CONTINUE
         END IF
      END IF
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DSPGVD
!
      END
      SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, &
                         IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, &
                         IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPGVX computes selected eigenvalues, and optionally, eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
!  and B are assumed to be symmetric, stored in packed storage, and B
!  is also positive definite.  Eigenvalues and eigenvectors can be
!  selected by specifying either a range of values or a range of indices
!  for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A and B are stored;
!          = 'L':  Lower triangle of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrix pencil (A,B).  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, the contents of AP are destroyed.
!
!  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          B, packed columnwise in a linear array.  The j-th column of B
!          is stored in the array BP as follows:
!          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
!          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
!
!          On exit, the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T, in the same storage
!          format as B.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          On normal exit, the first M elements contain the selected
!          eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'N', then Z is not referenced.
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          The eigenvectors are normalized as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (8*N)
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPPTRF or DSPEVX returned an error code:
!             <= N:  if INFO = i, DSPEVX failed to converge;
!                    i eigenvectors failed to converge.  Their indices
!                    are stored in array IFAIL.
!             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
      CHARACTER          TRANS
      INTEGER            J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      UPPER = LSAME( UPLO, 'U' )
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      INFO = 0
      IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
         INFO = -9
      ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
         INFO = -10
      ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
         INFO = -11
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -16
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPGVX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Form a Cholesky factorization of B.
!
      CALL DPPTRF( UPLO, N, BP, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
      CALL DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, &
                   W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         IF( INFO.GT.0 ) &
            M = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            DO 10 J = 1, M
               CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   10       CONTINUE
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            DO 20 J = 1, M
               CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), &
                           1 )
   20       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSPGVX
!
      END
      SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, &
                         FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric indefinite
!  and packed, and provides error bounds and backward error estimates
!  for the solution.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangle of the symmetric matrix A, packed
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The factored form of the matrix A.  AFP contains the block
!          diagonal matrix D and the multipliers used to obtain the
!          factor U or L from the factorization A = U*D*U**T or
!          A = L*D*L**T as computed by DSPTRF, stored as a packed
!          triangular matrix.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSPTRF.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DSPTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DSPMV, DSPTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ), &
                     1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(A)*abs(X) + abs(B).
!
         KK = 1
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               IK = KK
               DO 40 I = 1, K - 1
                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
                  IK = IK + 1
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
               KK = KK + K
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
               IK = KK + 1
               DO 60 I = K + 1, N
                  WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
                  S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
                  IK = IK + 1
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
               KK = KK + ( N-K+1 )
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(A) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(A').
!
               CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, &
                            INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
!
!              Multiply by inv(A)*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, &
                            INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DSPRFS
!
      END
      SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AP( * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPSV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric matrix stored in packed format and X
!  and B are N-by-NRHS matrices.
!
!  The diagonal pivoting method is used to factor A as
!     A = U * D * U**T,  if UPLO = 'U', or
!     A = L * D * L**T,  if UPLO = 'L',
!  where U (or L) is a product of permutation and unit upper (lower)
!  triangular matrices, D is symmetric and block diagonal with 1-by-1
!  and 2-by-2 diagonal blocks.  The factored form of A is then used to
!  solve the system of equations A * X = B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.
!
!          On exit, the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L from the factorization
!          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
!          a packed triangular matrix in the same storage format as A.
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D, as
!          determined by DSPTRF.  If IPIV(k) > 0, then rows and columns
!          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
!          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
!          then rows and columns k-1 and -IPIV(k) were interchanged and
!          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
!          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
!          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
!          diagonal block.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization
!                has been completed, but the block diagonal matrix D is
!                exactly singular, so the solution could not be
!                computed.
!
!  Further Details
!  ===============
!
!  The packed storage scheme is illustrated by the following example
!  when N = 4, UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11 a12 a13 a14
!         a22 a23 a24
!             a33 a34     (aij = aji)
!                 a44
!
!  Packed storage of the upper triangle of A:
!
!  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!
!  =====================================================================
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSPTRF, DSPTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPSV ', -INFO )
         RETURN
      END IF
!
!     Compute the factorization A = U*D*U' or A = L*D*L'.
!
      CALL DSPTRF( UPLO, N, AP, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
!
      END IF
      RETURN
!
!     End of DSPSV
!
      END
      SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, &
                         LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          FACT, UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   AFP( * ), AP( * ), B( LDB, * ), BERR( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
!  A = L*D*L**T to compute the solution to a real system of linear
!  equations A * X = B, where A is an N-by-N symmetric matrix stored
!  in packed format and X and B are N-by-NRHS matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'N', the diagonal pivoting method is used to factor A as
!        A = U * D * U**T,  if UPLO = 'U', or
!        A = L * D * L**T,  if UPLO = 'L',
!     where U (or L) is a product of permutation and unit upper (lower)
!     triangular matrices and D is symmetric and block diagonal with
!     1-by-1 and 2-by-2 diagonal blocks.
!
!  2. If some D(i,i)=0, so that D is exactly singular, then the routine
!     returns with INFO = i. Otherwise, the factored form of A is used
!     to estimate the condition number of the matrix A.  If the
!     reciprocal of the condition number is less than machine precision,
!     INFO = N+1 is returned as a warning, but the routine still goes on
!     to solve for X and compute error bounds as described below.
!
!  3. The system of equations is solved for X using the factored form
!     of A.
!
!  4. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of A has been
!          supplied on entry.
!          = 'F':  On entry, AFP and IPIV contain the factored form of
!                  A.  AP, AFP and IPIV will not be modified.
!          = 'N':  The matrix A will be copied to AFP and factored.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangle of the symmetric matrix A, packed
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.
!
!  AFP     (input or output) DOUBLE PRECISION array, dimension
!                            (N*(N+1)/2)
!          If FACT = 'F', then AFP is an input argument and on entry
!          contains the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L from the factorization
!          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
!          a packed triangular matrix in the same storage format as A.
!
!          If FACT = 'N', then AFP is an output argument and on exit
!          contains the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L from the factorization
!          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
!          a packed triangular matrix in the same storage format as A.
!
!  IPIV    (input or output) INTEGER array, dimension (N)
!          If FACT = 'F', then IPIV is an input argument and on entry
!          contains details of the interchanges and the block structure
!          of D, as determined by DSPTRF.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!          If FACT = 'N', then IPIV is an output argument and on exit
!          contains details of the interchanges and the block structure
!          of D, as determined by DSPTRF.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The N-by-NRHS right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A.  If RCOND is less than the machine precision (in
!          particular, if RCOND = 0), the matrix is singular to working
!          precision.  This condition is indicated by a return code of
!          INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, and i is
!                <= N:  D(i,i) is exactly zero.  The factorization
!                       has been completed but the factor D is exactly
!                       singular, so the solution and error bounds could
!                       not be computed. RCOND = 0 is returned.
!                = N+1: D is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  Further Details
!  ===============
!
!  The packed storage scheme is illustrated by the following example
!  when N = 4, UPLO = 'U':
!
!  Two-dimensional storage of the symmetric matrix A:
!
!     a11 a12 a13 a14
!         a22 a23 a24
!             a33 a34     (aij = aji)
!                 a44
!
!  Packed storage of the upper triangle of A:
!
!  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOFACT
      DOUBLE PRECISION   ANORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPSVX', -INFO )
         RETURN
      END IF
!
      IF( NOFACT ) THEN
!
!        Compute the factorization A = U*D*U' or A = L*D*L'.
!
         CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
         CALL DSPTRF( UPLO, N, AFP, IPIV, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution vectors X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solutions and
!     compute error bounds and backward error estimates for them.
!
      CALL DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, &
                   BERR, WORK, IWORK, INFO )
!
      RETURN
!
!     End of DSPSVX
!
      END
      SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), D( * ), E( * ), TAU( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPTRD reduces a real symmetric matrix A stored in packed form to
!  symmetric tridiagonal form T by an orthogonal similarity
!  transformation: Q**T * A * Q = T.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!          of A are overwritten by the corresponding elements of the
!          tridiagonal matrix T, and the elements above the first
!          superdiagonal, with the array TAU, represent the orthogonal
!          matrix Q as a product of elementary reflectors; if UPLO
!          = 'L', the diagonal and first subdiagonal of A are over-
!          written by the corresponding elements of the tridiagonal
!          matrix T, and the elements below the first subdiagonal, with
!          the array TAU, represent the orthogonal matrix Q as a product
!          of elementary reflectors. See Further Details.
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T:
!          D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          The off-diagonal elements of the tridiagonal matrix T:
!          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  If UPLO = 'U', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(n-1) . . . H(2) H(1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
!  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
!
!  If UPLO = 'L', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(1) H(2) . . . H(n-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
!  overwriting A(i+2:n,i), and tau is stored in TAU(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, HALF
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, &
                         HALF = 1.0D0 / 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, I1, I1I1, II
      DOUBLE PRECISION   ALPHA, TAUI
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPTRD', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Reduce the upper triangle of A.
!        I1 is the index in AP of A(1,I+1).
!
         I1 = N*( N-1 ) / 2 + 1
         DO 10 I = N - 1, 1, -1
!
!           Generate elementary reflector H(i) = I - tau * v * v'
!           to annihilate A(1:i-1,i+1)
!
            CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
            E( I ) = AP( I1+I-1 )
!
            IF( TAUI.NE.ZERO ) THEN
!
!              Apply H(i) from both sides to A(1:i,1:i)
!
               AP( I1+I-1 ) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(1:i)
!
               CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, &
                           1 )
!
!              Compute  w := y - 1/2 * tau * (y'*v) * v
!
               ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
               CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w' - w * v'
!
               CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
!
               AP( I1+I-1 ) = E( I )
            END IF
            D( I+1 ) = AP( I1+I )
            TAU( I ) = TAUI
            I1 = I1 - I
   10    CONTINUE
         D( 1 ) = AP( 1 )
      ELSE
!
!        Reduce the lower triangle of A. II is the index in AP of
!        A(i,i) and I1I1 is the index of A(i+1,i+1).
!
         II = 1
         DO 20 I = 1, N - 1
            I1I1 = II + N - I + 1
!
!           Generate elementary reflector H(i) = I - tau * v * v'
!           to annihilate A(i+2:n,i)
!
            CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
            E( I ) = AP( II+1 )
!
            IF( TAUI.NE.ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               AP( II+1 ) = ONE
!
!              Compute  y := tau * A * v  storing y in TAU(i:n-1)
!
               CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, &
                           ZERO, TAU( I ), 1 )
!
!              Compute  w := y - 1/2 * tau * (y'*v) * v
!
               ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), &
                       1 )
               CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w' - w * v'
!
               CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, &
                           AP( I1I1 ) )
!
               AP( II+1 ) = E( I )
            END IF
            D( I ) = AP( II )
            TAU( I ) = TAUI
            II = I1I1
   20    CONTINUE
         D( N ) = AP( II )
      END IF
!
      RETURN
!
!     End of DSPTRD
!
      END
      SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AP( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPTRF computes the factorization of a real symmetric matrix A stored
!  in packed format using the Bunch-Kaufman diagonal pivoting method:
!
!     A = U*D*U**T  or  A = L*D*L**T
!
!  where U (or L) is a product of permutation and unit upper (lower)
!  triangular matrices, and D is symmetric and block diagonal with
!  1-by-1 and 2-by-2 diagonal blocks.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangle of the symmetric matrix
!          A, packed columnwise in a linear array.  The j-th column of A
!          is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!
!          On exit, the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L, stored as a packed triangular
!          matrix overwriting A (see below for further details).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
!               has been completed, but the block diagonal matrix D is
!               exactly singular, and division by zero will occur if it
!               is used to solve a system of equations.
!
!  Further Details
!  ===============
!
!  5-96 - Based on modifications by J. Lewis, Boeing Computer Services
!         Company
!
!  If UPLO = 'U', then A = U*D*U', where
!     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    v    0   )   k-s
!     U(k) =  (   0    I    0   )   s
!             (   0    0    I   )   n-k
!                k-s   s   n-k
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!
!  If UPLO = 'L', then A = L*D*L', where
!     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    0     0   )  k-1
!     L(k) =  (   0    I     0   )  s
!             (   0    v     I   )  n-k-s+1
!                k-1   s  n-k-s+1
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   EIGHT, SEVTEN
      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, &
                         KSTEP, KX, NPP
      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, &
                         ROWMAX, T, WK, WKM1, WKP1
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      EXTERNAL           LSAME, IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPTRF', -INFO )
         RETURN
      END IF
!
!     Initialize ALPHA for use in choosing pivot block size.
!
      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
!
      IF( UPPER ) THEN
!
!        Factorize A as U*D*U' using the upper triangle of A
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2
!
         K = N
         KC = ( N-1 )*N / 2 + 1
   10    CONTINUE
         KNC = KC
!
!        If K < 1, exit from loop
!
         IF( K.LT.1 ) &
            GO TO 110
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( AP( KC+K-1 ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.GT.1 ) THEN
            IMAX = IDAMAX( K-1, AP( KC ), 1 )
            COLMAX = ABS( AP( KC+IMAX-1 ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               ROWMAX = ZERO
               JMAX = IMAX
               KX = IMAX*( IMAX+1 ) / 2 + IMAX
               DO 20 J = IMAX + 1, K
                  IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
                     ROWMAX = ABS( AP( KX ) )
                     JMAX = J
                  END IF
                  KX = KX + J
   20          CONTINUE
               KPC = ( IMAX-1 )*IMAX / 2 + 1
               IF( IMAX.GT.1 ) THEN
                  JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
               ELSE
!
!                 interchange rows and columns K-1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K - KSTEP + 1
            IF( KSTEP.EQ.2 ) &
               KNC = KNC - K + 1
            IF( KP.NE.KK ) THEN
!
!              Interchange rows and columns KK and KP in the leading
!              submatrix A(1:k,1:k)
!
               CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
               KX = KPC + KP - 1
               DO 30 J = KP + 1, KK - 1
                  KX = KX + J - 1
                  T = AP( KNC+J-1 )
                  AP( KNC+J-1 ) = AP( KX )
                  AP( KX ) = T
   30          CONTINUE
               T = AP( KNC+KK-1 )
               AP( KNC+KK-1 ) = AP( KPC+KP-1 )
               AP( KPC+KP-1 ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = AP( KC+K-2 )
                  AP( KC+K-2 ) = AP( KC+KP-1 )
                  AP( KC+KP-1 ) = T
               END IF
            END IF
!
!           Update the leading submatrix
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column k now holds
!
!              W(k) = U(k)*D(k)
!
!              where U(k) is the k-th column of U
!
!              Perform a rank-1 update of A(1:k-1,1:k-1) as
!
!              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
!
               R1 = ONE / AP( KC+K-1 )
               CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
!
!              Store U(k) in column k
!
               CALL DSCAL( K-1, R1, AP( KC ), 1 )
            ELSE
!
!              2-by-2 pivot block D(k): columns k and k-1 now hold
!
!              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
!
!              where U(k) and U(k-1) are the k-th and (k-1)-th columns
!              of U
!
!              Perform a rank-2 update of A(1:k-2,1:k-2) as
!
!              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
!                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
!
               IF( K.GT.2 ) THEN
!
                  D12 = AP( K-1+( K-1 )*K / 2 )
                  D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
                  D11 = AP( K+( K-1 )*K / 2 ) / D12
                  T = ONE / ( D11*D22-ONE )
                  D12 = T / D12
!
                  DO 50 J = K - 2, 1, -1
                     WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- &
                            AP( J+( K-1 )*K / 2 ) )
                     WK = D12*( D22*AP( J+( K-1 )*K / 2 )- &
                          AP( J+( K-2 )*( K-1 ) / 2 ) )
                     DO 40 I = J, 1, -1
                        AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - &
                           AP( I+( K-1 )*K / 2 )*WK - &
                           AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
   40                CONTINUE
                     AP( J+( K-1 )*K / 2 ) = WK
                     AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
   50             CONTINUE
!
               END IF
!
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K-1 ) = -KP
         END IF
!
!        Decrease K and return to the start of the main loop
!
         K = K - KSTEP
         KC = KNC - K
         GO TO 10
!
      ELSE
!
!        Factorize A as L*D*L' using the lower triangle of A
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2
!
         K = 1
         KC = 1
         NPP = N*( N+1 ) / 2
   60    CONTINUE
         KNC = KC
!
!        If K > N, exit from loop
!
         IF( K.GT.N ) &
            GO TO 110
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( AP( KC ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.LT.N ) THEN
            IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 )
            COLMAX = ABS( AP( KC+IMAX-K ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               ROWMAX = ZERO
               KX = KC + IMAX - K
               DO 70 J = K, IMAX - 1
                  IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
                     ROWMAX = ABS( AP( KX ) )
                     JMAX = J
                  END IF
                  KX = KX + N - J
   70          CONTINUE
               KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
               IF( IMAX.LT.N ) THEN
                  JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
               ELSE
!
!                 interchange rows and columns K+1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K + KSTEP - 1
            IF( KSTEP.EQ.2 ) &
               KNC = KNC + N - K + 1
            IF( KP.NE.KK ) THEN
!
!              Interchange rows and columns KK and KP in the trailing
!              submatrix A(k:n,k:n)
!
               IF( KP.LT.N ) &
                  CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), &
                              1 )
               KX = KNC + KP - KK
               DO 80 J = KK + 1, KP - 1
                  KX = KX + N - J + 1
                  T = AP( KNC+J-KK )
                  AP( KNC+J-KK ) = AP( KX )
                  AP( KX ) = T
   80          CONTINUE
               T = AP( KNC )
               AP( KNC ) = AP( KPC )
               AP( KPC ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = AP( KC+1 )
                  AP( KC+1 ) = AP( KC+KP-K )
                  AP( KC+KP-K ) = T
               END IF
            END IF
!
!           Update the trailing submatrix
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column k now holds
!
!              W(k) = L(k)*D(k)
!
!              where L(k) is the k-th column of L
!
               IF( K.LT.N ) THEN
!
!                 Perform a rank-1 update of A(k+1:n,k+1:n) as
!
!                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
!
                  R1 = ONE / AP( KC )
                  CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, &
                             AP( KC+N-K+1 ) )
!
!                 Store L(k) in column K
!
                  CALL DSCAL( N-K, R1, AP( KC+1 ), 1 )
               END IF
            ELSE
!
!              2-by-2 pivot block D(k): columns K and K+1 now hold
!
!              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
!
!              where L(k) and L(k+1) are the k-th and (k+1)-th columns
!              of L
!
               IF( K.LT.N-1 ) THEN
!
!                 Perform a rank-2 update of A(k+2:n,k+2:n) as
!
!                 A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
!                    = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
!
                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
                  D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
                  D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
                  T = ONE / ( D11*D22-ONE )
                  D21 = T / D21
!
                  DO 100 J = K + 2, N
                     WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- &
                          AP( J+K*( 2*N-K-1 ) / 2 ) )
                     WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- &
                            AP( J+( K-1 )*( 2*N-K ) / 2 ) )
!
                     DO 90 I = J, N
                        AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* &
                           ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / &
                           2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
   90                CONTINUE
!
                     AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
                     AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
!
  100             CONTINUE
               END IF
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K+1 ) = -KP
         END IF
!
!        Increase K and return to the start of the main loop
!
         K = K + KSTEP
         KC = KNC + N - K + 2
         GO TO 60
!
      END IF
!
  110 CONTINUE
      RETURN
!
!     End of DSPTRF
!
      END
      SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPTRI computes the inverse of a real symmetric indefinite matrix
!  A in packed storage using the factorization A = U*D*U**T or
!  A = L*D*L**T computed by DSPTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the block diagonal matrix D and the multipliers
!          used to obtain the factor U or L as computed by DSPTRF,
!          stored as a packed triangular matrix.
!
!          On exit, if INFO = 0, the (symmetric) inverse of the original
!          matrix, stored as a packed triangular matrix. The j-th column
!          of inv(A) is stored in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
!          if UPLO = 'L',
!             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSPTRF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!               inverse could not be computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
      DOUBLE PRECISION   AK, AKKP1, AKP1, D, T, TEMP
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DSPMV, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPTRI', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check that the diagonal matrix D is nonsingular.
!
      IF( UPPER ) THEN
!
!        Upper triangular storage: examine D from bottom to top
!
         KP = N*( N+1 ) / 2
         DO 10 INFO = N, 1, -1
            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) &
               RETURN
            KP = KP - INFO
   10    CONTINUE
      ELSE
!
!        Lower triangular storage: examine D from top to bottom.
!
         KP = 1
         DO 20 INFO = 1, N
            IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) &
               RETURN
            KP = KP + N - INFO + 1
   20    CONTINUE
      END IF
      INFO = 0
!
      IF( UPPER ) THEN
!
!        Compute inv(A) from the factorization A = U*D*U'.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
         KC = 1
   30    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 50
!
         KCNEXT = KC + K
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Invert the diagonal block.
!
            AP( KC+K-1 ) = ONE / AP( KC+K-1 )
!
!           Compute column K of the inverse.
!
            IF( K.GT.1 ) THEN
               CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), &
                           1 )
               AP( KC+K-1 ) = AP( KC+K-1 ) - &
                              DDOT( K-1, WORK, 1, AP( KC ), 1 )
            END IF
            KSTEP = 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Invert the diagonal block.
!
            T = ABS( AP( KCNEXT+K-1 ) )
            AK = AP( KC+K-1 ) / T
            AKP1 = AP( KCNEXT+K ) / T
            AKKP1 = AP( KCNEXT+K-1 ) / T
            D = T*( AK*AKP1-ONE )
            AP( KC+K-1 ) = AKP1 / D
            AP( KCNEXT+K ) = AK / D
            AP( KCNEXT+K-1 ) = -AKKP1 / D
!
!           Compute columns K and K+1 of the inverse.
!
            IF( K.GT.1 ) THEN
               CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), &
                           1 )
               AP( KC+K-1 ) = AP( KC+K-1 ) - &
                              DDOT( K-1, WORK, 1, AP( KC ), 1 )
               AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) - &
                                  DDOT( K-1, AP( KC ), 1, AP( KCNEXT ), &
                                  1 )
               CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
               CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, &
                           AP( KCNEXT ), 1 )
               AP( KCNEXT+K ) = AP( KCNEXT+K ) - &
                                DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
            END IF
            KSTEP = 2
            KCNEXT = KCNEXT + K + 1
         END IF
!
         KP = ABS( IPIV( K ) )
         IF( KP.NE.K ) THEN
!
!           Interchange rows and columns K and KP in the leading
!           submatrix A(1:k+1,1:k+1)
!
            KPC = ( KP-1 )*KP / 2 + 1
            CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
            KX = KPC + KP - 1
            DO 40 J = KP + 1, K - 1
               KX = KX + J - 1
               TEMP = AP( KC+J-1 )
               AP( KC+J-1 ) = AP( KX )
               AP( KX ) = TEMP
   40       CONTINUE
            TEMP = AP( KC+K-1 )
            AP( KC+K-1 ) = AP( KPC+KP-1 )
            AP( KPC+KP-1 ) = TEMP
            IF( KSTEP.EQ.2 ) THEN
               TEMP = AP( KC+K+K-1 )
               AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
               AP( KC+K+KP-1 ) = TEMP
            END IF
         END IF
!
         K = K + KSTEP
         KC = KCNEXT
         GO TO 30
   50    CONTINUE
!
      ELSE
!
!        Compute inv(A) from the factorization A = L*D*L'.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         NPP = N*( N+1 ) / 2
         K = N
         KC = NPP
   60    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 80
!
         KCNEXT = KC - ( N-K+2 )
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Invert the diagonal block.
!
            AP( KC ) = ONE / AP( KC )
!
!           Compute column K of the inverse.
!
            IF( K.LT.N ) THEN
               CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1, &
                           ZERO, AP( KC+1 ), 1 )
               AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
            END IF
            KSTEP = 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Invert the diagonal block.
!
            T = ABS( AP( KCNEXT+1 ) )
            AK = AP( KCNEXT ) / T
            AKP1 = AP( KC ) / T
            AKKP1 = AP( KCNEXT+1 ) / T
            D = T*( AK*AKP1-ONE )
            AP( KCNEXT ) = AKP1 / D
            AP( KC ) = AK / D
            AP( KCNEXT+1 ) = -AKKP1 / D
!
!           Compute columns K-1 and K of the inverse.
!
            IF( K.LT.N ) THEN
               CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, &
                           ZERO, AP( KC+1 ), 1 )
               AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
               AP( KCNEXT+1 ) = AP( KCNEXT+1 ) - &
                                DDOT( N-K, AP( KC+1 ), 1, &
                                AP( KCNEXT+2 ), 1 )
               CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
               CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, &
                           ZERO, AP( KCNEXT+2 ), 1 )
               AP( KCNEXT ) = AP( KCNEXT ) - &
                              DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
            END IF
            KSTEP = 2
            KCNEXT = KCNEXT - ( N-K+3 )
         END IF
!
         KP = ABS( IPIV( K ) )
         IF( KP.NE.K ) THEN
!
!           Interchange rows and columns K and KP in the trailing
!           submatrix A(k-1:n,k-1:n)
!
            KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
            IF( KP.LT.N ) &
               CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
            KX = KC + KP - K
            DO 70 J = K + 1, KP - 1
               KX = KX + N - J + 1
               TEMP = AP( KC+J-K )
               AP( KC+J-K ) = AP( KX )
               AP( KX ) = TEMP
   70       CONTINUE
            TEMP = AP( KC )
            AP( KC ) = AP( KPC )
            AP( KPC ) = TEMP
            IF( KSTEP.EQ.2 ) THEN
               TEMP = AP( KC-N+K-1 )
               AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
               AP( KC-N+KP-1 ) = TEMP
            END IF
         END IF
!
         K = K - KSTEP
         KC = KCNEXT
         GO TO 60
   80    CONTINUE
      END IF
!
      RETURN
!
!     End of DSPTRI
!
      END
      SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   AP( * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DSPTRS solves a system of linear equations A*X = B with a real
!  symmetric matrix A stored in packed format using the factorization
!  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The block diagonal matrix D and the multipliers used to
!          obtain the factor U or L as computed by DSPTRF, stored as a
!          packed triangular matrix.
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSPTRF.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, K, KC, KP
      DOUBLE PRECISION   AK, AKM1, AKM1K, BK, BKM1, DENOM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Solve A*X = B, where A = U*D*U'.
!
!        First solve U*D*X = B, overwriting B with X.
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = N
         KC = N*( N+1 ) / 2 + 1
   10    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 30
!
         KC = KC - K
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(U(K)), where U(K) is the transformation
!           stored in column K of A.
!
            CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, &
                       B( 1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
            K = K - 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Interchange rows K-1 and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K-1 ) &
               CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(U(K)), where U(K) is the transformation
!           stored in columns K-1 and K of A.
!
            CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, &
                       B( 1, 1 ), LDB )
            CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, &
                       B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            AKM1K = AP( KC+K-2 )
            AKM1 = AP( KC-1 ) / AKM1K
            AK = AP( KC+K-1 ) / AKM1K
            DENOM = AKM1*AK - ONE
            DO 20 J = 1, NRHS
               BKM1 = B( K-1, J ) / AKM1K
               BK = B( K, J ) / AKM1K
               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
   20       CONTINUE
            KC = KC - K + 1
            K = K - 2
         END IF
!
         GO TO 10
   30    CONTINUE
!
!        Next solve U'*X = B, overwriting B with X.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
         KC = 1
   40    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 50
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Multiply by inv(U'(K)), where U(K) is the transformation
!           stored in column K of A.
!
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), &
                        1, ONE, B( K, 1 ), LDB )
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC + K
            K = K + 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
!           stored in columns K and K+1 of A.
!
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), &
                        1, ONE, B( K, 1 ), LDB )
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, &
                        AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
!
!           Interchange rows K and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC + 2*K + 1
            K = K + 2
         END IF
!
         GO TO 40
   50    CONTINUE
!
      ELSE
!
!        Solve A*X = B, where A = L*D*L'.
!
!        First solve L*D*X = B, overwriting B with X.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
         KC = 1
   60    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 80
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(L(K)), where L(K) is the transformation
!           stored in column K of A.
!
            IF( K.LT.N ) &
               CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ), &
                          LDB, B( K+1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
            KC = KC + N - K + 1
            K = K + 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Interchange rows K+1 and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K+1 ) &
               CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(L(K)), where L(K) is the transformation
!           stored in columns K and K+1 of A.
!
            IF( K.LT.N-1 ) THEN
               CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ), &
                          LDB, B( K+2, 1 ), LDB )
               CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, &
                          B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
            END IF
!
!           Multiply by the inverse of the diagonal block.
!
            AKM1K = AP( KC+1 )
            AKM1 = AP( KC ) / AKM1K
            AK = AP( KC+N-K+1 ) / AKM1K
            DENOM = AKM1*AK - ONE
            DO 70 J = 1, NRHS
               BKM1 = B( K, J ) / AKM1K
               BK = B( K+1, J ) / AKM1K
               B( K, J ) = ( AK*BKM1-BK ) / DENOM
               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
   70       CONTINUE
            KC = KC + 2*( N-K ) + 1
            K = K + 2
         END IF
!
         GO TO 60
   80    CONTINUE
!
!        Next solve L'*X = B, overwriting B with X.
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = N
         KC = N*( N+1 ) / 2 + 1
   90    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 100
!
         KC = KC - ( N-K+1 )
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Multiply by inv(L'(K)), where L(K) is the transformation
!           stored in column K of A.
!
            IF( K.LT.N ) &
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K - 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Multiply by inv(L'(K-1)), where L(K-1) is the transformation
!           stored in columns K-1 and K of A.
!
            IF( K.LT.N ) THEN
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ), &
                           LDB )
            END IF
!
!           Interchange rows K and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC - ( N-K+2 )
            K = K - 2
         END IF
!
         GO TO 90
  100    CONTINUE
      END IF
!
      RETURN
!
!     End of DSPTRS
!
      END
      SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, &
                         M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          ORDER, RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEBZ computes the eigenvalues of a symmetric tridiagonal
!  matrix T.  The user may ask for all eigenvalues, all eigenvalues
!  in the half-open interval (VL, VU], or the IL-th through IU-th
!  eigenvalues.
!
!  To avoid overflow, the matrix must be scaled so that its
!  largest element is no greater than overflow**(1/2) *
!  underflow**(1/4) in absolute value, and for greatest
!  accuracy, it should not be much smaller than that.
!
!  See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!  Matrix", Report CS41, Computer Science Dept., Stanford
!  University, July 21, 1966.
!
!  Arguments
!  =========
!
!  RANGE   (input) CHARACTER
!          = 'A': ("All")   all eigenvalues will be found.
!          = 'V': ("Value") all eigenvalues in the half-open interval
!                           (VL, VU] will be found.
!          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
!                           entire matrix) will be found.
!
!  ORDER   (input) CHARACTER
!          = 'B': ("By Block") the eigenvalues will be grouped by
!                              split-off block (see IBLOCK, ISPLIT) and
!                              ordered from smallest to largest within
!                              the block.
!          = 'E': ("Entire matrix")
!                              the eigenvalues for the entire matrix
!                              will be ordered from smallest to
!                              largest.
!
!  N       (input) INTEGER
!          The order of the tridiagonal matrix T.  N >= 0.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues.  Eigenvalues less than or equal
!          to VL, or greater than VU, will not be returned.  VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute tolerance for the eigenvalues.  An eigenvalue
!          (or cluster) is considered to be located if it has been
!          determined to lie in an interval whose width is ABSTOL or
!          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
!          will be used, where |T| means the 1-norm of T.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the tridiagonal matrix T.
!
!  E       (input) DOUBLE PRECISION array, dimension (N-1)
!          The (n-1) off-diagonal elements of the tridiagonal matrix T.
!
!  M       (output) INTEGER
!          The actual number of eigenvalues found. 0 <= M <= N.
!          (See also the description of INFO=2,3.)
!
!  NSPLIT  (output) INTEGER
!          The number of diagonal blocks in the matrix T.
!          1 <= NSPLIT <= N.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          On exit, the first M elements of W will contain the
!          eigenvalues.  (DSTEBZ may use the remaining N-M elements as
!          workspace.)
!
!  IBLOCK  (output) INTEGER array, dimension (N)
!          At each row/column j where E(j) is zero or small, the
!          matrix T is considered to split into a block diagonal
!          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which
!          block (from 1 to the number of blocks) the eigenvalue W(i)
!          belongs.  (DSTEBZ may use the remaining N-M elements as
!          workspace.)
!
!  ISPLIT  (output) INTEGER array, dimension (N)
!          The splitting points, at which T breaks up into submatrices.
!          The first submatrix consists of rows/columns 1 to ISPLIT(1),
!          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
!          etc., and the NSPLIT-th consists of rows/columns
!          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
!          (Only the first NSPLIT elements will actually be used, but
!          since the user cannot know a priori what value NSPLIT will
!          have, N words must be reserved for ISPLIT.)
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
!
!  IWORK   (workspace) INTEGER array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  some or all of the eigenvalues failed to converge or
!                were not computed:
!                =1 or 3: Bisection failed to converge for some
!                        eigenvalues; these eigenvalues are flagged by a
!                        negative block number.  The effect is that the
!                        eigenvalues may not be as accurate as the
!                        absolute and relative tolerances.  This is
!                        generally caused by unexpectedly inaccurate
!                        arithmetic.
!                =2 or 3: RANGE='I' only: Not all of the eigenvalues
!                        IL:IU were found.
!                        Effect: M < IU+1-IL
!                        Cause:  non-monotonic arithmetic, causing the
!                                Sturm sequence to be non-monotonic.
!                        Cure:   recalculate, using RANGE='A', and pick
!                                out eigenvalues IL:IU.  In some cases,
!                                increasing the PARAMETER "FUDGE" may
!                                make things work.
!                = 4:    RANGE='I', and the Gershgorin interval
!                        initially used was too small.  No eigenvalues
!                        were computed.
!                        Probable cause: your machine has sloppy
!                                        floating-point arithmetic.
!                        Cure: Increase the PARAMETER "FUDGE",
!                              recompile, and try again.
!
!  Internal Parameters
!  ===================
!
!  RELFAC  DOUBLE PRECISION, default = 2.0e0
!          The relative tolerance.  An interval (a,b] lies within
!          "relative tolerance" if  b-a < RELFAC*ulp*max(|a|,|b|),
!          where "ulp" is the machine precision (distance from 1 to
!          the next larger floating point number.)
!
!  FUDGE   DOUBLE PRECISION, default = 2
!          A "fudge factor" to widen the Gershgorin intervals.  Ideally,
!          a value of 1 should work, but on machines with sloppy
!          arithmetic, this needs to be larger.  The default for
!          publicly released versions should be large enough to handle
!          the worst machine around.  Note that this has no effect
!          on accuracy of the solution.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         HALF = 1.0D0 / TWO )
      DOUBLE PRECISION   FUDGE, RELFAC
      PARAMETER          ( FUDGE = 2.0D0, RELFAC = 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NCNVRG, TOOFEW
      INTEGER            IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, &
                         IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, &
                         ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, &
                         NWU
      DOUBLE PRECISION   ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, &
                         TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
!     ..
!     .. Local Arrays ..
      INTEGER            IDUMMA( 1 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, ILAENV, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAEBZ, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, LOG, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
!
!     Decode RANGE
!
      IF( LSAME( RANGE, 'A' ) ) THEN
         IRANGE = 1
      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
         IRANGE = 2
      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
         IRANGE = 3
      ELSE
         IRANGE = 0
      END IF
!
!     Decode ORDER
!
      IF( LSAME( ORDER, 'B' ) ) THEN
         IORDER = 2
      ELSE IF( LSAME( ORDER, 'E' ) ) THEN
         IORDER = 1
      ELSE
         IORDER = 0
      END IF
!
!     Check for Errors
!
      IF( IRANGE.LE.0 ) THEN
         INFO = -1
      ELSE IF( IORDER.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( IRANGE.EQ.2 ) THEN
         IF( VL.GE.VU ) &
            INFO = -5
      ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) &
                THEN
         INFO = -6
      ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) &
                THEN
         INFO = -7
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEBZ', -INFO )
         RETURN
      END IF
!
!     Initialize error flags
!
      INFO = 0
      NCNVRG = .FALSE.
      TOOFEW = .FALSE.
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
!     Simplifications:
!
      IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) &
         IRANGE = 1
!
!     Get machine constants
!     NB is the minimum vector length for vector bisection, or 0
!     if only scalar is to be done.
!
      SAFEMN = DLAMCH( 'S' )
      ULP = DLAMCH( 'P' )
      RTOLI = ULP*RELFAC
      NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
      IF( NB.LE.1 ) &
         NB = 0
!
!     Special Case when N=1
!
      IF( N.EQ.1 ) THEN
         NSPLIT = 1
         ISPLIT( 1 ) = 1
         IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
            M = 0
         ELSE
            W( 1 ) = D( 1 )
            IBLOCK( 1 ) = 1
            M = 1
         END IF
         RETURN
      END IF
!
!     Compute Splitting Points
!
      NSPLIT = 1
      WORK( N ) = ZERO
      PIVMIN = ONE
!
!DIR$ NOVECTOR
      DO 10 J = 2, N
         TMP1 = E( J-1 )**2
         IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
            ISPLIT( NSPLIT ) = J - 1
            NSPLIT = NSPLIT + 1
            WORK( J-1 ) = ZERO
         ELSE
            WORK( J-1 ) = TMP1
            PIVMIN = MAX( PIVMIN, TMP1 )
         END IF
   10 CONTINUE
      ISPLIT( NSPLIT ) = N
      PIVMIN = PIVMIN*SAFEMN
!
!     Compute Interval and ATOLI
!
      IF( IRANGE.EQ.3 ) THEN
!
!        RANGE='I': Compute the interval containing eigenvalues
!                   IL through IU.
!
!        Compute Gershgorin interval for entire (split) matrix
!        and use it as the initial interval
!
         GU = D( 1 )
         GL = D( 1 )
         TMP1 = ZERO
!
         DO 20 J = 1, N - 1
            TMP2 = SQRT( WORK( J ) )
            GU = MAX( GU, D( J )+TMP1+TMP2 )
            GL = MIN( GL, D( J )-TMP1-TMP2 )
            TMP1 = TMP2
   20    CONTINUE
!
         GU = MAX( GU, D( N )+TMP1 )
         GL = MIN( GL, D( N )-TMP1 )
         TNORM = MAX( ABS( GL ), ABS( GU ) )
         GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
         GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
!
!        Compute Iteration parameters
!
         ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / &
                 LOG( TWO ) ) + 2
         IF( ABSTOL.LE.ZERO ) THEN
            ATOLI = ULP*TNORM
         ELSE
            ATOLI = ABSTOL
         END IF
!
         WORK( N+1 ) = GL
         WORK( N+2 ) = GL
         WORK( N+3 ) = GU
         WORK( N+4 ) = GU
         WORK( N+5 ) = GL
         WORK( N+6 ) = GU
         IWORK( 1 ) = -1
         IWORK( 2 ) = -1
         IWORK( 3 ) = N + 1
         IWORK( 4 ) = N + 1
         IWORK( 5 ) = IL - 1
         IWORK( 6 ) = IU
!
         CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, &
                      WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, &
                      IWORK, W, IBLOCK, IINFO )
!
         IF( IWORK( 6 ).EQ.IU ) THEN
            WL = WORK( N+1 )
            WLU = WORK( N+3 )
            NWL = IWORK( 1 )
            WU = WORK( N+4 )
            WUL = WORK( N+2 )
            NWU = IWORK( 4 )
         ELSE
            WL = WORK( N+2 )
            WLU = WORK( N+4 )
            NWL = IWORK( 2 )
            WU = WORK( N+3 )
            WUL = WORK( N+1 )
            NWU = IWORK( 3 )
         END IF
!
         IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
            INFO = 4
            RETURN
         END IF
      ELSE
!
!        RANGE='A' or 'V' -- Set ATOLI
!
         TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), &
                 ABS( D( N ) )+ABS( E( N-1 ) ) )
!
         DO 30 J = 2, N - 1
            TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ &
                    ABS( E( J ) ) )
   30    CONTINUE
!
         IF( ABSTOL.LE.ZERO ) THEN
            ATOLI = ULP*TNORM
         ELSE
            ATOLI = ABSTOL
         END IF
!
         IF( IRANGE.EQ.2 ) THEN
            WL = VL
            WU = VU
         ELSE
            WL = ZERO
            WU = ZERO
         END IF
      END IF
!
!     Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
!     NWL accumulates the number of eigenvalues .le. WL,
!     NWU accumulates the number of eigenvalues .le. WU
!
      M = 0
      IEND = 0
      INFO = 0
      NWL = 0
      NWU = 0
!
      DO 70 JB = 1, NSPLIT
         IOFF = IEND
         IBEGIN = IOFF + 1
         IEND = ISPLIT( JB )
         IN = IEND - IOFF
!
         IF( IN.EQ.1 ) THEN
!
!           Special Case -- IN=1
!
            IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) &
               NWL = NWL + 1
            IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) &
               NWU = NWU + 1
            IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. &
                D( IBEGIN )-PIVMIN ) ) THEN
               M = M + 1
               W( M ) = D( IBEGIN )
               IBLOCK( M ) = JB
            END IF
         ELSE
!
!           General Case -- IN > 1
!
!           Compute Gershgorin Interval
!           and use it as the initial interval
!
            GU = D( IBEGIN )
            GL = D( IBEGIN )
            TMP1 = ZERO
!
            DO 40 J = IBEGIN, IEND - 1
               TMP2 = ABS( E( J ) )
               GU = MAX( GU, D( J )+TMP1+TMP2 )
               GL = MIN( GL, D( J )-TMP1-TMP2 )
               TMP1 = TMP2
   40       CONTINUE
!
            GU = MAX( GU, D( IEND )+TMP1 )
            GL = MIN( GL, D( IEND )-TMP1 )
            BNORM = MAX( ABS( GL ), ABS( GU ) )
            GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
            GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
!
!           Compute ATOLI for the current submatrix
!
            IF( ABSTOL.LE.ZERO ) THEN
               ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
            ELSE
               ATOLI = ABSTOL
            END IF
!
            IF( IRANGE.GT.1 ) THEN
               IF( GU.LT.WL ) THEN
                  NWL = NWL + IN
                  NWU = NWU + IN
                  GO TO 70
               END IF
               GL = MAX( GL, WL )
               GU = MIN( GU, WU )
               IF( GL.GE.GU ) &
                  GO TO 70
            END IF
!
!           Set Up Initial Interval
!
            WORK( N+1 ) = GL
            WORK( N+IN+1 ) = GU
            CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, &
                         D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), &
                         IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, &
                         IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
!
            NWL = NWL + IWORK( 1 )
            NWU = NWU + IWORK( IN+1 )
            IWOFF = M - IWORK( 1 )
!
!           Compute Eigenvalues
!
            ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / &
                    LOG( TWO ) ) + 2
            CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, &
                         D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), &
                         IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, &
                         IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
!
!           Copy Eigenvalues Into W and IBLOCK
!           Use -JB for block number for unconverged eigenvalues.
!
            DO 60 J = 1, IOUT
               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
!
!              Flag non-convergence.
!
               IF( J.GT.IOUT-IINFO ) THEN
                  NCNVRG = .TRUE.
                  IB = -JB
               ELSE
                  IB = JB
               END IF
               DO 50 JE = IWORK( J ) + 1 + IWOFF, &
                       IWORK( J+IN ) + IWOFF
                  W( JE ) = TMP1
                  IBLOCK( JE ) = IB
   50          CONTINUE
   60       CONTINUE
!
            M = M + IM
         END IF
   70 CONTINUE
!
!     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
!     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
!
      IF( IRANGE.EQ.3 ) THEN
         IM = 0
         IDISCL = IL - 1 - NWL
         IDISCU = NWU - IU
!
         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
            DO 80 JE = 1, M
               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
                  IDISCL = IDISCL - 1
               ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
                  IDISCU = IDISCU - 1
               ELSE
                  IM = IM + 1
                  W( IM ) = W( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
   80       CONTINUE
            M = IM
         END IF
         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
!
!           Code to deal with effects of bad arithmetic:
!           Some low eigenvalues to be discarded are not in (WL,WLU],
!           or high eigenvalues to be discarded are not in (WUL,WU]
!           so just kill off the smallest IDISCL/largest IDISCU
!           eigenvalues, by simply finding the smallest/largest
!           eigenvalue(s).
!
!           (If N(w) is monotone non-decreasing, this should never
!               happen.)
!
            IF( IDISCL.GT.0 ) THEN
               WKILL = WU
               DO 100 JDISC = 1, IDISCL
                  IW = 0
                  DO 90 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND. &
                         ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
   90             CONTINUE
                  IBLOCK( IW ) = 0
  100          CONTINUE
            END IF
            IF( IDISCU.GT.0 ) THEN
!
               WKILL = WL
               DO 120 JDISC = 1, IDISCU
                  IW = 0
                  DO 110 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND. &
                         ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
  110             CONTINUE
                  IBLOCK( IW ) = 0
  120          CONTINUE
            END IF
            IM = 0
            DO 130 JE = 1, M
               IF( IBLOCK( JE ).NE.0 ) THEN
                  IM = IM + 1
                  W( IM ) = W( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
  130       CONTINUE
            M = IM
         END IF
         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
            TOOFEW = .TRUE.
         END IF
      END IF
!
!     If ORDER='B', do nothing -- the eigenvalues are already sorted
!        by block.
!     If ORDER='E', sort the eigenvalues from smallest to largest
!
      IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
         DO 150 JE = 1, M - 1
            IE = 0
            TMP1 = W( JE )
            DO 140 J = JE + 1, M
               IF( W( J ).LT.TMP1 ) THEN
                  IE = J
                  TMP1 = W( J )
               END IF
  140       CONTINUE
!
            IF( IE.NE.0 ) THEN
               ITMP1 = IBLOCK( IE )
               W( IE ) = W( JE )
               IBLOCK( IE ) = IBLOCK( JE )
               W( JE ) = TMP1
               IBLOCK( JE ) = ITMP1
            END IF
  150    CONTINUE
      END IF
!
      INFO = 0
      IF( NCNVRG ) &
         INFO = INFO + 1
      IF( TOOFEW ) &
         INFO = INFO + 2
      RETURN
!
!     End of DSTEBZ
!
      END
      SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, &
                         LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!  symmetric tridiagonal matrix using the divide and conquer method.
!  The eigenvectors of a full or band real symmetric matrix can also be
!  found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
!  matrix to tridiagonal form.
!
!  This code makes very mild assumptions about floating point
!  arithmetic. It will work on machines with a guard digit in
!  add/subtract, or on those binary machines without guard digits
!  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!  It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.  See DLAED3 for details.
!
!  Arguments
!  =========
!
!  COMPZ   (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only.
!          = 'I':  Compute eigenvectors of tridiagonal matrix also.
!          = 'V':  Compute eigenvectors of original dense symmetric
!                  matrix also.  On entry, Z contains the orthogonal
!                  matrix used to reduce the original matrix to
!                  tridiagonal form.
!
!  N       (input) INTEGER
!          The dimension of the symmetric tridiagonal matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the diagonal elements of the tridiagonal matrix.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the subdiagonal elements of the tridiagonal matrix.
!          On exit, E has been destroyed.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if COMPZ = 'V', then Z contains the orthogonal
!          matrix used in the reduction to tridiagonal form.
!          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
!          orthonormal eigenvectors of the original symmetric matrix,
!          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!          of the symmetric tridiagonal matrix.
!          If  COMPZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1.
!          If eigenvectors are desired, then LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array,
!                                         dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
!          If COMPZ = 'V' and N > 1 then LWORK must be at least
!                         ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
!                         where lg( N ) = smallest integer k such
!                         that 2**k >= N.
!          If COMPZ = 'I' and N > 1 then LWORK must be at least
!                         ( 1 + 4*N + N**2 ).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
!          If COMPZ = 'V' and N > 1 then LIWORK must be at least
!                         ( 6 + 6*N + 5*N*lg N ).
!          If COMPZ = 'I' and N > 1 then LIWORK must be at least
!                         ( 3 + 5*N ).
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  The algorithm failed to compute an eigenvalue while
!                working on the submatrix lying in rows and columns
!                INFO/(N+1) through mod(INFO,N+1).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!  Modified by Francoise Tisseur, University of Tennessee.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            DTRTRW, END, I, ICOMPZ, II, J, K, LGN, LIWMIN, &
                         LWMIN, M, SMLSIZ, START, STOREZ
      DOUBLE PRECISION   EPS, ORGNRM, P, TINY
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, &
                         DSTEQR, DSTERF, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG, MAX, MOD, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( N.LE.1 .OR. ICOMPZ.LE.0 ) THEN
         LIWMIN = 1
         LWMIN = 1
      ELSE
         LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IF( 2**LGN.LT.N ) &
            LGN = LGN + 1
         IF( ICOMPZ.EQ.1 ) THEN
            LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
            LIWMIN = 6 + 6*N + 5*N*LGN
         ELSE IF( ICOMPZ.EQ.2 ) THEN
            LWMIN = 1 + 4*N + N**2
            LIWMIN = 3 + 5*N
         END IF
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, &
               N ) ) ) THEN
         INFO = -6
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -8
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEDC', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.NE.0 ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
      SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
!
!     If the following conditional clause is removed, then the routine
!     will use the Divide and Conquer routine to compute only the
!     eigenvalues, which requires (3N + 3N**2) real workspace and
!     (2 + 5N + 2N lg(N)) integer workspace.
!     Since on many architectures DSTERF is much faster than any other
!     algorithm for finding eigenvalues only, it is used here
!     as the default.
!
!     If COMPZ = 'N', use DSTERF to compute the eigenvalues.
!
      IF( ICOMPZ.EQ.0 ) THEN
         CALL DSTERF( N, D, E, INFO )
         RETURN
      END IF
!
!     If N is smaller than the minimum divide size (SMLSIZ+1), then
!     solve the problem with another solver.
!
      IF( N.LE.SMLSIZ ) THEN
         IF( ICOMPZ.EQ.0 ) THEN
            CALL DSTERF( N, D, E, INFO )
            RETURN
         ELSE IF( ICOMPZ.EQ.2 ) THEN
            CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
            RETURN
         ELSE
            CALL DSTEQR( 'V', N, D, E, Z, LDZ, WORK, INFO )
            RETURN
         END IF
      END IF
!
!     If COMPZ = 'V', the Z matrix must be stored elsewhere for later
!     use.
!
      IF( ICOMPZ.EQ.1 ) THEN
         STOREZ = 1 + N*N
      ELSE
         STOREZ = 1
      END IF
!
      IF( ICOMPZ.EQ.2 ) THEN
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
      END IF
!
!     Scale.
!
      ORGNRM = DLANST( 'M', N, D, E )
      IF( ORGNRM.EQ.ZERO ) &
         RETURN
!
      EPS = DLAMCH( 'Epsilon' )
!
      START = 1
!
!     while ( START <= N )
!
   10 CONTINUE
      IF( START.LE.N ) THEN
!
!     Let END be the position of the next subdiagonal entry such that
!     E( END ) <= TINY or END = N if no such subdiagonal exists.  The
!     matrix identified by the elements between START and END
!     constitutes an independent sub-problem.
!
         END = START
   20    CONTINUE
         IF( END.LT.N ) THEN
            TINY = EPS*SQRT( ABS( D( END ) ) )*SQRT( ABS( D( END+1 ) ) )
            IF( ABS( E( END ) ).GT.TINY ) THEN
               END = END + 1
               GO TO 20
            END IF
         END IF
!
!        (Sub) Problem determined.  Compute its size and solve it.
!
         M = END - START + 1
         IF( M.EQ.1 ) THEN
            START = END + 1
            GO TO 10
         END IF
         IF( M.GT.SMLSIZ ) THEN
            INFO = SMLSIZ
!
!           Scale.
!
            ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
            CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, &
                         INFO )
            CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), &
                         M-1, INFO )
!
            IF( ICOMPZ.EQ.1 ) THEN
               DTRTRW = 1
            ELSE
               DTRTRW = START
            END IF
            CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), &
                         Z( DTRTRW, START ), LDZ, WORK( 1 ), N, &
                         WORK( STOREZ ), IWORK, INFO )
            IF( INFO.NE.0 ) THEN
               INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + &
                      MOD( INFO, ( M+1 ) ) + START - 1
               RETURN
            END IF
!
!           Scale back.
!
            CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, &
                         INFO )
!
         ELSE
            IF( ICOMPZ.EQ.1 ) THEN
!
!     Since QR won't update a Z matrix which is larger than the
!     length of D, we must solve the sub-problem in a workspace and
!     then multiply back into Z.
!
               CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, &
                            WORK( M*M+1 ), INFO )
               CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, &
                            WORK( STOREZ ), N )
               CALL DGEMM( 'N', 'N', N, M, M, ONE, WORK( STOREZ ), LDZ, &
                           WORK, M, ZERO, Z( 1, START ), LDZ )
            ELSE IF( ICOMPZ.EQ.2 ) THEN
               CALL DSTEQR( 'I', M, D( START ), E( START ), &
                            Z( START, START ), LDZ, WORK, INFO )
            ELSE
               CALL DSTERF( M, D( START ), E( START ), INFO )
            END IF
            IF( INFO.NE.0 ) THEN
               INFO = START*( N+1 ) + END
               RETURN
            END IF
         END IF
!
         START = END + 1
         GO TO 10
      END IF
!
!     endwhile
!
!     If the problem split any number of times, then the eigenvalues
!     will not be properly ordered.  Here we permute the eigenvalues
!     (and the associated eigenvectors) into ascending order.
!
      IF( M.NE.N ) THEN
         IF( ICOMPZ.EQ.0 ) THEN
!
!        Use Quick Sort
!
            CALL DLASRT( 'I', N, D, INFO )
!
         ELSE
!
!        Use Selection Sort to minimize swaps of eigenvectors
!
            DO 40 II = 2, N
               I = II - 1
               K = I
               P = D( I )
               DO 30 J = II, N
                  IF( D( J ).LT.P ) THEN
                     K = J
                     P = D( J )
                  END IF
   30          CONTINUE
               IF( K.NE.I ) THEN
                  D( K ) = D( I )
                  D( I ) = P
                  CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
               END IF
   40       CONTINUE
         END IF
      END IF
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DSTEDC
!
      END
      SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, &
                         M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, &
                         LIWORK, INFO )
!
!  -- LAPACK computational routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            ISUPPZ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
! DSTEGR computes selected eigenvalues and, optionally, eigenvectors
! of a real symmetric tridiagonal matrix T.  Eigenvalues and
! eigenvectors can be selected by specifying either a range of values
! or a range of indices for the desired eigenvalues. The eigenvalues
! are computed by the dqds algorithm, while orthogonal eigenvectors are
! computed from various ``good'' L D L^T representations (also known as
! Relatively Robust Representations). Gram-Schmidt orthogonalization is
! avoided as far as possible. More specifically, the various steps of
! the algorithm are as follows. For the i-th unreduced block of T,
!     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!         is a relatively robust representation,
!     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!         relative accuracy by the dqds algorithm,
!     (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!         close to the cluster, and go to step (a),
!     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!         compute the corresponding eigenvector by forming a
!         rank-revealing twisted factorization.
!  The desired accuracy of the output can be specified by the input
!  parameter ABSTOL.
!
!  For more details, see "A new O(n^2) algorithm for the symmetric
!  tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!  Computer Science Division Technical Report No. UCB/CSD-97-971,
!  UC Berkeley, May 1997.
!
!  Note 1 : Currently DSTEGR is only set up to find ALL the n
!  eigenvalues and eigenvectors of T in O(n^2) time
!  Note 2 : Currently the routine DSTEIN is called when an appropriate
!  sigma_i cannot be chosen in step (c) above. DSTEIN invokes modified
!  Gram-Schmidt when eigenvalues are close.
!  Note 3 : DSTEGR works only on machines which follow ieee-754
!  floating-point standard in their handling of infinities and NaNs.
!  Normal execution of DSTEGR may create NaNs and infinities and hence
!  may abort due to a floating point exception in environments which
!  do not conform to the ieee standard.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!********* Only RANGE = 'A' is currently supported *********************
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          T. On exit, D is overwritten.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix T in elements 1 to N-1 of E; E(N) need not be set.
!          On exit, E is overwritten.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the
!          eigenvalues/eigenvectors. IF JOBZ = 'V', the eigenvalues and
!          eigenvectors output have residual norms bounded by ABSTOL,
!          and the dot products between different eigenvectors are
!          bounded by ABSTOL. If ABSTOL is less than N*EPS*|T|, then
!          N*EPS*|T| will be used in its place, where EPS is the
!          machine precision and |T| is the 1-norm of the tridiagonal
!          matrix. The eigenvalues are computed to an accuracy of
!          EPS*|T| irrespective of ABSTOL. If high relative accuracy
!          is important, set ABSTOL to DLAMCH( 'Safe minimum' ).
!          See Barlow and Demmel "Computing Accurate Eigensystems of
!          Scaled Diagonally Dominant Matrices", LAPACK Working Note #7
!          for a discussion of which matrices define their eigenvalues
!          to high relative accuracy.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the selected eigenvalues in
!          ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix T
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
!          The support of the eigenvectors in Z, i.e., the indices
!          indicating the nonzero elements in Z. The i-th eigenvector
!          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!          ISUPPZ( 2*i ).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal
!          (and minimal) LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,18*N)
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = 1, internal error in DLARRE,
!                if INFO = 2, internal error in DLARRV.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ
      INTEGER            I, IBEGIN, IEND, IINDBL, IINDWK, IINFO, IINSPL, &
                         INDGRS, INDWOF, INDWRK, ITMP, J, JJ, LIWMIN, &
                         LWMIN, NSPLIT
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SCALE, SMLNUM, &
                         THRESH, TMP, TNRM, TOL
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARRE, DLARRV, DLASET, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
      LWMIN = 18*N
      LIWMIN = 10*N
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
!
!     The following two lines need to be removed once the
!     RANGE = 'V' and RANGE = 'I' options are provided.
!
      ELSE IF( VALEIG .OR. INDEIG ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
         INFO = -7
      ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
         INFO = -8
!     The following change should be made in DSTEVX also, otherwise
!     IL can be specified as N+1 and IU as N.
!     ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
      ELSE IF( INDEIG .AND. ( IU.LT.IL .OR. IU.GT.N ) ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -17
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -19
      END IF
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEGR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      SCALE = ONE
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         SCALE = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         SCALE = RMAX / TNRM
      END IF
      IF( SCALE.NE.ONE ) THEN
         CALL DSCAL( N, SCALE, D, 1 )
         CALL DSCAL( N-1, SCALE, E, 1 )
         TNRM = TNRM*SCALE
      END IF
      INDGRS = 1
      INDWOF = 2*N + 1
      INDWRK = 3*N + 1
!
      IINSPL = 1
      IINDBL = N + 1
      IINDWK = 2*N + 1
!
      CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ )
!
!     Compute the desired eigenvalues of the tridiagonal after splitting
!     into smaller subblocks if the corresponding of-diagonal elements
!     are small
!
      THRESH = EPS*TNRM
      CALL DLARRE( N, D, E, THRESH, NSPLIT, IWORK( IINSPL ), M, W, &
                   WORK( INDWOF ), WORK( INDGRS ), WORK( INDWRK ), &
                   IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
!
      IF( WANTZ ) THEN
!
!        Compute the desired eigenvectors corresponding to the computed
!        eigenvalues
!
         TOL = MAX( ABSTOL, DBLE( N )*THRESH )
         IBEGIN = 1
         DO 20 I = 1, NSPLIT
            IEND = IWORK( IINSPL+I-1 )
            DO 10 J = IBEGIN, IEND
               IWORK( IINDBL+J-1 ) = I
   10       CONTINUE
            IBEGIN = IEND + 1
   20    CONTINUE
!
         CALL DLARRV( N, D, E, IWORK( IINSPL ), M, W, IWORK( IINDBL ), &
                      WORK( INDGRS ), TOL, Z, LDZ, ISUPPZ, &
                      WORK( INDWRK ), IWORK( IINDWK ), IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
!
      END IF
!
      IBEGIN = 1
      DO 40 I = 1, NSPLIT
         IEND = IWORK( IINSPL+I-1 )
         DO 30 J = IBEGIN, IEND
            W( J ) = W( J ) + WORK( INDWOF+I-1 )
   30    CONTINUE
         IBEGIN = IEND + 1
   40 CONTINUE
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( SCALE.NE.ONE ) THEN
         CALL DSCAL( M, ONE / SCALE, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( NSPLIT.GT.1 ) THEN
         DO 60 J = 1, M - 1
            I = 0
            TMP = W( J )
            DO 50 JJ = J + 1, M
               IF( W( JJ ).LT.TMP ) THEN
                  I = JJ
                  TMP = W( JJ )
               END IF
   50       CONTINUE
            IF( I.NE.0 ) THEN
               W( I ) = W( J )
               W( J ) = TMP
               IF( WANTZ ) THEN
                  CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
                  ITMP = ISUPPZ( 2*I-1 )
                  ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
                  ISUPPZ( 2*J-1 ) = ITMP
                  ITMP = ISUPPZ( 2*I )
                  ISUPPZ( 2*I ) = ISUPPZ( 2*J )
                  ISUPPZ( 2*J ) = ITMP
               END IF
            END IF
   60    CONTINUE
      END IF
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
!
!     End of DSTEGR
!
      END
      SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, &
                         IWORK, IFAIL, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDZ, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ), &
                         IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEIN computes the eigenvectors of a real symmetric tridiagonal
!  matrix T corresponding to specified eigenvalues, using inverse
!  iteration.
!
!  The maximum number of iterations allowed for each eigenvector is
!  specified by an internal parameter MAXITS (currently set to 5).
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input) DOUBLE PRECISION array, dimension (N)
!          The n diagonal elements of the tridiagonal matrix T.
!
!  E       (input) DOUBLE PRECISION array, dimension (N)
!          The (n-1) subdiagonal elements of the tridiagonal matrix
!          T, in elements 1 to N-1.  E(N) need not be set.
!
!  M       (input) INTEGER
!          The number of eigenvectors to be found.  0 <= M <= N.
!
!  W       (input) DOUBLE PRECISION array, dimension (N)
!          The first M elements of W contain the eigenvalues for
!          which eigenvectors are to be computed.  The eigenvalues
!          should be grouped by split-off block and ordered from
!          smallest to largest within the block.  ( The output array
!          W from DSTEBZ with ORDER = 'B' is expected here. )
!
!  IBLOCK  (input) INTEGER array, dimension (N)
!          The submatrix indices associated with the corresponding
!          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
!          the first submatrix from the top, =2 if W(i) belongs to
!          the second submatrix, etc.  ( The output array IBLOCK
!          from DSTEBZ is expected here. )
!
!  ISPLIT  (input) INTEGER array, dimension (N)
!          The splitting points, at which T breaks up into submatrices.
!          The first submatrix consists of rows/columns 1 to
!          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
!          through ISPLIT( 2 ), etc.
!          ( The output array ISPLIT from DSTEBZ is expected here. )
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, M)
!          The computed eigenvectors.  The eigenvector associated
!          with the eigenvalue W(i) is stored in the i-th column of
!          Z.  Any vector which fails to converge is set to its current
!          iterate after MAXITS iterations.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  IFAIL   (output) INTEGER array, dimension (M)
!          On normal exit, all elements of IFAIL are zero.
!          If one or more eigenvectors fail to converge after
!          MAXITS iterations, then their indices are stored in
!          array IFAIL.
!
!  INFO    (output) INTEGER
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, then i eigenvectors failed to converge
!               in MAXITS iterations.  Their indices are stored in
!               array IFAIL.
!
!  Internal Parameters
!  ===================
!
!  MAXITS  INTEGER, default = 5
!          The maximum number of iterations performed.
!
!  EXTRA   INTEGER, default = 2
!          The number of iterations performed after norm growth
!          criterion is satisfied, should be at least 1.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN, ODM3, ODM1
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, &
                         ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
      INTEGER            MAXITS, EXTRA
      PARAMETER          ( MAXITS = 5, EXTRA = 2 )
!     ..
!     .. Local Scalars ..
      INTEGER            B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, &
                         INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, &
                         JBLK, JMAX, NBLK, NRMCHK
      DOUBLE PRECISION   DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, &
                         SCL, SEP, TOL, XJ, XJM, ZTR
!     ..
!     .. Local Arrays ..
      INTEGER            ISEED( 4 )
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DASUM, DDOT, DLAMCH, DNRM2
      EXTERNAL           IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      DO 10 I = 1, M
         IFAIL( I ) = 0
   10 CONTINUE
!
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
         INFO = -4
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE
         DO 20 J = 2, M
            IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
               INFO = -6
               GO TO 30
            END IF
            IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) &
                 THEN
               INFO = -5
               GO TO 30
            END IF
   20    CONTINUE
   30    CONTINUE
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEIN', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. M.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      EPS = DLAMCH( 'Precision' )
!
!     Initialize seed for random number generator DLARNV.
!
      DO 40 I = 1, 4
         ISEED( I ) = 1
   40 CONTINUE
!
!     Initialize pointers.
!
      INDRV1 = 0
      INDRV2 = INDRV1 + N
      INDRV3 = INDRV2 + N
      INDRV4 = INDRV3 + N
      INDRV5 = INDRV4 + N
!
!     Compute eigenvectors of matrix blocks.
!
      J1 = 1
      DO 160 NBLK = 1, IBLOCK( M )
!
!        Find starting and ending indices of block nblk.
!
         IF( NBLK.EQ.1 ) THEN
            B1 = 1
         ELSE
            B1 = ISPLIT( NBLK-1 ) + 1
         END IF
         BN = ISPLIT( NBLK )
         BLKSIZ = BN - B1 + 1
         IF( BLKSIZ.EQ.1 ) &
            GO TO 60
         GPIND = B1
!
!        Compute reorthogonalization criterion and stopping criterion.
!
         ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
         ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
         DO 50 I = B1 + 1, BN - 1
            ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ &
                     ABS( E( I ) ) )
   50    CONTINUE
         ORTOL = ODM3*ONENRM
!
         DTPCRT = SQRT( ODM1 / BLKSIZ )
!
!        Loop through eigenvalues of block nblk.
!
   60    CONTINUE
         JBLK = 0
         DO 150 J = J1, M
            IF( IBLOCK( J ).NE.NBLK ) THEN
               J1 = J
               GO TO 160
            END IF
            JBLK = JBLK + 1
            XJ = W( J )
!
!           Skip all the work if the block size is one.
!
            IF( BLKSIZ.EQ.1 ) THEN
               WORK( INDRV1+1 ) = ONE
               GO TO 120
            END IF
!
!           If eigenvalues j and j-1 are too close, add a relatively
!           small perturbation.
!
            IF( JBLK.GT.1 ) THEN
               EPS1 = ABS( EPS*XJ )
               PERTOL = TEN*EPS1
               SEP = XJ - XJM
               IF( SEP.LT.PERTOL ) &
                  XJ = XJM + PERTOL
            END IF
!
            ITS = 0
            NRMCHK = 0
!
!           Get random starting vector.
!
            CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
!
!           Copy the matrix T so it won't be destroyed in factorization.
!
            CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
            CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
!
!           Compute LU factors with partial pivoting  ( PT = LU )
!
            TOL = ZERO
            CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), &
                         WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, &
                         IINFO )
!
!           Update iteration count.
!
   70       CONTINUE
            ITS = ITS + 1
            IF( ITS.GT.MAXITS ) &
               GO TO 100
!
!           Normalize and scale the righthand side vector Pb.
!
            SCL = BLKSIZ*ONENRM*MAX( EPS, &
                  ABS( WORK( INDRV4+BLKSIZ ) ) ) / &
                  DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
!
!           Solve the system LU = Pb.
!
            CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), &
                         WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, &
                         WORK( INDRV1+1 ), TOL, IINFO )
!
!           Reorthogonalize by modified Gram-Schmidt if eigenvalues are
!           close enough.
!
            IF( JBLK.EQ.1 ) &
               GO TO 90
            IF( ABS( XJ-XJM ).GT.ORTOL ) &
               GPIND = J
            IF( GPIND.NE.J ) THEN
               DO 80 I = GPIND, J - 1
                  ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), &
                        1 )
                  CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, &
                              WORK( INDRV1+1 ), 1 )
   80          CONTINUE
            END IF
!
!           Check the infinity norm of the iterate.
!
   90       CONTINUE
            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
            NRM = ABS( WORK( INDRV1+JMAX ) )
!
!           Continue for additional iterations after norm reaches
!           stopping criterion.
!
            IF( NRM.LT.DTPCRT ) &
               GO TO 70
            NRMCHK = NRMCHK + 1
            IF( NRMCHK.LT.EXTRA+1 ) &
               GO TO 70
!
            GO TO 110
!
!           If stopping criterion was not satisfied, update info and
!           store eigenvector number in array ifail.
!
  100       CONTINUE
            INFO = INFO + 1
            IFAIL( INFO ) = J
!
!           Accept iterate as jth eigenvector.
!
  110       CONTINUE
            SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
            JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
            IF( WORK( INDRV1+JMAX ).LT.ZERO ) &
               SCL = -SCL
            CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
  120       CONTINUE
            DO 130 I = 1, N
               Z( I, J ) = ZERO
  130       CONTINUE
            DO 140 I = 1, BLKSIZ
               Z( B1+I-1, J ) = WORK( INDRV1+I )
  140       CONTINUE
!
!           Save the shift to check eigenvalue spacing at next
!           iteration.
!
            XJM = XJ
!
  150    CONTINUE
  160 CONTINUE
!
      RETURN
!
!     End of DSTEIN
!
      END
      SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!  symmetric tridiagonal matrix using the implicit QL or QR method.
!  The eigenvectors of a full or band symmetric matrix can also be found
!  if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
!  tridiagonal form.
!
!  Arguments
!  =========
!
!  COMPZ   (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only.
!          = 'V':  Compute eigenvalues and eigenvectors of the original
!                  symmetric matrix.  On entry, Z must contain the
!                  orthogonal matrix used to reduce the original matrix
!                  to tridiagonal form.
!          = 'I':  Compute eigenvalues and eigenvectors of the
!                  tridiagonal matrix.  Z is initialized to the identity
!                  matrix.
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the diagonal elements of the tridiagonal matrix.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix.
!          On exit, E has been destroyed.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
!          On entry, if  COMPZ = 'V', then Z contains the orthogonal
!          matrix used in the reduction to tridiagonal form.
!          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
!          orthonormal eigenvectors of the original symmetric matrix,
!          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!          of the symmetric tridiagonal matrix.
!          If COMPZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          eigenvectors are desired, then  LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
!          If COMPZ = 'N', then WORK is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  the algorithm has failed to find all the eigenvalues in
!                a total of 30*N iterations; if INFO = i, then i
!                elements of E have not converged to zero; on exit, D
!                and E contain the elements of a symmetric tridiagonal
!                matrix which is orthogonally similar to the original
!                matrix.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         THREE = 3.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, &
                         LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, &
                         NM1, NMAXIT
      DOUBLE PRECISION   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, &
                         S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, &
                         DLASRT, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, &
               N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEQR', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.EQ.2 ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Determine the unit roundoff and over/underflow thresholds.
!
      EPS = DLAMCH( 'E' )
      EPS2 = EPS**2
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
!
!     Compute the eigenvalues and eigenvectors of the tridiagonal
!     matrix.
!
      IF( ICOMPZ.EQ.2 ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
!
      NMAXIT = N*MAXIT
      JTOT = 0
!
!     Determine where the matrix splits and choose QL or QR iteration
!     for each block, according to whether top or bottom diagonal
!     element is smaller.
!
      L1 = 1
      NM1 = N - 1
!
   10 CONTINUE
      IF( L1.GT.N ) &
         GO TO 160
      IF( L1.GT.1 ) &
         E( L1-1 ) = ZERO
      IF( L1.LE.NM1 ) THEN
         DO 20 M = L1, NM1
            TST = ABS( E( M ) )
            IF( TST.EQ.ZERO ) &
               GO TO 30
            IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ &
                1 ) ) ) )*EPS ) THEN
               E( M ) = ZERO
               GO TO 30
            END IF
   20    CONTINUE
      END IF
      M = N
!
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L ) &
         GO TO 10
!
!     Scale submatrix in rows and columns L to LEND
!
      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
      ISCALE = 0
      IF( ANORM.EQ.ZERO ) &
         GO TO 10
      IF( ANORM.GT.SSFMAX ) THEN
         ISCALE = 1
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, &
                      INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, &
                      INFO )
      ELSE IF( ANORM.LT.SSFMIN ) THEN
         ISCALE = 2
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, &
                      INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, &
                      INFO )
      END IF
!
!     Choose between QL and QR iteration
!
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
!
      IF( LEND.GT.L ) THEN
!
!        QL Iteration
!
!        Look for small subdiagonal element.
!
   40    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 50 M = L, LENDM1
               TST = ABS( E( M ) )**2
               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ &
                   SAFMIN )GO TO 60
   50       CONTINUE
         END IF
!
         M = LEND
!
   60    CONTINUE
         IF( M.LT.LEND ) &
            E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L ) &
            GO TO 80
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
         IF( M.EQ.L+1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
               WORK( L ) = C
               WORK( N-1+L ) = S
               CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), &
                           WORK( N-1+L ), Z( 1, L ), LDZ )
            ELSE
               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
            END IF
            D( L ) = RT1
            D( L+1 ) = RT2
            E( L ) = ZERO
            L = L + 2
            IF( L.LE.LEND ) &
               GO TO 40
            GO TO 140
         END IF
!
         IF( JTOT.EQ.NMAXIT ) &
            GO TO 140
         JTOT = JTOT + 1
!
!        Form shift.
!
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
!
         S = ONE
         C = ONE
         P = ZERO
!
!        Inner loop
!
         MM1 = M - 1
         DO 70 I = MM1, L, -1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            IF( I.NE.M-1 ) &
               E( I+1 ) = R
            G = D( I+1 ) - P
            R = ( D( I )-G )*S + TWO*C*B
            P = S*R
            D( I+1 ) = G + P
            G = C*R - B
!
!           If eigenvectors are desired, then save rotations.
!
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
!
   70    CONTINUE
!
!        If eigenvectors are desired, then apply saved rotations.
!
         IF( ICOMPZ.GT.0 ) THEN
            MM = M - L + 1
            CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), &
                        Z( 1, L ), LDZ )
         END IF
!
         D( L ) = D( L ) - P
         E( L ) = G
         GO TO 40
!
!        Eigenvalue found.
!
   80    CONTINUE
         D( L ) = P
!
         L = L + 1
         IF( L.LE.LEND ) &
            GO TO 40
         GO TO 140
!
      ELSE
!
!        QR Iteration
!
!        Look for small superdiagonal element.
!
   90    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 100 M = L, LENDP1, -1
               TST = ABS( E( M-1 ) )**2
               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ &
                   SAFMIN )GO TO 110
  100       CONTINUE
         END IF
!
         M = LEND
!
  110    CONTINUE
         IF( M.GT.LEND ) &
            E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L ) &
            GO TO 130
!
!        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
!        to compute its eigensystem.
!
         IF( M.EQ.L-1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
               WORK( M ) = C
               WORK( N-1+M ) = S
               CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), &
                           WORK( N-1+M ), Z( 1, L-1 ), LDZ )
            ELSE
               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
            END IF
            D( L-1 ) = RT1
            D( L ) = RT2
            E( L-1 ) = ZERO
            L = L - 2
            IF( L.GE.LEND ) &
               GO TO 90
            GO TO 140
         END IF
!
         IF( JTOT.EQ.NMAXIT ) &
            GO TO 140
         JTOT = JTOT + 1
!
!        Form shift.
!
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
!
         S = ONE
         C = ONE
         P = ZERO
!
!        Inner loop
!
         LM1 = L - 1
         DO 120 I = M, LM1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            IF( I.NE.M ) &
               E( I-1 ) = R
            G = D( I ) - P
            R = ( D( I+1 )-G )*S + TWO*C*B
            P = S*R
            D( I ) = G + P
            G = C*R - B
!
!           If eigenvectors are desired, then save rotations.
!
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
!
  120    CONTINUE
!
!        If eigenvectors are desired, then apply saved rotations.
!
         IF( ICOMPZ.GT.0 ) THEN
            MM = L - M + 1
            CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), &
                        Z( 1, M ), LDZ )
         END IF
!
         D( L ) = D( L ) - P
         E( LM1 ) = G
         GO TO 90
!
!        Eigenvalue found.
!
  130    CONTINUE
         D( L ) = P
!
         L = L - 1
         IF( L.GE.LEND ) &
            GO TO 90
         GO TO 140
!
      END IF
!
!     Undo scaling if necessary
!
  140 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, &
                      D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), &
                      N, INFO )
      ELSE IF( ISCALE.EQ.2 ) THEN
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, &
                      D( LSV ), N, INFO )
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), &
                      N, INFO )
      END IF
!
!     Check for no convergence to an eigenvalue after a total
!     of N*MAXIT iterations.
!
      IF( JTOT.LT.NMAXIT ) &
         GO TO 10
      DO 150 I = 1, N - 1
         IF( E( I ).NE.ZERO ) &
            INFO = INFO + 1
  150 CONTINUE
      GO TO 190
!
!     Order eigenvalues and eigenvectors.
!
  160 CONTINUE
      IF( ICOMPZ.EQ.0 ) THEN
!
!        Use Quick Sort
!
         CALL DLASRT( 'I', N, D, INFO )
!
      ELSE
!
!        Use Selection Sort to minimize swaps of eigenvectors
!
         DO 180 II = 2, N
            I = II - 1
            K = I
            P = D( I )
            DO 170 J = II, N
               IF( D( J ).LT.P ) THEN
                  K = J
                  P = D( J )
               END IF
  170       CONTINUE
            IF( K.NE.I ) THEN
               D( K ) = D( I )
               D( I ) = P
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
            END IF
  180    CONTINUE
      END IF
!
  190 CONTINUE
      RETURN
!
!     End of DSTEQR
!
      END
      SUBROUTINE DSTERF( N, D, E, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
!     ..
!
!  Purpose
!  =======
!
!  DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
!  using the Pal-Walker-Kahan variant of the QL or QR algorithm.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix.
!          On exit, E has been destroyed.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  the algorithm failed to find all of the eigenvalues in
!                a total of 30*N iterations; if INFO = i, then i
!                elements of E have not converged to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, &
                         THREE = 3.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, &
                         NMAXIT
      DOUBLE PRECISION   ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, &
                         OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, &
                         SIGMA, SSFMAX, SSFMIN
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
      EXTERNAL           DLAMCH, DLANST, DLAPY2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAE2, DLASCL, DLASRT, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
!
!     Quick return if possible
!
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DSTERF', -INFO )
         RETURN
      END IF
      IF( N.LE.1 ) &
         RETURN
!
!     Determine the unit roundoff for this environment.
!
      EPS = DLAMCH( 'E' )
      EPS2 = EPS**2
      SAFMIN = DLAMCH( 'S' )
      SAFMAX = ONE / SAFMIN
      SSFMAX = SQRT( SAFMAX ) / THREE
      SSFMIN = SQRT( SAFMIN ) / EPS2
!
!     Compute the eigenvalues of the tridiagonal matrix.
!
      NMAXIT = N*MAXIT
      SIGMA = ZERO
      JTOT = 0
!
!     Determine where the matrix splits and choose QL or QR iteration
!     for each block, according to whether top or bottom diagonal
!     element is smaller.
!
      L1 = 1
!
   10 CONTINUE
      IF( L1.GT.N ) &
         GO TO 170
      IF( L1.GT.1 ) &
         E( L1-1 ) = ZERO
      DO 20 M = L1, N - 1
         IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ &
             1 ) ) ) )*EPS ) THEN
            E( M ) = ZERO
            GO TO 30
         END IF
   20 CONTINUE
      M = N
!
   30 CONTINUE
      L = L1
      LSV = L
      LEND = M
      LENDSV = LEND
      L1 = M + 1
      IF( LEND.EQ.L ) &
         GO TO 10
!
!     Scale submatrix in rows and columns L to LEND
!
      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
      ISCALE = 0
      IF( ANORM.GT.SSFMAX ) THEN
         ISCALE = 1
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, &
                      INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, &
                      INFO )
      ELSE IF( ANORM.LT.SSFMIN ) THEN
         ISCALE = 2
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, &
                      INFO )
         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, &
                      INFO )
      END IF
!
      DO 40 I = L, LEND - 1
         E( I ) = E( I )**2
   40 CONTINUE
!
!     Choose between QL and QR iteration
!
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         LEND = LSV
         L = LENDSV
      END IF
!
      IF( LEND.GE.L ) THEN
!
!        QL Iteration
!
!        Look for small subdiagonal element.
!
   50    CONTINUE
         IF( L.NE.LEND ) THEN
            DO 60 M = L, LEND - 1
               IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) &
                  GO TO 70
   60       CONTINUE
         END IF
         M = LEND
!
   70    CONTINUE
         IF( M.LT.LEND ) &
            E( M ) = ZERO
         P = D( L )
         IF( M.EQ.L ) &
            GO TO 90
!
!        If remaining matrix is 2 by 2, use DLAE2 to compute its
!        eigenvalues.
!
         IF( M.EQ.L+1 ) THEN
            RTE = SQRT( E( L ) )
            CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
            D( L ) = RT1
            D( L+1 ) = RT2
            E( L ) = ZERO
            L = L + 2
            IF( L.LE.LEND ) &
               GO TO 50
            GO TO 150
         END IF
!
         IF( JTOT.EQ.NMAXIT ) &
            GO TO 150
         JTOT = JTOT + 1
!
!        Form shift.
!
         RTE = SQRT( E( L ) )
         SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
!
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
!
!        Inner loop
!
         DO 80 I = M - 1, L, -1
            BB = E( I )
            R = P + BB
            IF( I.NE.M-1 ) &
               E( I+1 ) = S*R
            OLDC = C
            C = P / R
            S = BB / R
            OLDGAM = GAMMA
            ALPHA = D( I )
            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
            D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
            IF( C.NE.ZERO ) THEN
               P = ( GAMMA*GAMMA ) / C
            ELSE
               P = OLDC*BB
            END IF
   80    CONTINUE
!
         E( L ) = S*P
         D( L ) = SIGMA + GAMMA
         GO TO 50
!
!        Eigenvalue found.
!
   90    CONTINUE
         D( L ) = P
!
         L = L + 1
         IF( L.LE.LEND ) &
            GO TO 50
         GO TO 150
!
      ELSE
!
!        QR Iteration
!
!        Look for small superdiagonal element.
!
  100    CONTINUE
         DO 110 M = L, LEND + 1, -1
            IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) &
               GO TO 120
  110    CONTINUE
         M = LEND
!
  120    CONTINUE
         IF( M.GT.LEND ) &
            E( M-1 ) = ZERO
         P = D( L )
         IF( M.EQ.L ) &
            GO TO 140
!
!        If remaining matrix is 2 by 2, use DLAE2 to compute its
!        eigenvalues.
!
         IF( M.EQ.L-1 ) THEN
            RTE = SQRT( E( L-1 ) )
            CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
            D( L ) = RT1
            D( L-1 ) = RT2
            E( L-1 ) = ZERO
            L = L - 2
            IF( L.GE.LEND ) &
               GO TO 100
            GO TO 150
         END IF
!
         IF( JTOT.EQ.NMAXIT ) &
            GO TO 150
         JTOT = JTOT + 1
!
!        Form shift.
!
         RTE = SQRT( E( L-1 ) )
         SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
!
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
!
!        Inner loop
!
         DO 130 I = M, L - 1
            BB = E( I )
            R = P + BB
            IF( I.NE.M ) &
               E( I-1 ) = S*R
            OLDC = C
            C = P / R
            S = BB / R
            OLDGAM = GAMMA
            ALPHA = D( I+1 )
            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
            D( I ) = OLDGAM + ( ALPHA-GAMMA )
            IF( C.NE.ZERO ) THEN
               P = ( GAMMA*GAMMA ) / C
            ELSE
               P = OLDC*BB
            END IF
  130    CONTINUE
!
         E( L-1 ) = S*P
         D( L ) = SIGMA + GAMMA
         GO TO 100
!
!        Eigenvalue found.
!
  140    CONTINUE
         D( L ) = P
!
         L = L - 1
         IF( L.GE.LEND ) &
            GO TO 100
         GO TO 150
!
      END IF
!
!     Undo scaling if necessary
!
  150 CONTINUE
      IF( ISCALE.EQ.1 ) &
         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, &
                      D( LSV ), N, INFO )
      IF( ISCALE.EQ.2 ) &
         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, &
                      D( LSV ), N, INFO )
!
!     Check for no convergence to an eigenvalue after a total
!     of N*MAXIT iterations.
!
      IF( JTOT.LT.NMAXIT ) &
         GO TO 10
      DO 160 I = 1, N - 1
         IF( E( I ).NE.ZERO ) &
            INFO = INFO + 1
  160 CONTINUE
      GO TO 180
!
!     Sort eigenvalues in increasing order.
!
  170 CONTINUE
      CALL DLASRT( 'I', N, D, INFO )
!
  180 CONTINUE
      RETURN
!
!     End of DSTERF
!
      END
      SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ
      INTEGER            INFO, LDZ, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEV computes all eigenvalues and, optionally, eigenvectors of a
!  real symmetric tridiagonal matrix A.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A, stored in elements 1 to N-1 of E; E(N) need not
!          be set, but is used by the routine.
!          On exit, the contents of E are destroyed.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with D(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
!          If JOBZ = 'N', WORK is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of E did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            WANTZ
      INTEGER            IMAX, ISCALE
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, &
                         TNRM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSTEQR, DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -6
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEV ', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / TNRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( N, SIGMA, D, 1 )
         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
      END IF
!
!     For eigenvalues only, call DSTERF.  For eigenvalues and
!     eigenvectors, call DSTEQR.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, D, E, INFO )
      ELSE
         CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, D, 1 )
      END IF
!
      RETURN
!
!     End of DSTEV
!
      END
      SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, &
                         LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ
      INTEGER            INFO, LDZ, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
!  real symmetric tridiagonal matrix. If eigenvectors are desired, it
!  uses a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.
!          On exit, if INFO = 0, the eigenvalues in ascending order.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A, stored in elements 1 to N-1 of E; E(N) need not
!          be set, but is used by the routine.
!          On exit, the contents of E are destroyed.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
!          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
!          eigenvectors of the matrix A, with the i-th column of Z
!          holding the eigenvector associated with D(i).
!          If JOBZ = 'N', then Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array,
!                                         dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1.
!          If JOBZ  = 'V' and N > 1 then LWORK must be at least
!                         ( 1 + 4*N + N**2 ).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1.
!          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of E did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, WANTZ
      INTEGER            ISCALE, LIWMIN, LWMIN
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, &
                         TNRM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSTEDC, DSTERF, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      LIWMIN = 1
      LWMIN = 1
      IF( N.GT.1 .AND. WANTZ ) THEN
         LWMIN = 1 + 4*N + N**2
         LIWMIN = 3 + 5*N
      END IF
!
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -6
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -8
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / TNRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( N, SIGMA, D, 1 )
         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
      END IF
!
!     For eigenvalues only, call DSTERF.  For eigenvalues and
!     eigenvectors, call DSTEDC.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, D, E, INFO )
      ELSE
         CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) &
         CALL DSCAL( N, ONE / SIGMA, D, 1 )
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DSTEVD
!
      END
      SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, &
                         M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, &
                         LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 20, 2000
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            ISUPPZ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEVR computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric tridiagonal matrix T.  Eigenvalues and
!  eigenvectors can be selected by specifying either a range of values
!  or a range of indices for the desired eigenvalues.
!
!  Whenever possible, DSTEVR calls SSTEGR to compute the
!  eigenspectrum using Relatively Robust Representations.  DSTEGR
!  computes eigenvalues by the dqds algorithm, while orthogonal
!  eigenvectors are computed from various "good" L D L^T representations
!  (also known as Relatively Robust Representations). Gram-Schmidt
!  orthogonalization is avoided as far as possible. More specifically,
!  the various steps of the algorithm are as follows. For the i-th
!  unreduced block of T,
!     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!          is a relatively robust representation,
!     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!         relative accuracy by the dqds algorithm,
!     (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!         close to the cluster, and go to step (a),
!     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!         compute the corresponding eigenvector by forming a
!         rank-revealing twisted factorization.
!  The desired accuracy of the output can be specified by the input
!  parameter ABSTOL.
!
!  For more details, see "A new O(n^2) algorithm for the symmetric
!  tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!  Computer Science Division Technical Report No. UCB//CSD-97-971,
!  UC Berkeley, May 1997.
!
!
!  Note 1 : DSTEVR calls SSTEGR when the full spectrum is requested
!  on machines which conform to the ieee-754 floating point standard.
!  DSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and
!  when partial spectrum requests are made.
!
!  Normal execution of DSTEGR may create NaNs and infinities and
!  hence may abort due to a floating point exception in environments
!  which do not handle NaNs and infinities in the ieee standard default
!  manner.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
!********* DSTEIN are called
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.
!          On exit, D may be multiplied by a constant factor chosen
!          to avoid over/underflow in computing the eigenvalues.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A in elements 1 to N-1 of E; E(N) need not be set.
!          On exit, E may be multiplied by a constant factor chosen
!          to avoid over/underflow in computing the eigenvalues.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!          If high relative accuracy is important, set ABSTOL to
!          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that
!          eigenvalues are computed to high relative accuracy when
!          possible in future releases.  The current code does not
!          make any guarantees about high relative accuracy, but
!          future releases will. See J. Barlow and J. Demmel,
!          "Computing Accurate Eigensystems of Scaled Diagonally
!          Dominant Matrices", LAPACK Working Note #7, for a discussion
!          of which matrices define their eigenvalues to high relative
!          accuracy.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the selected eigenvalues in
!          ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
!          The support of the eigenvectors in Z, i.e., the indices
!          indicating the nonzero elements in Z. The i-th eigenvector
!          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!          ISUPPZ( 2*i ).
!********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal (and
!          minimal) LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= 20*N.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal (and
!          minimal) LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.  LIWORK >= 10*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  Internal error
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!     Ken Stanley, Computer Science Division, University of
!       California at Berkeley, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP, &
                         INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN, &
                         NSPLIT
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, &
                         TMP1, TNRM, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTEGR, DSTEIN, DSTERF, &
                         DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!
!     Test the input parameters.
!
      IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 )
!
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
      LWMIN = 20*N
      LIWMIN = 10*N
!
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -7
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -8
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -9
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
            INFO = -14
         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -17
         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -19
         END IF
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEVR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      VLL = VL
      VUU = VU
!
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / TNRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( N, SIGMA, D, 1 )
         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     If all eigenvalues are desired, then
!     call DSTERF or SSTEGR.  If this fails for some eigenvalue, then
!     try DSTEBZ.
!
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          IEEEOK.EQ.1 ) THEN
         CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
         IF( .NOT.WANTZ ) THEN
            CALL DCOPY( N, D, 1, W, 1 )
            CALL DSTERF( N, W, WORK, INFO )
         ELSE
            CALL DCOPY( N, D, 1, WORK( N+1 ), 1 )
            CALL DSTEGR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL, &
                         IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, &
                         WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
!
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 10
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIFL = INDISP + N
      INDIWO = INDIFL + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, &
                   NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK, &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), &
                      Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ), &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   10 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 30 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 20 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   20       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( I )
               W( I ) = W( J )
               IWORK( I ) = IWORK( J )
               W( J ) = TMP1
               IWORK( J ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
            END IF
   30    CONTINUE
      END IF
!
!      Causes problems with tests 19 & 20:
!      IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
!
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
!
!     End of DSTEVR
!
      END
      SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, &
                         M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      INTEGER            IL, INFO, IU, LDZ, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSTEVX computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric tridiagonal matrix A.  Eigenvalues and
!  eigenvectors can be selected by specifying either a range of values
!  or a range of indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  N       (input) INTEGER
!          The order of the matrix.  N >= 0.
!
!  D       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the n diagonal elements of the tridiagonal matrix
!          A.
!          On exit, D may be multiplied by a constant factor chosen
!          to avoid over/underflow in computing the eigenvalues.
!
!  E       (input/output) DOUBLE PRECISION array, dimension (N)
!          On entry, the (n-1) subdiagonal elements of the tridiagonal
!          matrix A in elements 1 to N-1 of E; E(N) need not be set.
!          On exit, E may be multiplied by a constant factor chosen
!          to avoid over/underflow in computing the eigenvalues.
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less
!          than or equal to zero, then  EPS*|T|  will be used in
!          its place, where |T| is the 1-norm of the tridiagonal
!          matrix.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the selected eigenvalues in
!          ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If an eigenvector fails to converge (INFO > 0), then that
!          column of Z contains the latest approximation to the
!          eigenvector, and the index of the eigenvector is returned
!          in IFAIL.  If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, then i eigenvectors failed to converge.
!                Their indices are stored in array IFAIL.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IMAX, INDIBL, INDISP, INDIWO, INDWRK, &
                         ISCALE, ITMP1, J, JJ, NSPLIT
      DOUBLE PRECISION   BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, &
                         TMP1, TNRM, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF, &
                         DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -7
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -8
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -9
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) &
            INFO = -14
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEVX', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      IF( VALEIG ) THEN
         VLL = VL
         VUU = VU
      ELSE
         VLL = ZERO
         VUU = ZERO
      END IF
      TNRM = DLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / TNRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( N, SIGMA, D, 1 )
         CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     If all eigenvalues are desired and ABSTOL is less than zero, then
!     call DSTERF or SSTEQR.  If this fails for some eigenvalue, then
!     try DSTEBZ.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, D, 1, W, 1 )
         CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
         INDWRK = N + 1
         IF( .NOT.WANTZ ) THEN
            CALL DSTERF( N, W, WORK, INFO )
         ELSE
            CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 10 I = 1, N
                  IFAIL( I ) = 0
   10          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 20
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDWRK = 1
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, &
                   NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), &
                   WORK( INDWRK ), IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), &
                      Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL, &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   20 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 40 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 30 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   30       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DSTEVX
!
      END
      SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   ANORM, RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYCON estimates the reciprocal of the condition number (in the
!  1-norm) of a real symmetric matrix A using the factorization
!  A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
!
!  An estimate is obtained for norm(inv(A)), and the reciprocal of the
!  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The block diagonal matrix D and the multipliers used to
!          obtain the factor U or L as computed by DSYTRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSYTRF.
!
!  ANORM   (input) DOUBLE PRECISION
!          The 1-norm of the original matrix A.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
!          estimate of the 1-norm of inv(A) computed in this routine.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  IWORK    (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, KASE
      DOUBLE PRECISION   AINVNM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DSYTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( ANORM.LT.ZERO ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      RCOND = ZERO
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      ELSE IF( ANORM.LE.ZERO ) THEN
         RETURN
      END IF
!
!     Check that the diagonal matrix D is nonsingular.
!
      IF( UPPER ) THEN
!
!        Upper triangular storage: examine D from bottom to top
!
         DO 10 I = N, 1, -1
            IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) &
               RETURN
   10    CONTINUE
      ELSE
!
!        Lower triangular storage: examine D from top to bottom.
!
         DO 20 I = 1, N
            IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO ) &
               RETURN
   20    CONTINUE
      END IF
!
!     Estimate the 1-norm of the inverse.
!
      KASE = 0
   30 CONTINUE
      CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
      IF( KASE.NE.0 ) THEN
!
!        Multiply by inv(L*D*L') or inv(U*D*U').
!
         CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
         GO TO 30
      END IF
!
!     Compute the estimate of the reciprocal condition number.
!
      IF( AINVNM.NE.ZERO ) &
         RCOND = ( ONE / AINVNM ) / ANORM
!
      RETURN
!
!     End of DSYCON
!
      END
      SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYEV computes all eigenvalues and, optionally, eigenvectors of a
!  real symmetric matrix A.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,3*N-1).
!          For optimal efficiency, LWORK >= (NB+2)*N,
!          where NB is the blocksize for DSYTRD returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LOWER, LQUERY, WANTZ
      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, &
                         LLWORK, LOPT, LWKOPT, NB
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, &
                         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
      LQUERY = ( LWORK.EQ.-1 )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN
         INFO = -8
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
         LWKOPT = MAX( 1, ( NB+2 )*N )
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYEV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( N.EQ.1 ) THEN
         W( 1 ) = A( 1, 1 )
         WORK( 1 ) = 3
         IF( WANTZ ) &
            A( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) &
         CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
!
!     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
!
      INDE = 1
      INDTAU = INDE + N
      INDWRK = INDTAU + N
      LLWORK = LWORK - INDWRK + 1
      CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), &
                   WORK( INDWRK ), LLWORK, IINFO )
      LOPT = 2*N + WORK( INDWRK )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, first call
!     DORGTR to generate the orthogonal matrix, then call DSTEQR.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), &
                      LLWORK, IINFO )
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), &
                      INFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     Set WORK(1) to optimal workspace size.
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DSYEV
!
      END
      SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, &
                         LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDA, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
!  real symmetric matrix A. If eigenvectors are desired, it uses a
!  divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Because of large use of BLAS of level 3, DSYEVD needs N**2 more
!  workspace than DSYEVX.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  WORK    (workspace/output) DOUBLE PRECISION array,
!                                         dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If N <= 1,               LWORK must be at least 1.
!          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
!          If JOBZ = 'V' and N > 1, LWORK must be at least
!                                                1 + 6*N + 2*N**2.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If N <= 1,                LIWORK must be at least 1.
!          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.
!          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the algorithm failed to converge; i
!                off-diagonal elements of an intermediate tridiagonal
!                form did not converge to zero.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Jeff Rutter, Computer Science Division, University of California
!     at Berkeley, USA
!  Modified by Francoise Tisseur, University of Tennessee.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
!
      LOGICAL            LOWER, LQUERY, WANTZ
      INTEGER            IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, &
                         LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, &
                         SMLNUM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, &
                         DSYTRD, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LIWMIN = 1
         LWMIN = 1
         LOPT = LWMIN
         LIOPT = LIWMIN
      ELSE
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 6*N + 2*N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N + 1
         END IF
         LOPT = LWMIN
         LIOPT = LIWMIN
      END IF
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -8
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LOPT
         IWORK( 1 ) = LIOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYEVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         W( 1 ) = A( 1, 1 )
         IF( WANTZ ) &
            A( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
!
!     Scale matrix to allowable range, if necessary.
!
      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) &
         CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
!
!     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
!
      INDE = 1
      INDTAU = INDE + N
      INDWRK = INDTAU + N
      LLWORK = LWORK - INDWRK + 1
      INDWK2 = INDWRK + N*N
      LLWRK2 = LWORK - INDWK2 + 1
!
      CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), &
                   WORK( INDWRK ), LLWORK, IINFO )
      LOPT = 2*N + WORK( INDWRK )
!
!     For eigenvalues only, call DSTERF.  For eigenvectors, first call
!     DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
!     tridiagonal matrix, then call DORMTR to multiply it by the
!     Householder transformations stored in A.
!
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, &
                      WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
         CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), &
                      WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
         CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
         LOPT = MAX( LOPT, 1+6*N+2*N**2 )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
      IF( ISCALE.EQ.1 ) &
         CALL DSCAL( N, ONE / SIGMA, W, 1 )
!
      WORK( 1 ) = LOPT
      IWORK( 1 ) = LIOPT
!
      RETURN
!
!     End of DSYEVD
!
      END
      SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, &
                         ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, &
                         IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 20, 2000
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            ISUPPZ( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYEVR computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric matrix T.  Eigenvalues and eigenvectors can be
!  selected by specifying either a range of values or a range of
!  indices for the desired eigenvalues.
!
!  Whenever possible, DSYEVR calls DSTEGR to compute the
!  eigenspectrum using Relatively Robust Representations.  DSTEGR
!  computes eigenvalues by the dqds algorithm, while orthogonal
!  eigenvectors are computed from various "good" L D L^T representations
!  (also known as Relatively Robust Representations). Gram-Schmidt
!  orthogonalization is avoided as far as possible. More specifically,
!  the various steps of the algorithm are as follows. For the i-th
!  unreduced block of T,
!     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!          is a relatively robust representation,
!     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!         relative accuracy by the dqds algorithm,
!     (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!         close to the cluster, and go to step (a),
!     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!         compute the corresponding eigenvector by forming a
!         rank-revealing twisted factorization.
!  The desired accuracy of the output can be specified by the input
!  parameter ABSTOL.
!
!  For more details, see "A new O(n^2) algorithm for the symmetric
!  tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!  Computer Science Division Technical Report No. UCB//CSD-97-971,
!  UC Berkeley, May 1997.
!
!
!  Note 1 : DSYEVR calls DSTEGR when the full spectrum is requested
!  on machines which conform to the ieee-754 floating point standard.
!  DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
!  when partial spectrum requests are made.
!
!  Normal execution of DSTEGR may create NaNs and infinities and
!  hence may abort due to a floating point exception in environments
!  which do not handle NaNs and infinities in the ieee standard default
!  manner.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
!********* DSTEIN are called
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, the lower triangle (if UPLO='L') or the upper
!          triangle (if UPLO='U') of A, including the diagonal, is
!          destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!          If high relative accuracy is important, set ABSTOL to
!          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that
!          eigenvalues are computed to high relative accuracy when
!          possible in future releases.  The current code does not
!          make any guarantees about high relative accuracy, but
!          furutre releases will. See J. Barlow and J. Demmel,
!          "Computing Accurate Eigensystems of Scaled Diagonally
!          Dominant Matrices", LAPACK Working Note #7, for a discussion
!          of which matrices define their eigenvalues to high relative
!          accuracy.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          The first M elements contain the selected eigenvalues in
!          ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )
!          The support of the eigenvectors in Z, i.e., the indices
!          indicating the nonzero elements in Z. The i-th eigenvector
!          is nonzero only in elements ISUPPZ( 2*i-1 ) through
!          ISUPPZ( 2*i ).
!********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,26*N).
!          For optimal efficiency, LWORK >= (NB+6)*N,
!          where NB is the max of the blocksize for DSYTRD and DORMTR
!          returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.  LIWORK >= max(1,10*N).
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  Internal error
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Inderjit Dhillon, IBM Almaden, USA
!     Osni Marques, LBNL/NERSC, USA
!     Ken Stanley, Computer Science Division, University of
!       California at Berkeley, USA
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, &
                         INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, &
                         INDWK, INDWKN, ISCALE, ITMP1, J, JJ, LIWMIN, &
                         LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, &
                         SIGMA, SMLNUM, TMP1, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEGR, DSTEIN, &
                         DSTERF, DSWAP, DSYTRD, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 )
!
      LOWER = LSAME( UPLO, 'L' )
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
!
      LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
!
      LWMIN = MAX( 1, 26*N )
      LIWMIN = MAX( 1, 10*N )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -8
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -9
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -10
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
            INFO = -15
         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -18
         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -20
         END IF
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
         NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) )
         LWKOPT = MAX( ( NB+1 )*N, LWMIN )
         WORK( 1 ) = LWKOPT
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYEVR', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( N.EQ.1 ) THEN
         WORK( 1 ) = 7
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = A( 1, 1 )
         ELSE
            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
               M = 1
               W( 1 ) = A( 1, 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      ABSTLL = ABSTOL
      VLL = VL
      VUU = VU
      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         IF( LOWER ) THEN
            DO 10 J = 1, N
               CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
   10       CONTINUE
         ELSE
            DO 20 J = 1, N
               CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
   20       CONTINUE
         END IF
         IF( ABSTOL.GT.0 ) &
            ABSTLL = ABSTOL*SIGMA
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
!
      INDTAU = 1
      INDE = INDTAU + N
      INDD = INDE + N
      INDEE = INDD + N
      INDDD = INDEE + N
      INDIFL = INDDD + N
      INDWK = INDIFL + N
      LLWORK = LWORK - INDWK + 1
      CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), &
                   WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
!
!     If all eigenvalues are desired
!     then call DSTERF or SSTEGR and DORMTR.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          IEEEOK.EQ.1 ) THEN
         IF( .NOT.WANTZ ) THEN
            CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTERF( N, W, WORK( INDEE ), INFO )
         ELSE
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
!
            CALL DSTEGR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), &
                         VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, &
                         WORK( INDWK ), LWORK, IWORK, LIWORK, INFO )
!
!
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
            IF( WANTZ .AND. INFO.EQ.0 ) THEN
               INDWKN = INDE
               LLWRKN = LWORK - INDWKN + 1
               CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, &
                            WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), &
                            LLWRKN, IINFO )
            END IF
         END IF
!
!
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 30
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!     Also call DSTEBZ and SSTEIN if SSTEGR fails.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIFL = 1
      INDIBL = INDIFL + N
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, &
                   WORK( INDD ), WORK( INDE ), M, NSPLIT, W, &
                   IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, &
                      IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, &
                      WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), &
                      INFO )
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         INDWKN = INDE
         LLWRKN = LWORK - INDWKN + 1
         CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, &
                      LDZ, WORK( INDWKN ), LLWRKN, IINFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   30 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 50 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 40 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   40       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
            END IF
   50    CONTINUE
      END IF
!
!     Set WORK(1) to optimal workspace size.
!
      WORK( 1 ) = LWKOPT
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DSYEVR
!
      END
      SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, &
                         ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, &
                         IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, LDA, LDZ, LWORK, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYEVX computes selected eigenvalues and, optionally, eigenvectors
!  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be
!  selected by specifying either a range of values or a range of indices
!  for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, the lower triangle (if UPLO='L') or the upper
!          triangle (if UPLO='U') of A, including the diagonal, is
!          destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!          See "Computing Small Singular Values of Bidiagonal Matrices
!          with Guaranteed High Relative Accuracy," by Demmel and
!          Kahan, LAPACK Working Note #3.
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          On normal exit, the first M elements contain the selected
!          eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          If JOBZ = 'N', then Z is not referenced.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,8*N).
!          For optimal efficiency, LWORK >= (NB+3)*N,
!          where NB is the max of the blocksize for DSYTRD and DORMTR
!          returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, then i eigenvectors failed to converge.
!                Their indices are stored in array IFAIL.
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ
      CHARACTER          ORDER
      INTEGER            I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, &
                         INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, &
                         ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, LWKOPT, NB, &
                         NSPLIT
      DOUBLE PRECISION   ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, &
                         SIGMA, SMLNUM, TMP1, VLL, VUU
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, &
                         DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LOWER = LSAME( UPLO, 'L' )
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
      LQUERY = ( LWORK.EQ.-1 )
!
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE
         IF( VALEIG ) THEN
            IF( N.GT.0 .AND. VU.LE.VL ) &
               INFO = -8
         ELSE IF( INDEIG ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -9
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -10
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
            INFO = -15
         ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN
            INFO = -17
         END IF
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
         NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
         LWKOPT = ( NB+3 )*N
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYEVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      IF( N.EQ.1 ) THEN
         WORK( 1 ) = 7
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = A( 1, 1 )
         ELSE
            IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
               M = 1
               W( 1 ) = A( 1, 1 )
            END IF
         END IF
         IF( WANTZ ) &
            Z( 1, 1 ) = ONE
         RETURN
      END IF
!
!     Get machine constants.
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
!
!     Scale matrix to allowable range, if necessary.
!
      ISCALE = 0
      ABSTLL = ABSTOL
      VLL = VL
      VUU = VU
      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         IF( LOWER ) THEN
            DO 10 J = 1, N
               CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
   10       CONTINUE
         ELSE
            DO 20 J = 1, N
               CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
   20       CONTINUE
         END IF
         IF( ABSTOL.GT.0 ) &
            ABSTLL = ABSTOL*SIGMA
         IF( VALEIG ) THEN
            VLL = VL*SIGMA
            VUU = VU*SIGMA
         END IF
      END IF
!
!     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
!
      INDTAU = 1
      INDE = INDTAU + N
      INDD = INDE + N
      INDWRK = INDD + N
      LLWORK = LWORK - INDWRK + 1
      CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), &
                   WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
      LOPT = 3*N + WORK( INDWRK )
!
!     If all eigenvalues are desired and ABSTOL is less than or equal to
!     zero, then call DSTERF or DORGTR and SSTEQR.  If this fails for
!     some eigenvalue, then try DSTEBZ.
!
      IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. &
          ( ABSTOL.LE.ZERO ) ) THEN
         CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
         INDEE = INDWRK + 2*N
         IF( .NOT.WANTZ ) THEN
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTERF( N, W, WORK( INDEE ), INFO )
         ELSE
            CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
            CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), &
                         WORK( INDWRK ), LLWORK, IINFO )
            CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
            CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, &
                         WORK( INDWRK ), INFO )
            IF( INFO.EQ.0 ) THEN
               DO 30 I = 1, N
                  IFAIL( I ) = 0
   30          CONTINUE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            M = N
            GO TO 40
         END IF
         INFO = 0
      END IF
!
!     Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
!
      IF( WANTZ ) THEN
         ORDER = 'B'
      ELSE
         ORDER = 'E'
      END IF
      INDIBL = 1
      INDISP = INDIBL + N
      INDIWO = INDISP + N
      CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, &
                   WORK( INDD ), WORK( INDE ), M, NSPLIT, W, &
                   IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), &
                   IWORK( INDIWO ), INFO )
!
      IF( WANTZ ) THEN
         CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, &
                      IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, &
                      WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
!
!        Apply orthogonal matrix used in reduction to tridiagonal
!        form to eigenvectors returned by DSTEIN.
!
         INDWKN = INDE
         LLWRKN = LWORK - INDWKN + 1
         CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, &
                      LDZ, WORK( INDWKN ), LLWRKN, IINFO )
      END IF
!
!     If matrix was scaled, then rescale eigenvalues appropriately.
!
   40 CONTINUE
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = M
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
!
!     If eigenvalues are not in order, then sort them, along with
!     eigenvectors.
!
      IF( WANTZ ) THEN
         DO 60 J = 1, M - 1
            I = 0
            TMP1 = W( J )
            DO 50 JJ = J + 1, M
               IF( W( JJ ).LT.TMP1 ) THEN
                  I = JJ
                  TMP1 = W( JJ )
               END IF
   50       CONTINUE
!
            IF( I.NE.0 ) THEN
               ITMP1 = IWORK( INDIBL+I-1 )
               W( I ) = W( J )
               IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
               W( J ) = TMP1
               IWORK( INDIBL+J-1 ) = ITMP1
               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
               IF( INFO.NE.0 ) THEN
                  ITMP1 = IFAIL( I )
                  IFAIL( I ) = IFAIL( J )
                  IFAIL( J ) = ITMP1
               END IF
            END IF
   60    CONTINUE
      END IF
!
!     Set WORK(1) to optimal workspace size.
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DSYEVX
!
      END
      SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, ITYPE, LDA, LDB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYGS2 reduces a real symmetric-definite generalized eigenproblem
!  to standard form.
!
!  If ITYPE = 1, the problem is A*x = lambda*B*x,
!  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
!
!  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
!
!  B must have been previously factorized as U'*U or L*L' by DPOTRF.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
!          = 2 or 3: compute U*A*U' or L'*A*L.
!
!  UPLO    (input) CHARACTER
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored, and how B has been factorized.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n by n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n by n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the transformed matrix, stored in the
!          same format as A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
!          The triangular factor from the Cholesky factorization of B,
!          as returned by DPOTRF.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, HALF
      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            K
      DOUBLE PRECISION   AKK, BKK, CT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYGS2', -INFO )
         RETURN
      END IF
!
      IF( ITYPE.EQ.1 ) THEN
         IF( UPPER ) THEN
!
!           Compute inv(U')*A*inv(U)
!
            DO 10 K = 1, N
!
!              Update the upper triangle of A(k:n,k:n)
!
               AKK = A( K, K )
               BKK = B( K, K )
               AKK = AKK / BKK**2
               A( K, K ) = AKK
               IF( K.LT.N ) THEN
                  CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
                  CT = -HALF*AKK
                  CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), &
                              LDA )
                  CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, &
                              B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
                  CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), &
                              LDA )
                  CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, &
                              B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
               END IF
   10       CONTINUE
         ELSE
!
!           Compute inv(L)*A*inv(L')
!
            DO 20 K = 1, N
!
!              Update the lower triangle of A(k:n,k:n)
!
               AKK = A( K, K )
               BKK = B( K, K )
               AKK = AKK / BKK**2
               A( K, K ) = AKK
               IF( K.LT.N ) THEN
                  CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
                  CT = -HALF*AKK
                  CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
                  CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, &
                              B( K+1, K ), 1, A( K+1, K+1 ), LDA )
                  CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
                  CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, &
                              B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
               END IF
   20       CONTINUE
         END IF
      ELSE
         IF( UPPER ) THEN
!
!           Compute U*A*U'
!
            DO 30 K = 1, N
!
!              Update the upper triangle of A(1:k,1:k)
!
               AKK = A( K, K )
               BKK = B( K, K )
               CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, &
                           LDB, A( 1, K ), 1 )
               CT = HALF*AKK
               CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
               CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, &
                           A, LDA )
               CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
               CALL DSCAL( K-1, BKK, A( 1, K ), 1 )
               A( K, K ) = AKK*BKK**2
   30       CONTINUE
         ELSE
!
!           Compute L'*A*L
!
            DO 40 K = 1, N
!
!              Update the lower triangle of A(1:k,1:k)
!
               AKK = A( K, K )
               BKK = B( K, K )
               CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, &
                           A( K, 1 ), LDA )
               CT = HALF*AKK
               CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
               CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), &
                           LDB, A, LDA )
               CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
               CALL DSCAL( K-1, BKK, A( K, 1 ), LDA )
               A( K, K ) = AKK*BKK**2
   40       CONTINUE
         END IF
      END IF
      RETURN
!
!     End of DSYGS2
!
      END
      SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, ITYPE, LDA, LDB, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYGST reduces a real symmetric-definite generalized eigenproblem
!  to standard form.
!
!  If ITYPE = 1, the problem is A*x = lambda*B*x,
!  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
!
!  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
!  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
!
!  B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
!          = 2 or 3: compute U*A*U**T or L**T*A*L.
!
!  UPLO    (input) CHARACTER
!          = 'U':  Upper triangle of A is stored and B is factored as
!                  U**T*U;
!          = 'L':  Lower triangle of A is stored and B is factored as
!                  L*L**T.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the transformed matrix, stored in the
!          same format as A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
!          The triangular factor from the Cholesky factorization of B,
!          as returned by DPOTRF.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, HALF
      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            K, KB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYGST', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 )
!
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
!
!        Use unblocked code
!
         CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
      ELSE
!
!        Use blocked code
!
         IF( ITYPE.EQ.1 ) THEN
            IF( UPPER ) THEN
!
!              Compute inv(U')*A*inv(U)
!
               DO 10 K = 1, N, NB
                  KB = MIN( N-K+1, NB )
!
!                 Update the upper triangle of A(k:n,k:n)
!
                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, &
                               B( K, K ), LDB, INFO )
                  IF( K+KB.LE.N ) THEN
                     CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', &
                                 KB, N-K-KB+1, ONE, B( K, K ), LDB, &
                                 A( K, K+KB ), LDA )
                     CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, &
                                 A( K, K ), LDA, B( K, K+KB ), LDB, ONE, &
                                 A( K, K+KB ), LDA )
                     CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, &
                                  A( K, K+KB ), LDA, B( K, K+KB ), LDB, &
                                  ONE, A( K+KB, K+KB ), LDA )
                     CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, &
                                 A( K, K ), LDA, B( K, K+KB ), LDB, ONE, &
                                 A( K, K+KB ), LDA )
                     CALL DTRSM( 'Right', UPLO, 'No transpose', &
                                 'Non-unit', KB, N-K-KB+1, ONE, &
                                 B( K+KB, K+KB ), LDB, A( K, K+KB ), &
                                 LDA )
                  END IF
   10          CONTINUE
            ELSE
!
!              Compute inv(L)*A*inv(L')
!
               DO 20 K = 1, N, NB
                  KB = MIN( N-K+1, NB )
!
!                 Update the lower triangle of A(k:n,k:n)
!
                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, &
                               B( K, K ), LDB, INFO )
                  IF( K+KB.LE.N ) THEN
                     CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', &
                                 N-K-KB+1, KB, ONE, B( K, K ), LDB, &
                                 A( K+KB, K ), LDA )
                     CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, &
                                 A( K, K ), LDA, B( K+KB, K ), LDB, ONE, &
                                 A( K+KB, K ), LDA )
                     CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, &
                                  -ONE, A( K+KB, K ), LDA, B( K+KB, K ), &
                                  LDB, ONE, A( K+KB, K+KB ), LDA )
                     CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, &
                                 A( K, K ), LDA, B( K+KB, K ), LDB, ONE, &
                                 A( K+KB, K ), LDA )
                     CALL DTRSM( 'Left', UPLO, 'No transpose', &
                                 'Non-unit', N-K-KB+1, KB, ONE, &
                                 B( K+KB, K+KB ), LDB, A( K+KB, K ), &
                                 LDA )
                  END IF
   20          CONTINUE
            END IF
         ELSE
            IF( UPPER ) THEN
!
!              Compute U*A*U'
!
               DO 30 K = 1, N, NB
                  KB = MIN( N-K+1, NB )
!
!                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
!
                  CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', &
                              K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
                  CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), &
                              LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
                  CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, &
                               A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, &
                               LDA )
                  CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), &
                              LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
                  CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', &
                              K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), &
                              LDA )
                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, &
                               B( K, K ), LDB, INFO )
   30          CONTINUE
            ELSE
!
!              Compute L'*A*L
!
               DO 40 K = 1, N, NB
                  KB = MIN( N-K+1, NB )
!
!                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
!
                  CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', &
                              KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
                  CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), &
                              LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
                  CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, &
                               A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, &
                               LDA )
                  CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), &
                              LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
                  CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, &
                              K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
                  CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, &
                               B( K, K ), LDB, INFO )
   40          CONTINUE
            END IF
         END IF
      END IF
      RETURN
!
!     End of DSYGST
!
      END
      SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, &
                        LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, ITYPE, LDA, LDB, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYGV computes all the eigenvalues, and optionally, the eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.
!  Here A and B are assumed to be symmetric and B is also
!  positive definite.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          matrix Z of eigenvectors.  The eigenvectors are normalized
!          as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
!          or the lower triangle (if UPLO='L') of A, including the
!          diagonal, is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the symmetric positive definite matrix B.
!          If UPLO = 'U', the leading N-by-N upper triangular part of B
!          contains the upper triangular part of the matrix B.
!          If UPLO = 'L', the leading N-by-N lower triangular part of B
!          contains the lower triangular part of the matrix B.
!
!          On exit, if INFO <= N, the part of B containing the matrix is
!          overwritten by the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,3*N-1).
!          For optimal efficiency, LWORK >= (NB+2)*N,
!          where NB is the blocksize for DSYTRD returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPOTRF or DSYEV returned an error code:
!             <= N:  if INFO = i, DSYEV failed to converge;
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero;
!             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER, WANTZ
      CHARACTER          TRANS
      INTEGER            LWKOPT, NB, NEIG
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 )
!
      INFO = 0
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
         LWKOPT = ( NB+2 )*N
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYGV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a Cholesky factorization of B.
!
      CALL DPOTRF( UPLO, N, B, LDB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
      CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         NEIG = N
         IF( INFO.GT.0 ) &
            NEIG = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, &
                        B, LDB, A, LDA )
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, &
                        B, LDB, A, LDA )
         END IF
      END IF
!
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DSYGV
!
      END
      SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, &
                         LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
!  B are assumed to be symmetric and B is also positive definite.
!  If eigenvectors are desired, it uses a divide and conquer algorithm.
!
!  The divide and conquer algorithm makes very mild assumptions about
!  floating point arithmetic. It will work on machines with a guard
!  digit in add/subtract, or on those binary machines without guard
!  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!  Cray-2. It could conceivably fail on hexadecimal or decimal machines
!  without guard digits, but we know of none.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangles of A and B are stored;
!          = 'L':  Lower triangles of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          matrix Z of eigenvectors.  The eigenvectors are normalized
!          as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
!          or the lower triangle (if UPLO='L') of A, including the
!          diagonal, is destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, the symmetric matrix B.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of B contains the
!          upper triangular part of the matrix B.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of B contains
!          the lower triangular part of the matrix B.
!
!          On exit, if INFO <= N, the part of B containing the matrix is
!          overwritten by the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If N <= 1,               LWORK >= 1.
!          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
!          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If N <= 1,                LIWORK >= 1.
!          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
!          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPOTRF or DSYEVD returned an error code:
!             <= N:  if INFO = i, DSYEVD failed to converge;
!                    i off-diagonal elements of an intermediate
!                    tridiagonal form did not converge to zero;
!             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER, WANTZ
      CHARACTER          TRANS
      INTEGER            LIOPT, LIWMIN, LOPT, LWMIN, NEIG
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      WANTZ = LSAME( JOBZ, 'V' )
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      INFO = 0
      IF( N.LE.1 ) THEN
         LIWMIN = 1
         LWMIN = 1
         LOPT = LWMIN
         LIOPT = LIWMIN
      ELSE
         IF( WANTZ ) THEN
            LIWMIN = 3 + 5*N
            LWMIN = 1 + 6*N + 2*N**2
         ELSE
            LIWMIN = 1
            LWMIN = 2*N + 1
         END IF
         LOPT = LWMIN
         LIOPT = LIWMIN
      END IF
      IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -11
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LOPT
         IWORK( 1 ) = LIOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYGVD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Form a Cholesky factorization of B.
!
      CALL DPOTRF( UPLO, N, B, LDB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
      CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, &
                   INFO )
      LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) )
      LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         NEIG = N
         IF( INFO.GT.0 ) &
            NEIG = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, &
                        B, LDB, A, LDA )
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, &
                        B, LDB, A, LDA )
         END IF
      END IF
!
      WORK( 1 ) = LOPT
      IWORK( 1 ) = LIOPT
!
      RETURN
!
!     End of DSYGVD
!
      END
      SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, &
                         VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, &
                         LWORK, IWORK, IFAIL, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
      DOUBLE PRECISION   ABSTOL, VL, VU
!     ..
!     .. Array Arguments ..
      INTEGER            IFAIL( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), &
                         Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYGVX computes selected eigenvalues, and optionally, eigenvectors
!  of a real generalized symmetric-definite eigenproblem, of the form
!  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A
!  and B are assumed to be symmetric and B is also positive definite.
!  Eigenvalues and eigenvectors can be selected by specifying either a
!  range of values or a range of indices for the desired eigenvalues.
!
!  Arguments
!  =========
!
!  ITYPE   (input) INTEGER
!          Specifies the problem type to be solved:
!          = 1:  A*x = (lambda)*B*x
!          = 2:  A*B*x = (lambda)*x
!          = 3:  B*A*x = (lambda)*x
!
!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
!  RANGE   (input) CHARACTER*1
!          = 'A': all eigenvalues will be found.
!          = 'V': all eigenvalues in the half-open interval (VL,VU]
!                 will be found.
!          = 'I': the IL-th through IU-th eigenvalues will be found.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A and B are stored;
!          = 'L':  Lower triangle of A and B are stored.
!
!  N       (input) INTEGER
!          The order of the matrix pencil (A,B).  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!
!          On exit, the lower triangle (if UPLO='L') or the upper
!          triangle (if UPLO='U') of A, including the diagonal, is
!          destroyed.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
!          On entry, the symmetric matrix B.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of B contains the
!          upper triangular part of the matrix B.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of B contains
!          the lower triangular part of the matrix B.
!
!          On exit, if INFO <= N, the part of B containing the matrix is
!          overwritten by the triangular factor U or L from the Cholesky
!          factorization B = U**T*U or B = L*L**T.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION
!  VU      (input) DOUBLE PRECISION
!          If RANGE='V', the lower and upper bounds of the interval to
!          be searched for eigenvalues. VL < VU.
!          Not referenced if RANGE = 'A' or 'I'.
!
!  IL      (input) INTEGER
!  IU      (input) INTEGER
!          If RANGE='I', the indices (in ascending order) of the
!          smallest and largest eigenvalues to be returned.
!          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
!          Not referenced if RANGE = 'A' or 'V'.
!
!  ABSTOL  (input) DOUBLE PRECISION
!          The absolute error tolerance for the eigenvalues.
!          An approximate eigenvalue is accepted as converged
!          when it is determined to lie in an interval [a,b]
!          of width less than or equal to
!
!                  ABSTOL + EPS *   max( |a|,|b| ) ,
!
!          where EPS is the machine precision.  If ABSTOL is less than
!          or equal to zero, then  EPS*|T|  will be used in its place,
!          where |T| is the 1-norm of the tridiagonal matrix obtained
!          by reducing A to tridiagonal form.
!
!          Eigenvalues will be computed most accurately when ABSTOL is
!          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!          If this routine returns with INFO>0, indicating that some
!          eigenvectors did not converge, try setting ABSTOL to
!          2*DLAMCH('S').
!
!  M       (output) INTEGER
!          The total number of eigenvalues found.  0 <= M <= N.
!          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
!
!  W       (output) DOUBLE PRECISION array, dimension (N)
!          On normal exit, the first M elements contain the selected
!          eigenvalues in ascending order.
!
!  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
!          If JOBZ = 'N', then Z is not referenced.
!          If JOBZ = 'V', then if INFO = 0, the first M columns of Z
!          contain the orthonormal eigenvectors of the matrix A
!          corresponding to the selected eigenvalues, with the i-th
!          column of Z holding the eigenvector associated with W(i).
!          The eigenvectors are normalized as follows:
!          if ITYPE = 1 or 2, Z**T*B*Z = I;
!          if ITYPE = 3, Z**T*inv(B)*Z = I.
!
!          If an eigenvector fails to converge, then that column of Z
!          contains the latest approximation to the eigenvector, and the
!          index of the eigenvector is returned in IFAIL.
!          Note: the user must ensure that at least max(1,M) columns are
!          supplied in the array Z; if RANGE = 'V', the exact value of M
!          is not known in advance and an upper bound must be used.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z.  LDZ >= 1, and if
!          JOBZ = 'V', LDZ >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of the array WORK.  LWORK >= max(1,8*N).
!          For optimal efficiency, LWORK >= (NB+3)*N,
!          where NB is the blocksize for DSYTRD returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (5*N)
!
!  IFAIL   (output) INTEGER array, dimension (N)
!          If JOBZ = 'V', then if INFO = 0, the first M elements of
!          IFAIL are zero.  If INFO > 0, then IFAIL contains the
!          indices of the eigenvectors that failed to converge.
!          If JOBZ = 'N', then IFAIL is not referenced.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  DPOTRF or DSYEVX returned an error code:
!             <= N:  if INFO = i, DSYEVX failed to converge;
!                    i eigenvectors failed to converge.  Their indices
!                    are stored in array IFAIL.
!             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!                    minor of order i of B is not positive definite.
!                    The factorization of B could not be completed and
!                    no eigenvalues or eigenvectors were computed.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
      CHARACTER          TRANS
      INTEGER            LOPT, LWKOPT, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      UPPER = LSAME( UPLO, 'U' )
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
      LQUERY = ( LWORK.EQ.-1 )
!
      INFO = 0
      IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( VALEIG .AND. N.GT.0 ) THEN
         IF( VU.LE.VL ) &
            INFO = -11
      ELSE IF( INDEIG .AND. IL.LT.1 ) THEN
         INFO = -12
      ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
         INFO = -13
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -18
      ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN
         INFO = -20
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
         LWKOPT = ( NB+3 )*N
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYGVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      M = 0
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
!     Form a Cholesky factorization of B.
!
      CALL DPOTRF( UPLO, N, B, LDB, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = N + INFO
         RETURN
      END IF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
      CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, &
                   M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
      LOPT = WORK( 1 )
!
      IF( WANTZ ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         IF( INFO.GT.0 ) &
            M = INFO - 1
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
!
            IF( UPPER ) THEN
               TRANS = 'N'
            ELSE
               TRANS = 'T'
            END IF
!
            CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, &
                        LDB, Z, LDZ )
!
         ELSE IF( ITYPE.EQ.3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U'*y
!
            IF( UPPER ) THEN
               TRANS = 'T'
            ELSE
               TRANS = 'N'
            END IF
!
            CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, &
                        LDB, Z, LDZ )
         END IF
      END IF
!
!     Set WORK(1) to optimal workspace size.
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DSYGVX
!
      END
      SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, &
                         X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYRFS improves the computed solution to a system of linear
!  equations when the coefficient matrix is symmetric indefinite, and
!  provides error bounds and backward error estimates for the solution.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of A contains the upper triangular part
!          of the matrix A, and the strictly lower triangular part of A
!          is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of A contains the lower triangular part of
!          the matrix A, and the strictly upper triangular part of A is
!          not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
!          The factored form of the matrix A.  AF contains the block
!          diagonal matrix D and the multipliers used to obtain the
!          factor U or L from the factorization A = U*D*U**T or
!          A = L*D*L**T as computed by DSYTRF.
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSYTRF.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          On entry, the solution matrix X, as computed by DSYTRS.
!          On exit, the improved solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Internal Parameters
!  ===================
!
!  ITMAX is the maximum number of steps of iterative refinement.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            COUNT, I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DSYMV, DSYTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 140 J = 1, NRHS
!
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
!
!        Loop until stopping criterion is satisfied.
!
!        Compute residual R = B - A * X
!
         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE, &
                     WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 30 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   30    CONTINUE
!
!        Compute abs(A)*abs(X) + abs(B).
!
         IF( UPPER ) THEN
            DO 50 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               DO 40 I = 1, K - 1
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   40          CONTINUE
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
   50       CONTINUE
         ELSE
            DO 70 K = 1, N
               S = ZERO
               XK = ABS( X( K, J ) )
               WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
               DO 60 I = K + 1, N
                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
   60          CONTINUE
               WORK( K ) = WORK( K ) + S
   70       CONTINUE
         END IF
         S = ZERO
         DO 80 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
   80    CONTINUE
         BERR( J ) = S
!
!        Test stopping criterion. Continue iterating if
!           1) The residual BERR(J) is larger than machine epsilon, and
!           2) BERR(J) decreased by at least a factor of 2 during the
!              last iteration, and
!           3) At most ITMAX iterations tried.
!
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. &
             COUNT.LE.ITMAX ) THEN
!
!           Update solution and try again.
!
            CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, &
                         INFO )
            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(A))*
!           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(A) is the inverse of A
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(A)*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(A) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
!
         DO 90 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
   90    CONTINUE
!
         KASE = 0
  100    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(A').
!
               CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, &
                            INFO )
               DO 110 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  110          CONTINUE
            ELSE IF( KASE.EQ.2 ) THEN
!
!              Multiply by inv(A)*diag(W).
!
               DO 120 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  120          CONTINUE
               CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, &
                            INFO )
            END IF
            GO TO 100
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 130 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  130    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  140 CONTINUE
!
      RETURN
!
!     End of DSYRFS
!
      END
      SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, &
                        LWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYSV computes the solution to a real system of linear equations
!     A * X = B,
!  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!  matrices.
!
!  The diagonal pivoting method is used to factor A as
!     A = U * D * U**T,  if UPLO = 'U', or
!     A = L * D * L**T,  if UPLO = 'L',
!  where U (or L) is a product of permutation and unit upper (lower)
!  triangular matrices, and D is symmetric and block diagonal with
!  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then
!  used to solve the system of equations A * X = B.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, if INFO = 0, the block diagonal matrix D and the
!          multipliers used to obtain the factor U or L from the
!          factorization A = U*D*U**T or A = L*D*L**T as computed by
!          DSYTRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D, as
!          determined by DSYTRF.  If IPIV(k) > 0, then rows and columns
!          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
!          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
!          then rows and columns k-1 and -IPIV(k) were interchanged and
!          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
!          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
!          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
!          diagonal block.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the N-by-NRHS right hand side matrix B.
!          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of WORK.  LWORK >= 1, and for best performance
!          LWORK >= N*NB, where NB is the optimal blocksize for
!          DSYTRF.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
!               has been completed, but the block diagonal matrix D is
!               exactly singular, so the solution could not be computed.
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LWKOPT, NB
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSYTRF, DSYTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
         LWKOPT = N*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYSV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Compute the factorization A = U*D*U' or A = L*D*L'.
!
      CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
      IF( INFO.EQ.0 ) THEN
!
!        Solve the system A*X = B, overwriting B with X.
!
         CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
      END IF
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DSYSV
!
      END
      SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, &
                         LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, &
                         IWORK, INFO )
!
!  -- LAPACK driver routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          FACT, UPLO
      INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * ), IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ), &
                         BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYSVX uses the diagonal pivoting factorization to compute the
!  solution to a real system of linear equations A * X = B,
!  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!  matrices.
!
!  Error bounds on the solution and a condition estimate are also
!  provided.
!
!  Description
!  ===========
!
!  The following steps are performed:
!
!  1. If FACT = 'N', the diagonal pivoting method is used to factor A.
!     The form of the factorization is
!        A = U * D * U**T,  if UPLO = 'U', or
!        A = L * D * L**T,  if UPLO = 'L',
!     where U (or L) is a product of permutation and unit upper (lower)
!     triangular matrices, and D is symmetric and block diagonal with
!     1-by-1 and 2-by-2 diagonal blocks.
!
!  2. If some D(i,i)=0, so that D is exactly singular, then the routine
!     returns with INFO = i. Otherwise, the factored form of A is used
!     to estimate the condition number of the matrix A.  If the
!     reciprocal of the condition number is less than machine precision,
!     INFO = N+1 is returned as a warning, but the routine still goes on
!     to solve for X and compute error bounds as described below.
!
!  3. The system of equations is solved for X using the factored form
!     of A.
!
!  4. Iterative refinement is applied to improve the computed solution
!     matrix and calculate error bounds and backward error estimates
!     for it.
!
!  Arguments
!  =========
!
!  FACT    (input) CHARACTER*1
!          Specifies whether or not the factored form of A has been
!          supplied on entry.
!          = 'F':  On entry, AF and IPIV contain the factored form of
!                  A.  AF and IPIV will not be modified.
!          = 'N':  The matrix A will be copied to AF and factored.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The number of linear equations, i.e., the order of the
!          matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of A contains the upper triangular part
!          of the matrix A, and the strictly lower triangular part of A
!          is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of A contains the lower triangular part of
!          the matrix A, and the strictly upper triangular part of A is
!          not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
!          If FACT = 'F', then AF is an input argument and on entry
!          contains the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L from the factorization
!          A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.
!
!          If FACT = 'N', then AF is an output argument and on exit
!          returns the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L from the factorization
!          A = U*D*U**T or A = L*D*L**T.
!
!  LDAF    (input) INTEGER
!          The leading dimension of the array AF.  LDAF >= max(1,N).
!
!  IPIV    (input or output) INTEGER array, dimension (N)
!          If FACT = 'F', then IPIV is an input argument and on entry
!          contains details of the interchanges and the block structure
!          of D, as determined by DSYTRF.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!          If FACT = 'N', then IPIV is an output argument and on exit
!          contains details of the interchanges and the block structure
!          of D, as determined by DSYTRF.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The N-by-NRHS right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The estimate of the reciprocal condition number of the matrix
!          A.  If RCOND is less than the machine precision (in
!          particular, if RCOND = 0), the matrix is singular to working
!          precision.  This condition is indicated by a return code of
!          INFO > 0.
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of WORK.  LWORK >= 3*N, and for best performance
!          LWORK >= N*NB, where NB is the optimal blocksize for
!          DSYTRF.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, and i is
!                <= N:  D(i,i) is exactly zero.  The factorization
!                       has been completed but the factor D is exactly
!                       singular, so the solution and error bounds could
!                       not be computed. RCOND = 0 is returned.
!                = N+1: D is nonsingular, but RCOND is less than machine
!                       precision, meaning that the matrix is singular
!                       to working precision.  Nevertheless, the
!                       solution and error bounds are computed because
!                       there are a number of situations where the
!                       computed solution can be more accurate than the
!                       value of RCOND would suggest.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, NOFACT
      INTEGER            LWKOPT, NB
      DOUBLE PRECISION   ANORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) &
                THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
         INFO = -18
      END IF
!
      IF( INFO.EQ.0 ) THEN
         NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
         LWKOPT = N*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYSVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
      IF( NOFACT ) THEN
!
!        Compute the factorization A = U*D*U' or A = L*D*L'.
!
         CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
         CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
!
!        Return if INFO is non-zero.
!
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) &
               RCOND = ZERO
            RETURN
         END IF
      END IF
!
!     Compute the norm of the matrix A.
!
      ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK )
!
!     Compute the reciprocal of the condition number of A.
!
      CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK, &
                   INFO )
!
!     Set INFO = N+1 if the matrix is singular to working precision.
!
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) &
         INFO = N + 1
!
!     Compute the solution vectors X.
!
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
!
!     Use iterative refinement to improve the computed solutions and
!     compute error bounds and backward error estimates for them.
!
      CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, &
                   LDX, FERR, BERR, WORK, IWORK, INFO )
!
      RETURN
!
!     End of DSYSVX
!
      END
      SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAU( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
!  form T by an orthogonal similarity transformation: Q' * A * Q = T.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n-by-n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n-by-n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!          of A are overwritten by the corresponding elements of the
!          tridiagonal matrix T, and the elements above the first
!          superdiagonal, with the array TAU, represent the orthogonal
!          matrix Q as a product of elementary reflectors; if UPLO
!          = 'L', the diagonal and first subdiagonal of A are over-
!          written by the corresponding elements of the tridiagonal
!          matrix T, and the elements below the first subdiagonal, with
!          the array TAU, represent the orthogonal matrix Q as a product
!          of elementary reflectors. See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T:
!          D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          The off-diagonal elements of the tridiagonal matrix T:
!          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  If UPLO = 'U', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(n-1) . . . H(2) H(1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
!  A(1:i-1,i+1), and tau in TAU(i).
!
!  If UPLO = 'L', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(1) H(2) . . . H(n-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
!  and tau in TAU(i).
!
!  The contents of A on exit are illustrated by the following examples
!  with n = 5:
!
!  if UPLO = 'U':                       if UPLO = 'L':
!
!    (  d   e   v2  v3  v4 )              (  d                  )
!    (      d   e   v3  v4 )              (  e   d              )
!    (          d   e   v4 )              (  v1  e   d          )
!    (              d   e  )              (  v1  v2  e   d      )
!    (                  d  )              (  v1  v2  v3  e   d  )
!
!  where d and e denote diagonal and off-diagonal elements of T, and vi
!  denotes an element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, HALF
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, &
                         HALF = 1.0D0 / 2.0D0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
      DOUBLE PRECISION   ALPHA, TAUI
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTD2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Reduce the upper triangle of A
!
         DO 10 I = N - 1, 1, -1
!
!           Generate elementary reflector H(i) = I - tau * v * v'
!           to annihilate A(1:i-1,i+1)
!
            CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
            E( I ) = A( I, I+1 )
!
            IF( TAUI.NE.ZERO ) THEN
!
!              Apply H(i) from both sides to A(1:i,1:i)
!
               A( I, I+1 ) = ONE
!
!              Compute  x := tau * A * v  storing x in TAU(1:i)
!
               CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, &
                           TAU, 1 )
!
!              Compute  w := x - 1/2 * tau * (x'*v) * v
!
               ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
               CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w' - w * v'
!
               CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, &
                           LDA )
!
               A( I, I+1 ) = E( I )
            END IF
            D( I+1 ) = A( I+1, I+1 )
            TAU( I ) = TAUI
   10    CONTINUE
         D( 1 ) = A( 1, 1 )
      ELSE
!
!        Reduce the lower triangle of A
!
         DO 20 I = 1, N - 1
!
!           Generate elementary reflector H(i) = I - tau * v * v'
!           to annihilate A(i+2:n,i)
!
            CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, &
                         TAUI )
            E( I ) = A( I+1, I )
!
            IF( TAUI.NE.ZERO ) THEN
!
!              Apply H(i) from both sides to A(i+1:n,i+1:n)
!
               A( I+1, I ) = ONE
!
!              Compute  x := tau * A * v  storing y in TAU(i:n-1)
!
               CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, &
                           A( I+1, I ), 1, ZERO, TAU( I ), 1 )
!
!              Compute  w := x - 1/2 * tau * (x'*v) * v
!
               ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), &
                       1 )
               CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
!
!              Apply the transformation as a rank-2 update:
!                 A := A - v * w' - w * v'
!
               CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, &
                           A( I+1, I+1 ), LDA )
!
               A( I+1, I ) = E( I )
            END IF
            D( I ) = A( I, I )
            TAU( I ) = TAUI
   20    CONTINUE
         D( N ) = A( N, N )
      END IF
!
      RETURN
!
!     End of DSYTD2
!
      END
      SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTF2 computes the factorization of a real symmetric matrix A using
!  the Bunch-Kaufman diagonal pivoting method:
!
!     A = U*D*U'  or  A = L*D*L'
!
!  where U (or L) is a product of permutation and unit upper (lower)
!  triangular matrices, U' is the transpose of U, and D is symmetric and
!  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the upper or lower triangular part of the
!          symmetric matrix A is stored:
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          n-by-n upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n-by-n lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L (see below for further details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
!               has been completed, but the block diagonal matrix D is
!               exactly singular, and division by zero will occur if it
!               is used to solve a system of equations.
!
!  Further Details
!  ===============
!
!  1-96 - Based on modifications by J. Lewis, Boeing Computer Services
!         Company
!
!  If UPLO = 'U', then A = U*D*U', where
!     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    v    0   )   k-s
!     U(k) =  (   0    I    0   )   s
!             (   0    0    I   )   n-k
!                k-s   s   n-k
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!
!  If UPLO = 'L', then A = L*D*L', where
!     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    0     0   )  k-1
!     L(k) =  (   0    I     0   )  s
!             (   0    v     I   )  n-k-s+1
!                k-1   s  n-k-s+1
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   EIGHT, SEVTEN
      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, &
                         ROWMAX, T, WK, WKM1, WKP1
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      EXTERNAL           LSAME, IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DSWAP, DSYR, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTF2', -INFO )
         RETURN
      END IF
!
!     Initialize ALPHA for use in choosing pivot block size.
!
      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
!
      IF( UPPER ) THEN
!
!        Factorize A as U*D*U' using the upper triangle of A
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2
!
         K = N
   10    CONTINUE
!
!        If K < 1, exit from loop
!
         IF( K.LT.1 ) &
            GO TO 70
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( A( K, K ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.GT.1 ) THEN
            IMAX = IDAMAX( K-1, A( 1, K ), 1 )
            COLMAX = ABS( A( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
               ROWMAX = ABS( A( IMAX, JMAX ) )
               IF( IMAX.GT.1 ) THEN
                  JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
               ELSE
!
!                 interchange rows and columns K-1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K - KSTEP + 1
            IF( KP.NE.KK ) THEN
!
!              Interchange rows and columns KK and KP in the leading
!              submatrix A(1:k,1:k)
!
               CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
               CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), &
                           LDA )
               T = A( KK, KK )
               A( KK, KK ) = A( KP, KP )
               A( KP, KP ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = A( K-1, K )
                  A( K-1, K ) = A( KP, K )
                  A( KP, K ) = T
               END IF
            END IF
!
!           Update the leading submatrix
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column k now holds
!
!              W(k) = U(k)*D(k)
!
!              where U(k) is the k-th column of U
!
!              Perform a rank-1 update of A(1:k-1,1:k-1) as
!
!              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
!
               R1 = ONE / A( K, K )
               CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
!
!              Store U(k) in column k
!
               CALL DSCAL( K-1, R1, A( 1, K ), 1 )
            ELSE
!
!              2-by-2 pivot block D(k): columns k and k-1 now hold
!
!              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
!
!              where U(k) and U(k-1) are the k-th and (k-1)-th columns
!              of U
!
!              Perform a rank-2 update of A(1:k-2,1:k-2) as
!
!              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
!                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
!
               IF( K.GT.2 ) THEN
!
                  D12 = A( K-1, K )
                  D22 = A( K-1, K-1 ) / D12
                  D11 = A( K, K ) / D12
                  T = ONE / ( D11*D22-ONE )
                  D12 = T / D12
!
                  DO 30 J = K - 2, 1, -1
                     WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
                     WK = D12*( D22*A( J, K )-A( J, K-1 ) )
                     DO 20 I = J, 1, -1
                        A( I, J ) = A( I, J ) - A( I, K )*WK - &
                                    A( I, K-1 )*WKM1
   20                CONTINUE
                     A( J, K ) = WK
                     A( J, K-1 ) = WKM1
   30             CONTINUE
!
               END IF
!
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K-1 ) = -KP
         END IF
!
!        Decrease K and return to the start of the main loop
!
         K = K - KSTEP
         GO TO 10
!
      ELSE
!
!        Factorize A as L*D*L' using the lower triangle of A
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2
!
         K = 1
   40    CONTINUE
!
!        If K > N, exit from loop
!
         IF( K.GT.N ) &
            GO TO 70
         KSTEP = 1
!
!        Determine rows and columns to be interchanged and whether
!        a 1-by-1 or 2-by-2 pivot block will be used
!
         ABSAKK = ABS( A( K, K ) )
!
!        IMAX is the row-index of the largest off-diagonal element in
!        column K, and COLMAX is its absolute value
!
         IF( K.LT.N ) THEN
            IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
            COLMAX = ABS( A( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
!
         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
!
!           Column K is zero: set INFO and continue
!
            IF( INFO.EQ.0 ) &
               INFO = K
            KP = K
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
!
!              no interchange, use 1-by-1 pivot block
!
               KP = K
            ELSE
!
!              JMAX is the column-index of the largest off-diagonal
!              element in row IMAX, and ROWMAX is its absolute value
!
               JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
               ROWMAX = ABS( A( IMAX, JMAX ) )
               IF( IMAX.LT.N ) THEN
                  JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
               END IF
!
               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
!
!                 no interchange, use 1-by-1 pivot block
!
                  KP = K
               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
!
!                 interchange rows and columns K and IMAX, use 1-by-1
!                 pivot block
!
                  KP = IMAX
               ELSE
!
!                 interchange rows and columns K+1 and IMAX, use 2-by-2
!                 pivot block
!
                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
!
            KK = K + KSTEP - 1
            IF( KP.NE.KK ) THEN
!
!              Interchange rows and columns KK and KP in the trailing
!              submatrix A(k:n,k:n)
!
               IF( KP.LT.N ) &
                  CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
               CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), &
                           LDA )
               T = A( KK, KK )
               A( KK, KK ) = A( KP, KP )
               A( KP, KP ) = T
               IF( KSTEP.EQ.2 ) THEN
                  T = A( K+1, K )
                  A( K+1, K ) = A( KP, K )
                  A( KP, K ) = T
               END IF
            END IF
!
!           Update the trailing submatrix
!
            IF( KSTEP.EQ.1 ) THEN
!
!              1-by-1 pivot block D(k): column k now holds
!
!              W(k) = L(k)*D(k)
!
!              where L(k) is the k-th column of L
!
               IF( K.LT.N ) THEN
!
!                 Perform a rank-1 update of A(k+1:n,k+1:n) as
!
!                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
!
                  D11 = ONE / A( K, K )
                  CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, &
                             A( K+1, K+1 ), LDA )
!
!                 Store L(k) in column K
!
                  CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
               END IF
            ELSE
!
!              2-by-2 pivot block D(k)
!
               IF( K.LT.N-1 ) THEN
!
!                 Perform a rank-2 update of A(k+2:n,k+2:n) as
!
!                 A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
!
!                 where L(k) and L(k+1) are the k-th and (k+1)-th
!                 columns of L
!
                  D21 = A( K+1, K )
                  D11 = A( K+1, K+1 ) / D21
                  D22 = A( K, K ) / D21
                  T = ONE / ( D11*D22-ONE )
                  D21 = T / D21
!
                  DO 60 J = K + 2, N
!
                     WK = D21*( D11*A( J, K )-A( J, K+1 ) )
                     WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
!
                     DO 50 I = J, N
                        A( I, J ) = A( I, J ) - A( I, K )*WK - &
                                    A( I, K+1 )*WKP1
   50                CONTINUE
!
                     A( J, K ) = WK
                     A( J, K+1 ) = WKP1
!
   60             CONTINUE
               END IF
            END IF
         END IF
!
!        Store details of the interchanges in IPIV
!
         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K+1 ) = -KP
         END IF
!
!        Increase K and return to the start of the main loop
!
         K = K + KSTEP
         GO TO 40
!
      END IF
!
   70 CONTINUE
!
      RETURN
!
!     End of DSYTF2
!
      END
      SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAU( * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTRD reduces a real symmetric matrix A to real symmetric
!  tridiagonal form T by an orthogonal similarity transformation:
!  Q**T * A * Q = T.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!          of A are overwritten by the corresponding elements of the
!          tridiagonal matrix T, and the elements above the first
!          superdiagonal, with the array TAU, represent the orthogonal
!          matrix Q as a product of elementary reflectors; if UPLO
!          = 'L', the diagonal and first subdiagonal of A are over-
!          written by the corresponding elements of the tridiagonal
!          matrix T, and the elements below the first subdiagonal, with
!          the array TAU, represent the orthogonal matrix Q as a product
!          of elementary reflectors. See Further Details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  D       (output) DOUBLE PRECISION array, dimension (N)
!          The diagonal elements of the tridiagonal matrix T:
!          D(i) = A(i,i).
!
!  E       (output) DOUBLE PRECISION array, dimension (N-1)
!          The off-diagonal elements of the tridiagonal matrix T:
!          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
!
!  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
!          The scalar factors of the elementary reflectors (see Further
!          Details).
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= 1.
!          For optimum performance LWORK >= N*NB, where NB is the
!          optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  If UPLO = 'U', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(n-1) . . . H(2) H(1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
!  A(1:i-1,i+1), and tau in TAU(i).
!
!  If UPLO = 'L', the matrix Q is represented as a product of elementary
!  reflectors
!
!     Q = H(1) H(2) . . . H(n-1).
!
!  Each H(i) has the form
!
!     H(i) = I - tau * v * v'
!
!  where tau is a real scalar, and v is a real vector with
!  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
!  and tau in TAU(i).
!
!  The contents of A on exit are illustrated by the following examples
!  with n = 5:
!
!  if UPLO = 'U':                       if UPLO = 'L':
!
!    (  d   e   v2  v3  v4 )              (  d                  )
!    (      d   e   v3  v4 )              (  e   d              )
!    (          d   e   v4 )              (  v1  e   d          )
!    (              d   e  )              (  v1  v2  e   d      )
!    (                  d  )              (  v1  v2  v3  e   d  )
!
!  where d and e denote diagonal and off-diagonal elements of T, and vi
!  denotes an element of the vector defining H(i).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER
      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, &
                         NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLATRD, DSYR2K, DSYTD2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
         INFO = -9
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.
!
         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
         LWKOPT = N*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NX = N
      IWS = 1
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
!
!        Determine when to cross over from blocked to unblocked code
!        (last block is always handled by unblocked code).
!
         NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
         IF( NX.LT.N ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  determine the
!              minimum value of NB, and reduce NB or force use of
!              unblocked code by setting NX = N.
!
               NB = MAX( LWORK / LDWORK, 1 )
               NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
               IF( NB.LT.NBMIN ) &
                  NX = N
            END IF
         ELSE
            NX = N
         END IF
      ELSE
         NB = 1
      END IF
!
      IF( UPPER ) THEN
!
!        Reduce the upper triangle of A.
!        Columns 1:kk are handled by the unblocked method.
!
         KK = N - ( ( N-NX+NB-1 ) / NB )*NB
         DO 20 I = N - NB + 1, KK + 1, -NB
!
!           Reduce columns i:i+nb-1 to tridiagonal form and form the
!           matrix W which is needed to update the unreduced part of
!           the matrix
!
            CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, &
                         LDWORK )
!
!           Update the unreduced submatrix A(1:i-1,1:i-1), using an
!           update of the form:  A := A - V*W' - W*V'
!
            CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), &
                         LDA, WORK, LDWORK, ONE, A, LDA )
!
!           Copy superdiagonal elements back into A, and diagonal
!           elements into D
!
            DO 10 J = I, I + NB - 1
               A( J-1, J ) = E( J-1 )
               D( J ) = A( J, J )
   10       CONTINUE
   20    CONTINUE
!
!        Use unblocked code to reduce the last or only block
!
         CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
      ELSE
!
!        Reduce the lower triangle of A
!
         DO 40 I = 1, N - NX, NB
!
!           Reduce columns i:i+nb-1 to tridiagonal form and form the
!           matrix W which is needed to update the unreduced part of
!           the matrix
!
            CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), &
                         TAU( I ), WORK, LDWORK )
!
!           Update the unreduced submatrix A(i+ib:n,i+ib:n), using
!           an update of the form:  A := A - V*W' - W*V'
!
            CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, &
                         A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, &
                         A( I+NB, I+NB ), LDA )
!
!           Copy subdiagonal elements back into A, and diagonal
!           elements into D
!
            DO 30 J = I, I + NB - 1
               A( J+1, J ) = E( J )
               D( J ) = A( J, J )
   30       CONTINUE
   40    CONTINUE
!
!        Use unblocked code to reduce the last or only block
!
         CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), &
                      TAU( I ), IINFO )
      END IF
!
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DSYTRD
!
      END
      SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LWORK, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTRF computes the factorization of a real symmetric matrix A using
!  the Bunch-Kaufman diagonal pivoting method.  The form of the
!  factorization is
!
!     A = U*D*U**T  or  A = L*D*L**T
!
!  where U (or L) is a product of permutation and unit upper (lower)
!  triangular matrices, and D is symmetric and block diagonal with
!  1-by-1 and 2-by-2 diagonal blocks.
!
!  This is the blocked version of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!          N-by-N upper triangular part of A contains the upper
!          triangular part of the matrix A, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of A contains the lower
!          triangular part of the matrix A, and the strictly upper
!          triangular part of A is not referenced.
!
!          On exit, the block diagonal matrix D and the multipliers used
!          to obtain the factor U or L (see below for further details).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (output) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D.
!          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!          interchanged and D(k,k) is a 1-by-1 diagonal block.
!          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
!          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
!          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
!          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
!          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The length of WORK.  LWORK >=1.  For best performance
!          LWORK >= N*NB, where NB is the block size returned by ILAENV.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization
!                has been completed, but the block diagonal matrix D is
!                exactly singular, and division by zero will occur if it
!                is used to solve a system of equations.
!
!  Further Details
!  ===============
!
!  If UPLO = 'U', then A = U*D*U', where
!     U = P(n)*U(n)* ... *P(k)U(k)* ...,
!  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
!  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    v    0   )   k-s
!     U(k) =  (   0    I    0   )   s
!             (   0    0    I   )   n-k
!                k-s   s   n-k
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
!  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
!  and A(k,k), and v overwrites A(1:k-2,k-1:k).
!
!  If UPLO = 'L', then A = L*D*L', where
!     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
!  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
!  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
!  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
!  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
!  that if the diagonal block D(k) is of order s (s = 1 or 2), then
!
!             (   I    0     0   )  k-1
!     L(k) =  (   0    I     0   )  s
!             (   0    v     I   )  n-k-s+1
!                k-1   s  n-k-s+1
!
!  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
!  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
!  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            LQUERY, UPPER
      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASYF, DSYTF2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size
!
         NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
         LWKOPT = N*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = LDWORK*NB
         IF( LWORK.LT.IWS ) THEN
            NB = MAX( LWORK / LDWORK, 1 )
            NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = 1
      END IF
      IF( NB.LT.NBMIN ) &
         NB = N
!
      IF( UPPER ) THEN
!
!        Factorize A as U*D*U' using the upper triangle of A
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        KB, where KB is the number of columns factorized by DLASYF;
!        KB is either NB or NB-1, or K for the last block
!
         K = N
   10    CONTINUE
!
!        If K < 1, exit from loop
!
         IF( K.LT.1 ) &
            GO TO 40
!
         IF( K.GT.NB ) THEN
!
!           Factorize columns k-kb+1:k of A and use blocked code to
!           update columns 1:k-kb
!
            CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, &
                         IINFO )
         ELSE
!
!           Use unblocked code to factorize columns 1:k of A
!
            CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
            KB = K
         END IF
!
!        Set INFO on the first occurrence of a zero pivot
!
         IF( INFO.EQ.0 .AND. IINFO.GT.0 ) &
            INFO = IINFO
!
!        Decrease K and return to the start of the main loop
!
         K = K - KB
         GO TO 10
!
      ELSE
!
!        Factorize A as L*D*L' using the lower triangle of A
!
!        K is the main loop index, increasing from 1 to N in steps of
!        KB, where KB is the number of columns factorized by DLASYF;
!        KB is either NB or NB-1, or N-K+1 for the last block
!
         K = 1
   20    CONTINUE
!
!        If K > N, exit from loop
!
         IF( K.GT.N ) &
            GO TO 40
!
         IF( K.LE.N-NB ) THEN
!
!           Factorize columns k:k+kb-1 of A and use blocked code to
!           update columns k+kb:n
!
            CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), &
                         WORK, LDWORK, IINFO )
         ELSE
!
!           Use unblocked code to factorize columns k:n of A
!
            CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
            KB = N - K + 1
         END IF
!
!        Set INFO on the first occurrence of a zero pivot
!
         IF( INFO.EQ.0 .AND. IINFO.GT.0 ) &
            INFO = IINFO + K - 1
!
!        Adjust IPIV
!
         DO 30 J = K, K + KB - 1
            IF( IPIV( J ).GT.0 ) THEN
               IPIV( J ) = IPIV( J ) + K - 1
            ELSE
               IPIV( J ) = IPIV( J ) - K + 1
            END IF
   30    CONTINUE
!
!        Increase K and return to the start of the main loop
!
         K = K + KB
         GO TO 20
!
      END IF
!
   40 CONTINUE
      WORK( 1 ) = LWKOPT
      RETURN
!
!     End of DSYTRF
!
      END
      SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTRI computes the inverse of a real symmetric indefinite matrix
!  A using the factorization A = U*D*U**T or A = L*D*L**T computed by
!  DSYTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the block diagonal matrix D and the multipliers
!          used to obtain the factor U or L as computed by DSYTRF.
!
!          On exit, if INFO = 0, the (symmetric) inverse of the original
!          matrix.  If UPLO = 'U', the upper triangular part of the
!          inverse is formed and the part of A below the diagonal is not
!          referenced; if UPLO = 'L' the lower triangular part of the
!          inverse is formed and the part of A above the diagonal is
!          not referenced.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSYTRF.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
!               inverse could not be computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            K, KP, KSTEP
      DOUBLE PRECISION   AK, AKKP1, AKP1, D, T, TEMP
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DSWAP, DSYMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRI', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check that the diagonal matrix D is nonsingular.
!
      IF( UPPER ) THEN
!
!        Upper triangular storage: examine D from bottom to top
!
         DO 10 INFO = N, 1, -1
            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) &
               RETURN
   10    CONTINUE
      ELSE
!
!        Lower triangular storage: examine D from top to bottom.
!
         DO 20 INFO = 1, N
            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) &
               RETURN
   20    CONTINUE
      END IF
      INFO = 0
!
      IF( UPPER ) THEN
!
!        Compute inv(A) from the factorization A = U*D*U'.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
   30    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 40
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Invert the diagonal block.
!
            A( K, K ) = ONE / A( K, K )
!
!           Compute column K of the inverse.
!
            IF( K.GT.1 ) THEN
               CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &
                           A( 1, K ), 1 )
               A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), &
                           1 )
            END IF
            KSTEP = 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Invert the diagonal block.
!
            T = ABS( A( K, K+1 ) )
            AK = A( K, K ) / T
            AKP1 = A( K+1, K+1 ) / T
            AKKP1 = A( K, K+1 ) / T
            D = T*( AK*AKP1-ONE )
            A( K, K ) = AKP1 / D
            A( K+1, K+1 ) = AK / D
            A( K, K+1 ) = -AKKP1 / D
!
!           Compute columns K and K+1 of the inverse.
!
            IF( K.GT.1 ) THEN
               CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &
                           A( 1, K ), 1 )
               A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), &
                           1 )
               A( K, K+1 ) = A( K, K+1 ) - &
                             DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
               CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, &
                           A( 1, K+1 ), 1 )
               A( K+1, K+1 ) = A( K+1, K+1 ) - &
                               DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
            END IF
            KSTEP = 2
         END IF
!
         KP = ABS( IPIV( K ) )
         IF( KP.NE.K ) THEN
!
!           Interchange rows and columns K and KP in the leading
!           submatrix A(1:k+1,1:k+1)
!
            CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
            CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
            TEMP = A( K, K )
            A( K, K ) = A( KP, KP )
            A( KP, KP ) = TEMP
            IF( KSTEP.EQ.2 ) THEN
               TEMP = A( K, K+1 )
               A( K, K+1 ) = A( KP, K+1 )
               A( KP, K+1 ) = TEMP
            END IF
         END IF
!
         K = K + KSTEP
         GO TO 30
   40    CONTINUE
!
      ELSE
!
!        Compute inv(A) from the factorization A = L*D*L'.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = N
   50    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 60
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Invert the diagonal block.
!
            A( K, K ) = ONE / A( K, K )
!
!           Compute column K of the inverse.
!
            IF( K.LT.N ) THEN
               CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &
                           ZERO, A( K+1, K ), 1 )
               A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), &
                           1 )
            END IF
            KSTEP = 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Invert the diagonal block.
!
            T = ABS( A( K, K-1 ) )
            AK = A( K-1, K-1 ) / T
            AKP1 = A( K, K ) / T
            AKKP1 = A( K, K-1 ) / T
            D = T*( AK*AKP1-ONE )
            A( K-1, K-1 ) = AKP1 / D
            A( K, K ) = AK / D
            A( K, K-1 ) = -AKKP1 / D
!
!           Compute columns K-1 and K of the inverse.
!
            IF( K.LT.N ) THEN
               CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &
                           ZERO, A( K+1, K ), 1 )
               A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), &
                           1 )
               A( K, K-1 ) = A( K, K-1 ) - &
                             DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), &
                             1 )
               CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, &
                           ZERO, A( K+1, K-1 ), 1 )
               A( K-1, K-1 ) = A( K-1, K-1 ) - &
                               DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
            END IF
            KSTEP = 2
         END IF
!
         KP = ABS( IPIV( K ) )
         IF( KP.NE.K ) THEN
!
!           Interchange rows and columns K and KP in the trailing
!           submatrix A(k-1:n,k-1:n)
!
            IF( KP.LT.N ) &
               CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
            CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
            TEMP = A( K, K )
            A( K, K ) = A( KP, KP )
            A( KP, KP ) = TEMP
            IF( KSTEP.EQ.2 ) THEN
               TEMP = A( K, K-1 )
               A( K, K-1 ) = A( KP, K-1 )
               A( KP, K-1 ) = TEMP
            END IF
         END IF
!
         K = K - KSTEP
         GO TO 50
   60    CONTINUE
      END IF
!
      RETURN
!
!     End of DSYTRI
!
      END
      SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYTRS solves a system of linear equations A*X = B with a real
!  symmetric matrix A using the factorization A = U*D*U**T or
!  A = L*D*L**T computed by DSYTRF.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the details of the factorization are stored
!          as an upper or lower triangular matrix.
!          = 'U':  Upper triangular, form is A = U*D*U**T;
!          = 'L':  Lower triangular, form is A = L*D*L**T.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The block diagonal matrix D and the multipliers used to
!          obtain the factor U or L as computed by DSYTRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          Details of the interchanges and the block structure of D
!          as determined by DSYTRF.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, K, KP
      DOUBLE PRECISION   AK, AKM1, AKM1K, BK, BKM1, DENOM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSYTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) &
         RETURN
!
      IF( UPPER ) THEN
!
!        Solve A*X = B, where A = U*D*U'.
!
!        First solve U*D*X = B, overwriting B with X.
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = N
   10    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 30
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(U(K)), where U(K) is the transformation
!           stored in column K of A.
!
            CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, &
                       B( 1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
            K = K - 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Interchange rows K-1 and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K-1 ) &
               CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(U(K)), where U(K) is the transformation
!           stored in columns K-1 and K of A.
!
            CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, &
                       B( 1, 1 ), LDB )
            CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), &
                       LDB, B( 1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            AKM1K = A( K-1, K )
            AKM1 = A( K-1, K-1 ) / AKM1K
            AK = A( K, K ) / AKM1K
            DENOM = AKM1*AK - ONE
            DO 20 J = 1, NRHS
               BKM1 = B( K-1, J ) / AKM1K
               BK = B( K, J ) / AKM1K
               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
   20       CONTINUE
            K = K - 2
         END IF
!
         GO TO 10
   30    CONTINUE
!
!        Next solve U'*X = B, overwriting B with X.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
   40    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 50
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Multiply by inv(U'(K)), where U(K) is the transformation
!           stored in column K of A.
!
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), &
                        1, ONE, B( K, 1 ), LDB )
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K + 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
!           stored in columns K and K+1 of A.
!
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), &
                        1, ONE, B( K, 1 ), LDB )
            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, &
                        A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
!
!           Interchange rows K and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K + 2
         END IF
!
         GO TO 40
   50    CONTINUE
!
      ELSE
!
!        Solve A*X = B, where A = L*D*L'.
!
!        First solve L*D*X = B, overwriting B with X.
!
!        K is the main loop index, increasing from 1 to N in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = 1
   60    CONTINUE
!
!        If K > N, exit from loop.
!
         IF( K.GT.N ) &
            GO TO 80
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(L(K)), where L(K) is the transformation
!           stored in column K of A.
!
            IF( K.LT.N ) &
               CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), &
                          LDB, B( K+1, 1 ), LDB )
!
!           Multiply by the inverse of the diagonal block.
!
            CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
            K = K + 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Interchange rows K+1 and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K+1 ) &
               CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
!
!           Multiply by inv(L(K)), where L(K) is the transformation
!           stored in columns K and K+1 of A.
!
            IF( K.LT.N-1 ) THEN
               CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), &
                          LDB, B( K+2, 1 ), LDB )
               CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, &
                          B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
            END IF
!
!           Multiply by the inverse of the diagonal block.
!
            AKM1K = A( K+1, K )
            AKM1 = A( K, K ) / AKM1K
            AK = A( K+1, K+1 ) / AKM1K
            DENOM = AKM1*AK - ONE
            DO 70 J = 1, NRHS
               BKM1 = B( K, J ) / AKM1K
               BK = B( K+1, J ) / AKM1K
               B( K, J ) = ( AK*BKM1-BK ) / DENOM
               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
   70       CONTINUE
            K = K + 2
         END IF
!
         GO TO 60
   80    CONTINUE
!
!        Next solve L'*X = B, overwriting B with X.
!
!        K is the main loop index, decreasing from N to 1 in steps of
!        1 or 2, depending on the size of the diagonal blocks.
!
         K = N
   90    CONTINUE
!
!        If K < 1, exit from loop.
!
         IF( K.LT.1 ) &
            GO TO 100
!
         IF( IPIV( K ).GT.0 ) THEN
!
!           1 x 1 diagonal block
!
!           Multiply by inv(L'(K)), where L(K) is the transformation
!           stored in column K of A.
!
            IF( K.LT.N ) &
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
!
!           Interchange rows K and IPIV(K).
!
            KP = IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K - 1
         ELSE
!
!           2 x 2 diagonal block
!
!           Multiply by inv(L'(K-1)), where L(K-1) is the transformation
!           stored in columns K-1 and K of A.
!
            IF( K.LT.N ) THEN
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), &
                           LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), &
                           LDB )
            END IF
!
!           Interchange rows K and -IPIV(K).
!
            KP = -IPIV( K )
            IF( KP.NE.K ) &
               CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K - 2
         END IF
!
         GO TO 90
  100    CONTINUE
      END IF
!
      RETURN
!
!     End of DSYTRS
!
      END
      SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            INFO, KD, LDAB, N
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTBCON estimates the reciprocal of the condition number of a
!  triangular band matrix A, in either the 1-norm or the infinity-norm.
!
!  The norm of A is computed and an estimate is obtained for
!  norm(inv(A)), then the reciprocal of the condition number is
!  computed as
!     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals or subdiagonals of the
!          triangular band matrix A.  KD >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangular band matrix A, stored in the
!          first kd+1 rows of the array. The j-th column of A is stored
!          in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!          If DIAG = 'U', the diagonal elements of A are not referenced
!          and are assumed to be 1.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, ONENRM, UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTB
      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATBS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( KD.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTBCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
!
      RCOND = ZERO
      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
!
!     Compute the norm of the triangular matrix A.
!
      ANORM = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
!
!     Continue only if ANORM > 0.
!
      IF( ANORM.GT.ZERO ) THEN
!
!        Estimate the norm of the inverse of A.
!
         AINVNM = ZERO
         NORMIN = 'N'
         IF( ONENRM ) THEN
            KASE1 = 1
         ELSE
            KASE1 = 2
         END IF
         KASE = 0
   10    CONTINUE
         CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.KASE1 ) THEN
!
!              Multiply by inv(A).
!
               CALL DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD, &
                            AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
            ELSE
!
!              Multiply by inv(A').
!
               CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB, &
                            LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
            END IF
            NORMIN = 'Y'
!
!           Multiply by 1/SCALE if doing so will not cause overflow.
!
            IF( SCALE.NE.ONE ) THEN
               IX = IDAMAX( N, WORK, 1 )
               XNORM = ABS( WORK( IX ) )
               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) &
                  GO TO 20
               CALL DRSCL( N, SCALE, WORK, 1 )
            END IF
            GO TO 10
         END IF
!
!        Compute the estimate of the reciprocal condition number.
!
         IF( AINVNM.NE.ZERO ) &
            RCOND = ( ONE / ANORM ) / AINVNM
      END IF
!
   20 CONTINUE
      RETURN
!
!     End of DTBCON
!
      END
      SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, &
                         LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, KD, LDAB, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * ), BERR( * ), &
                         FERR( * ), WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DTBRFS provides error bounds and backward error estimates for the
!  solution to a system of linear equations with a triangular band
!  coefficient matrix.
!
!  The solution matrix X must be computed by DTBTRS or some other
!  means before entering this routine.  DTBRFS does not do iterative
!  refinement because doing so cannot improve the backward error.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals or subdiagonals of the
!          triangular band matrix A.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangular band matrix A, stored in the
!          first kd+1 rows of the array. The j-th column of A is stored
!          in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!          If DIAG = 'U', the diagonal elements of A are not referenced
!          and are assumed to be 1.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          The solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      CHARACTER          TRANST
      INTEGER            I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DTBMV, DTBSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( KD.LT.0 ) THEN
         INFO = -5
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTBRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = KD + 2
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 250 J = 1, NRHS
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A or A', depending on TRANS.
!
         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ), &
                     1 )
         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 20 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   20    CONTINUE
!
         IF( NOTRAN ) THEN
!
!           Compute abs(A)*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               IF( NOUNIT ) THEN
                  DO 40 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 30 I = MAX( 1, K-KD ), K
                        WORK( I ) = WORK( I ) + &
                                    ABS( AB( KD+1+I-K, K ) )*XK
   30                CONTINUE
   40             CONTINUE
               ELSE
                  DO 60 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 50 I = MAX( 1, K-KD ), K - 1
                        WORK( I ) = WORK( I ) + &
                                    ABS( AB( KD+1+I-K, K ) )*XK
   50                CONTINUE
                     WORK( K ) = WORK( K ) + XK
   60             CONTINUE
               END IF
            ELSE
               IF( NOUNIT ) THEN
                  DO 80 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 70 I = K, MIN( N, K+KD )
                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
   70                CONTINUE
   80             CONTINUE
               ELSE
                  DO 100 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 90 I = K + 1, MIN( N, K+KD )
                        WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
   90                CONTINUE
                     WORK( K ) = WORK( K ) + XK
  100             CONTINUE
               END IF
            END IF
         ELSE
!
!           Compute abs(A')*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               IF( NOUNIT ) THEN
                  DO 120 K = 1, N
                     S = ZERO
                     DO 110 I = MAX( 1, K-KD ), K
                        S = S + ABS( AB( KD+1+I-K, K ) )* &
                            ABS( X( I, J ) )
  110                CONTINUE
                     WORK( K ) = WORK( K ) + S
  120             CONTINUE
               ELSE
                  DO 140 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 130 I = MAX( 1, K-KD ), K - 1
                        S = S + ABS( AB( KD+1+I-K, K ) )* &
                            ABS( X( I, J ) )
  130                CONTINUE
                     WORK( K ) = WORK( K ) + S
  140             CONTINUE
               END IF
            ELSE
               IF( NOUNIT ) THEN
                  DO 160 K = 1, N
                     S = ZERO
                     DO 150 I = K, MIN( N, K+KD )
                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
  150                CONTINUE
                     WORK( K ) = WORK( K ) + S
  160             CONTINUE
               ELSE
                  DO 180 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 170 I = K + 1, MIN( N, K+KD )
                        S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
  170                CONTINUE
                     WORK( K ) = WORK( K ) + S
  180             CONTINUE
               END IF
            END IF
         END IF
         S = ZERO
         DO 190 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
  190    CONTINUE
         BERR( J ) = S
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 200 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
  200    CONTINUE
!
         KASE = 0
  210    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)').
!
               CALL DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB, &
                           WORK( N+1 ), 1 )
               DO 220 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  220          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 230 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  230          CONTINUE
               CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, &
                           WORK( N+1 ), 1 )
            END IF
            GO TO 210
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 240 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  240    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  250 CONTINUE
!
      RETURN
!
!     End of DTBRFS
!
      END
      SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, &
                         LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTBTRS solves a triangular system of the form
!
!     A * X = B  or  A**T * X = B,
!
!  where A is a triangular band matrix of order N, and B is an
!  N-by NRHS matrix.  A check is made to verify that A is nonsingular.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  KD      (input) INTEGER
!          The number of superdiagonals or subdiagonals of the
!          triangular band matrix A.  KD >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)
!          The upper or lower triangular band matrix A, stored in the
!          first kd+1 rows of AB.  The j-th column of A is stored
!          in the j-th column of the array AB as follows:
!          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!          If DIAG = 'U', the diagonal elements of A are not referenced
!          and are assumed to be 1.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= KD+1.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, if INFO = 0, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the i-th diagonal element of A is zero,
!                indicating that the matrix is singular and the
!                solutions X have not been computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTBSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOUNIT = LSAME( DIAG, 'N' )
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. &
               LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( KD.LT.0 ) THEN
         INFO = -5
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTBTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check for singularity.
!
      IF( NOUNIT ) THEN
         IF( UPPER ) THEN
            DO 10 INFO = 1, N
               IF( AB( KD+1, INFO ).EQ.ZERO ) &
                  RETURN
   10       CONTINUE
         ELSE
            DO 20 INFO = 1, N
               IF( AB( 1, INFO ).EQ.ZERO ) &
                  RETURN
   20       CONTINUE
         END IF
      END IF
      INFO = 0
!
!     Solve A * X = B  or  A' * X = B.
!
      DO 30 J = 1, NRHS
         CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
   30 CONTINUE
!
      RETURN
!
!     End of DTBTRS
!
      END
      SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, &
                         LDVL, VR, LDVR, MM, M, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          HOWMNY, SIDE
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, M, MM, N
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), VL( LDVL, * ), &
                         VR( LDVR, * ), WORK( * )
!     ..
!
!
!  Purpose
!  =======
!
!  DTGEVC computes some or all of the right and/or left generalized
!  eigenvectors of a pair of real upper triangular matrices (A,B).
!
!  The right generalized eigenvector x and the left generalized
!  eigenvector y of (A,B) corresponding to a generalized eigenvalue
!  w are defined by:
!
!          (A - wB) * x = 0  and  y**H * (A - wB) = 0
!
!  where y**H denotes the conjugate tranpose of y.
!
!  If an eigenvalue w is determined by zero diagonal elements of both A
!  and B, a unit vector is returned as the corresponding eigenvector.
!
!  If all eigenvectors are requested, the routine may either return
!  the matrices X and/or Y of right or left eigenvectors of (A,B), or
!  the products Z*X and/or Q*Y, where Z and Q are input orthogonal
!  matrices.  If (A,B) was obtained from the generalized real-Schur
!  factorization of an original pair of matrices
!     (A0,B0) = (Q*A*Z**H,Q*B*Z**H),
!  then Z*X and Q*Y are the matrices of right or left eigenvectors of
!  A.
!
!  A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal
!  blocks.  Corresponding to each 2-by-2 diagonal block is a complex
!  conjugate pair of eigenvalues and eigenvectors; only one
!  eigenvector of the pair is computed, namely the one corresponding
!  to the eigenvalue with positive imaginary part.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'R': compute right eigenvectors only;
!          = 'L': compute left eigenvectors only;
!          = 'B': compute both right and left eigenvectors.
!
!  HOWMNY  (input) CHARACTER*1
!          = 'A': compute all right and/or left eigenvectors;
!          = 'B': compute all right and/or left eigenvectors, and
!                 backtransform them using the input matrices supplied
!                 in VR and/or VL;
!          = 'S': compute selected right and/or left eigenvectors,
!                 specified by the logical array SELECT.
!
!  SELECT  (input) LOGICAL array, dimension (N)
!          If HOWMNY='S', SELECT specifies the eigenvectors to be
!          computed.
!          If HOWMNY='A' or 'B', SELECT is not referenced.
!          To select the real eigenvector corresponding to the real
!          eigenvalue w(j), SELECT(j) must be set to .TRUE.  To select
!          the complex eigenvector corresponding to a complex conjugate
!          pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must
!          be set to .TRUE..
!
!  N       (input) INTEGER
!          The order of the matrices A and B.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The upper quasi-triangular matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of array A.  LDA >= max(1, N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
!          The upper triangular matrix B.  If A has a 2-by-2 diagonal
!          block, then the corresponding 2-by-2 block of B must be
!          diagonal with positive elements.
!
!  LDB     (input) INTEGER
!          The leading dimension of array B.  LDB >= max(1,N).
!
!  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
!          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!          contain an N-by-N matrix Q (usually the orthogonal matrix Q
!          of left Schur vectors returned by DHGEQZ).
!          On exit, if SIDE = 'L' or 'B', VL contains:
!          if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B);
!          if HOWMNY = 'B', the matrix Q*Y;
!          if HOWMNY = 'S', the left eigenvectors of (A,B) specified by
!                      SELECT, stored consecutively in the columns of
!                      VL, in the same order as their eigenvalues.
!          If SIDE = 'R', VL is not referenced.
!
!          A complex eigenvector corresponding to a complex eigenvalue
!          is stored in two consecutive columns, the first holding the
!          real part, and the second the imaginary part.
!
!  LDVL    (input) INTEGER
!          The leading dimension of array VL.
!          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
!
!  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
!          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!          contain an N-by-N matrix Q (usually the orthogonal matrix Z
!          of right Schur vectors returned by DHGEQZ).
!          On exit, if SIDE = 'R' or 'B', VR contains:
!          if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B);
!          if HOWMNY = 'B', the matrix Z*X;
!          if HOWMNY = 'S', the right eigenvectors of (A,B) specified by
!                      SELECT, stored consecutively in the columns of
!                      VR, in the same order as their eigenvalues.
!          If SIDE = 'L', VR is not referenced.
!
!          A complex eigenvector corresponding to a complex eigenvalue
!          is stored in two consecutive columns, the first holding the
!          real part and the second the imaginary part.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.
!          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
!
!  MM      (input) INTEGER
!          The number of columns in the arrays VL and/or VR. MM >= M.
!
!  M       (output) INTEGER
!          The number of columns in the arrays VL and/or VR actually
!          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
!          is set to N.  Each selected real eigenvector occupies one
!          column and each selected complex eigenvector occupies two
!          columns.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit.
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex
!                eigenvalue.
!
!  Further Details
!  ===============
!
!  Allocation of workspace:
!  ---------- -- ---------
!
!     WORK( j ) = 1-norm of j-th column of A, above the diagonal
!     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
!     WORK( 2*N+1:3*N ) = real part of eigenvector
!     WORK( 3*N+1:4*N ) = imaginary part of eigenvector
!     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
!     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
!
!  Rowwise vs. columnwise solution methods:
!  ------- --  ---------- -------- -------
!
!  Finding a generalized eigenvector consists basically of solving the
!  singular triangular system
!
!   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)
!
!  Consider finding the i-th right eigenvector (assume all eigenvalues
!  are real). The equation to be solved is:
!       n                   i
!  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1
!      k=j                 k=j
!
!  where  C = (A - w B)  (The components v(i+1:n) are 0.)
!
!  The "rowwise" method is:
!
!  (1)  v(i) := 1
!  for j = i-1,. . .,1:
!                          i
!      (2) compute  s = - sum C(j,k) v(k)   and
!                        k=j+1
!
!      (3) v(j) := s / C(j,j)
!
!  Step 2 is sometimes called the "dot product" step, since it is an
!  inner product between the j-th row and the portion of the eigenvector
!  that has been computed so far.
!
!  The "columnwise" method consists basically in doing the sums
!  for all the rows in parallel.  As each v(j) is computed, the
!  contribution of v(j) times the j-th column of C is added to the
!  partial sums.  Since FORTRAN arrays are stored columnwise, this has
!  the advantage that at each step, the elements of C that are accessed
!  are adjacent to one another, whereas with the rowwise method, the
!  elements accessed at a step are spaced LDA (and LDB) words apart.
!
!  When finding left eigenvectors, the matrix in question is the
!  transpose of the one in storage, so the rowwise method then
!  actually accesses columns of A and B at each step, and so is the
!  preferred method.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, SAFETY
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, &
                         SAFETY = 1.0D+2 )
!     ..
!     .. Local Scalars ..
      LOGICAL            COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK, &
                         ILBBAD, ILCOMP, ILCPLX, LSA, LSB
      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE, &
                         J, JA, JC, JE, JR, JW, NA, NW
      DOUBLE PRECISION   ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI, &
                         BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A, &
                         CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA, &
                         CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE, &
                         SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX, &
                         XSCALE
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   BDIAG( 2 ), SUM( 2, 2 ), SUMA( 2, 2 ), &
                         SUMB( 2, 2 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DLACPY, DLAG2, DLALN2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and Test the input parameters
!
      IF( LSAME( HOWMNY, 'A' ) ) THEN
         IHWMNY = 1
         ILALL = .TRUE.
         ILBACK = .FALSE.
      ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
         IHWMNY = 2
         ILALL = .FALSE.
         ILBACK = .FALSE.
      ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN
         IHWMNY = 3
         ILALL = .TRUE.
         ILBACK = .TRUE.
      ELSE
         IHWMNY = -1
         ILALL = .TRUE.
      END IF
!
      IF( LSAME( SIDE, 'R' ) ) THEN
         ISIDE = 1
         COMPL = .FALSE.
         COMPR = .TRUE.
      ELSE IF( LSAME( SIDE, 'L' ) ) THEN
         ISIDE = 2
         COMPL = .TRUE.
         COMPR = .FALSE.
      ELSE IF( LSAME( SIDE, 'B' ) ) THEN
         ISIDE = 3
         COMPL = .TRUE.
         COMPR = .TRUE.
      ELSE
         ISIDE = -1
      END IF
!
      INFO = 0
      IF( ISIDE.LT.0 ) THEN
         INFO = -1
      ELSE IF( IHWMNY.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGEVC', -INFO )
         RETURN
      END IF
!
!     Count the number of eigenvectors to be computed
!
      IF( .NOT.ILALL ) THEN
         IM = 0
         ILCPLX = .FALSE.
         DO 10 J = 1, N
            IF( ILCPLX ) THEN
               ILCPLX = .FALSE.
               GO TO 10
            END IF
            IF( J.LT.N ) THEN
               IF( A( J+1, J ).NE.ZERO ) &
                  ILCPLX = .TRUE.
            END IF
            IF( ILCPLX ) THEN
               IF( SELECT( J ) .OR. SELECT( J+1 ) ) &
                  IM = IM + 2
            ELSE
               IF( SELECT( J ) ) &
                  IM = IM + 1
            END IF
   10    CONTINUE
      ELSE
         IM = N
      END IF
!
!     Check 2-by-2 diagonal blocks of A, B
!
      ILABAD = .FALSE.
      ILBBAD = .FALSE.
      DO 20 J = 1, N - 1
         IF( A( J+1, J ).NE.ZERO ) THEN
            IF( B( J, J ).EQ.ZERO .OR. B( J+1, J+1 ).EQ.ZERO .OR. &
                B( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
            IF( J.LT.N-1 ) THEN
               IF( A( J+2, J+1 ).NE.ZERO ) &
                  ILABAD = .TRUE.
            END IF
         END IF
   20 CONTINUE
!
      IF( ILABAD ) THEN
         INFO = -5
      ELSE IF( ILBBAD ) THEN
         INFO = -7
      ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
         INFO = -10
      ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
         INFO = -12
      ELSE IF( MM.LT.IM ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGEVC', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      M = IM
      IF( N.EQ.0 ) &
         RETURN
!
!     Machine Constants
!
      SAFMIN = DLAMCH( 'Safe minimum' )
      BIG = ONE / SAFMIN
      CALL DLABAD( SAFMIN, BIG )
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
      SMALL = SAFMIN*N / ULP
      BIG = ONE / SMALL
      BIGNUM = ONE / ( SAFMIN*N )
!
!     Compute the 1-norm of each column of the strictly upper triangular
!     part (i.e., excluding all elements belonging to the diagonal
!     blocks) of A and B to check for possible overflow in the
!     triangular solver.
!
      ANORM = ABS( A( 1, 1 ) )
      IF( N.GT.1 ) &
         ANORM = ANORM + ABS( A( 2, 1 ) )
      BNORM = ABS( B( 1, 1 ) )
      WORK( 1 ) = ZERO
      WORK( N+1 ) = ZERO
!
      DO 50 J = 2, N
         TEMP = ZERO
         TEMP2 = ZERO
         IF( A( J, J-1 ).EQ.ZERO ) THEN
            IEND = J - 1
         ELSE
            IEND = J - 2
         END IF
         DO 30 I = 1, IEND
            TEMP = TEMP + ABS( A( I, J ) )
            TEMP2 = TEMP2 + ABS( B( I, J ) )
   30    CONTINUE
         WORK( J ) = TEMP
         WORK( N+J ) = TEMP2
         DO 40 I = IEND + 1, MIN( J+1, N )
            TEMP = TEMP + ABS( A( I, J ) )
            TEMP2 = TEMP2 + ABS( B( I, J ) )
   40    CONTINUE
         ANORM = MAX( ANORM, TEMP )
         BNORM = MAX( BNORM, TEMP2 )
   50 CONTINUE
!
      ASCALE = ONE / MAX( ANORM, SAFMIN )
      BSCALE = ONE / MAX( BNORM, SAFMIN )
!
!     Left eigenvectors
!
      IF( COMPL ) THEN
         IEIG = 0
!
!        Main loop over eigenvalues
!
         ILCPLX = .FALSE.
         DO 220 JE = 1, N
!
!           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
!           (b) this would be the second of a complex pair.
!           Check for complex eigenvalue, so as to be sure of which
!           entry(-ies) of SELECT to look at.
!
            IF( ILCPLX ) THEN
               ILCPLX = .FALSE.
               GO TO 220
            END IF
            NW = 1
            IF( JE.LT.N ) THEN
               IF( A( JE+1, JE ).NE.ZERO ) THEN
                  ILCPLX = .TRUE.
                  NW = 2
               END IF
            END IF
            IF( ILALL ) THEN
               ILCOMP = .TRUE.
            ELSE IF( ILCPLX ) THEN
               ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
            ELSE
               ILCOMP = SELECT( JE )
            END IF
            IF( .NOT.ILCOMP ) &
               GO TO 220
!
!           Decide if (a) singular pencil, (b) real eigenvalue, or
!           (c) complex eigenvalue.
!
            IF( .NOT.ILCPLX ) THEN
               IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. &
                   ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
!
!                 Singular matrix pencil -- return unit eigenvector
!
                  IEIG = IEIG + 1
                  DO 60 JR = 1, N
                     VL( JR, IEIG ) = ZERO
   60             CONTINUE
                  VL( IEIG, IEIG ) = ONE
                  GO TO 220
               END IF
            END IF
!
!           Clear vector
!
            DO 70 JR = 1, NW*N
               WORK( 2*N+JR ) = ZERO
   70       CONTINUE
!                                                 T
!           Compute coefficients in  ( a A - b B )  y = 0
!              a  is  ACOEF
!              b  is  BCOEFR + i*BCOEFI
!
            IF( .NOT.ILCPLX ) THEN
!
!              Real eigenvalue
!
               TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, &
                      ABS( B( JE, JE ) )*BSCALE, SAFMIN )
               SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
               SBETA = ( TEMP*B( JE, JE ) )*BSCALE
               ACOEF = SBETA*ASCALE
               BCOEFR = SALFAR*BSCALE
               BCOEFI = ZERO
!
!              Scale to avoid underflow
!
               SCALE = ONE
               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
               LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. &
                     SMALL
               IF( LSA ) &
                  SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
               IF( LSB ) &
                  SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* &
                          MIN( BNORM, BIG ) )
               IF( LSA .OR. LSB ) THEN
                  SCALE = MIN( SCALE, ONE / &
                          ( SAFMIN*MAX( ONE, ABS( ACOEF ), &
                          ABS( BCOEFR ) ) ) )
                  IF( LSA ) THEN
                     ACOEF = ASCALE*( SCALE*SBETA )
                  ELSE
                     ACOEF = SCALE*ACOEF
                  END IF
                  IF( LSB ) THEN
                     BCOEFR = BSCALE*( SCALE*SALFAR )
                  ELSE
                     BCOEFR = SCALE*BCOEFR
                  END IF
               END IF
               ACOEFA = ABS( ACOEF )
               BCOEFA = ABS( BCOEFR )
!
!              First component is 1
!
               WORK( 2*N+JE ) = ONE
               XMAX = ONE
            ELSE
!
!              Complex eigenvalue
!
               CALL DLAG2( A( JE, JE ), LDA, B( JE, JE ), LDB, &
                           SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, &
                           BCOEFI )
               BCOEFI = -BCOEFI
               IF( BCOEFI.EQ.ZERO ) THEN
                  INFO = JE
                  RETURN
               END IF
!
!              Scale to avoid over/underflow
!
               ACOEFA = ABS( ACOEF )
               BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
               SCALE = ONE
               IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) &
                  SCALE = ( SAFMIN / ULP ) / ACOEFA
               IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) &
                  SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
               IF( SAFMIN*ACOEFA.GT.ASCALE ) &
                  SCALE = ASCALE / ( SAFMIN*ACOEFA )
               IF( SAFMIN*BCOEFA.GT.BSCALE ) &
                  SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
               IF( SCALE.NE.ONE ) THEN
                  ACOEF = SCALE*ACOEF
                  ACOEFA = ABS( ACOEF )
                  BCOEFR = SCALE*BCOEFR
                  BCOEFI = SCALE*BCOEFI
                  BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
               END IF
!
!              Compute first two components of eigenvector
!
               TEMP = ACOEF*A( JE+1, JE )
               TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
               TEMP2I = -BCOEFI*B( JE, JE )
               IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
                  WORK( 2*N+JE ) = ONE
                  WORK( 3*N+JE ) = ZERO
                  WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
                  WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
               ELSE
                  WORK( 2*N+JE+1 ) = ONE
                  WORK( 3*N+JE+1 ) = ZERO
                  TEMP = ACOEF*A( JE, JE+1 )
                  WORK( 2*N+JE ) = ( BCOEFR*B( JE+1, JE+1 )-ACOEF* &
                                   A( JE+1, JE+1 ) ) / TEMP
                  WORK( 3*N+JE ) = BCOEFI*B( JE+1, JE+1 ) / TEMP
               END IF
               XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), &
                      ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
            END IF
!
            DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
!
!                                           T
!           Triangular solve of  (a A - b B)  y = 0
!
!                                   T
!           (rowwise in  (a A - b B) , or columnwise in (a A - b B) )
!
            IL2BY2 = .FALSE.
!
            DO 160 J = JE + NW, N
               IF( IL2BY2 ) THEN
                  IL2BY2 = .FALSE.
                  GO TO 160
               END IF
!
               NA = 1
               BDIAG( 1 ) = B( J, J )
               IF( J.LT.N ) THEN
                  IF( A( J+1, J ).NE.ZERO ) THEN
                     IL2BY2 = .TRUE.
                     BDIAG( 2 ) = B( J+1, J+1 )
                     NA = 2
                  END IF
               END IF
!
!              Check whether scaling is necessary for dot products
!
               XSCALE = ONE / MAX( ONE, XMAX )
               TEMP = MAX( WORK( J ), WORK( N+J ), &
                      ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
               IF( IL2BY2 ) &
                  TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ), &
                         ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
               IF( TEMP.GT.BIGNUM*XSCALE ) THEN
                  DO 90 JW = 0, NW - 1
                     DO 80 JR = JE, J - 1
                        WORK( ( JW+2 )*N+JR ) = XSCALE* &
                           WORK( ( JW+2 )*N+JR )
   80                CONTINUE
   90             CONTINUE
                  XMAX = XMAX*XSCALE
               END IF
!
!              Compute dot products
!
!                    j-1
!              SUM = sum  conjg( a*A(k,j) - b*B(k,j) )*x(k)
!                    k=je
!
!              To reduce the op count, this is done as
!
!              _        j-1                  _        j-1
!              a*conjg( sum  A(k,j)*x(k) ) - b*conjg( sum  B(k,j)*x(k) )
!                       k=je                          k=je
!
!              which may cause underflow problems if A or B are close
!              to underflow.  (E.g., less than SMALL.)
!
!
!              A series of compiler directives to defeat vectorization
!              for the next loop
!
!$PL$ CMCHAR=' '
!DIR$          NEXTSCALAR
!$DIR          SCALAR
!DIR$          NEXT SCALAR
!VD$L          NOVECTOR
!DEC$          NOVECTOR
!VD$           NOVECTOR
!VDIR          NOVECTOR
!VOCL          LOOP,SCALAR
!IBM           PREFER SCALAR
!$PL$ CMCHAR='*'
!
               DO 120 JW = 1, NW
!
!$PL$ CMCHAR=' '
!DIR$             NEXTSCALAR
!$DIR             SCALAR
!DIR$             NEXT SCALAR
!VD$L             NOVECTOR
!DEC$             NOVECTOR
!VD$              NOVECTOR
!VDIR             NOVECTOR
!VOCL             LOOP,SCALAR
!IBM              PREFER SCALAR
!$PL$ CMCHAR='*'
!
                  DO 110 JA = 1, NA
                     SUMA( JA, JW ) = ZERO
                     SUMB( JA, JW ) = ZERO
!
                     DO 100 JR = JE, J - 1
                        SUMA( JA, JW ) = SUMA( JA, JW ) + &
                                         A( JR, J+JA-1 )* &
                                         WORK( ( JW+1 )*N+JR )
                        SUMB( JA, JW ) = SUMB( JA, JW ) + &
                                         B( JR, J+JA-1 )* &
                                         WORK( ( JW+1 )*N+JR )
  100                CONTINUE
  110             CONTINUE
  120          CONTINUE
!
!$PL$ CMCHAR=' '
!DIR$          NEXTSCALAR
!$DIR          SCALAR
!DIR$          NEXT SCALAR
!VD$L          NOVECTOR
!DEC$          NOVECTOR
!VD$           NOVECTOR
!VDIR          NOVECTOR
!VOCL          LOOP,SCALAR
!IBM           PREFER SCALAR
!$PL$ CMCHAR='*'
!
               DO 130 JA = 1, NA
                  IF( ILCPLX ) THEN
                     SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + &
                                    BCOEFR*SUMB( JA, 1 ) - &
                                    BCOEFI*SUMB( JA, 2 )
                     SUM( JA, 2 ) = -ACOEF*SUMA( JA, 2 ) + &
                                    BCOEFR*SUMB( JA, 2 ) + &
                                    BCOEFI*SUMB( JA, 1 )
                  ELSE
                     SUM( JA, 1 ) = -ACOEF*SUMA( JA, 1 ) + &
                                    BCOEFR*SUMB( JA, 1 )
                  END IF
  130          CONTINUE
!
!                                  T
!              Solve  ( a A - b B )  y = SUM(,)
!              with scaling and perturbation of the denominator
!
               CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, A( J, J ), LDA, &
                            BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR, &
                            BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP, &
                            IINFO )
               IF( SCALE.LT.ONE ) THEN
                  DO 150 JW = 0, NW - 1
                     DO 140 JR = JE, J - 1
                        WORK( ( JW+2 )*N+JR ) = SCALE* &
                           WORK( ( JW+2 )*N+JR )
  140                CONTINUE
  150             CONTINUE
                  XMAX = SCALE*XMAX
               END IF
               XMAX = MAX( XMAX, TEMP )
  160       CONTINUE
!
!           Copy eigenvector to VL, back transforming if
!           HOWMNY='B'.
!
            IEIG = IEIG + 1
            IF( ILBACK ) THEN
               DO 170 JW = 0, NW - 1
                  CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL, &
                              WORK( ( JW+2 )*N+JE ), 1, ZERO, &
                              WORK( ( JW+4 )*N+1 ), 1 )
  170          CONTINUE
               CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ), &
                            LDVL )
               IBEG = 1
            ELSE
               CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ), &
                            LDVL )
               IBEG = JE
            END IF
!
!           Scale eigenvector
!
            XMAX = ZERO
            IF( ILCPLX ) THEN
               DO 180 J = IBEG, N
                  XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+ &
                         ABS( VL( J, IEIG+1 ) ) )
  180          CONTINUE
            ELSE
               DO 190 J = IBEG, N
                  XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
  190          CONTINUE
            END IF
!
            IF( XMAX.GT.SAFMIN ) THEN
               XSCALE = ONE / XMAX
!
               DO 210 JW = 0, NW - 1
                  DO 200 JR = IBEG, N
                     VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
  200             CONTINUE
  210          CONTINUE
            END IF
            IEIG = IEIG + NW - 1
!
  220    CONTINUE
      END IF
!
!     Right eigenvectors
!
      IF( COMPR ) THEN
         IEIG = IM + 1
!
!        Main loop over eigenvalues
!
         ILCPLX = .FALSE.
         DO 500 JE = N, 1, -1
!
!           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
!           (b) this would be the second of a complex pair.
!           Check for complex eigenvalue, so as to be sure of which
!           entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
!           or SELECT(JE-1).
!           If this is a complex pair, the 2-by-2 diagonal block
!           corresponding to the eigenvalue is in rows/columns JE-1:JE
!
            IF( ILCPLX ) THEN
               ILCPLX = .FALSE.
               GO TO 500
            END IF
            NW = 1
            IF( JE.GT.1 ) THEN
               IF( A( JE, JE-1 ).NE.ZERO ) THEN
                  ILCPLX = .TRUE.
                  NW = 2
               END IF
            END IF
            IF( ILALL ) THEN
               ILCOMP = .TRUE.
            ELSE IF( ILCPLX ) THEN
               ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
            ELSE
               ILCOMP = SELECT( JE )
            END IF
            IF( .NOT.ILCOMP ) &
               GO TO 500
!
!           Decide if (a) singular pencil, (b) real eigenvalue, or
!           (c) complex eigenvalue.
!
            IF( .NOT.ILCPLX ) THEN
               IF( ABS( A( JE, JE ) ).LE.SAFMIN .AND. &
                   ABS( B( JE, JE ) ).LE.SAFMIN ) THEN
!
!                 Singular matrix pencil -- unit eigenvector
!
                  IEIG = IEIG - 1
                  DO 230 JR = 1, N
                     VR( JR, IEIG ) = ZERO
  230             CONTINUE
                  VR( IEIG, IEIG ) = ONE
                  GO TO 500
               END IF
            END IF
!
!           Clear vector
!
            DO 250 JW = 0, NW - 1
               DO 240 JR = 1, N
                  WORK( ( JW+2 )*N+JR ) = ZERO
  240          CONTINUE
  250       CONTINUE
!
!           Compute coefficients in  ( a A - b B ) x = 0
!              a  is  ACOEF
!              b  is  BCOEFR + i*BCOEFI
!
            IF( .NOT.ILCPLX ) THEN
!
!              Real eigenvalue
!
               TEMP = ONE / MAX( ABS( A( JE, JE ) )*ASCALE, &
                      ABS( B( JE, JE ) )*BSCALE, SAFMIN )
               SALFAR = ( TEMP*A( JE, JE ) )*ASCALE
               SBETA = ( TEMP*B( JE, JE ) )*BSCALE
               ACOEF = SBETA*ASCALE
               BCOEFR = SALFAR*BSCALE
               BCOEFI = ZERO
!
!              Scale to avoid underflow
!
               SCALE = ONE
               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
               LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT. &
                     SMALL
               IF( LSA ) &
                  SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
               IF( LSB ) &
                  SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )* &
                          MIN( BNORM, BIG ) )
               IF( LSA .OR. LSB ) THEN
                  SCALE = MIN( SCALE, ONE / &
                          ( SAFMIN*MAX( ONE, ABS( ACOEF ), &
                          ABS( BCOEFR ) ) ) )
                  IF( LSA ) THEN
                     ACOEF = ASCALE*( SCALE*SBETA )
                  ELSE
                     ACOEF = SCALE*ACOEF
                  END IF
                  IF( LSB ) THEN
                     BCOEFR = BSCALE*( SCALE*SALFAR )
                  ELSE
                     BCOEFR = SCALE*BCOEFR
                  END IF
               END IF
               ACOEFA = ABS( ACOEF )
               BCOEFA = ABS( BCOEFR )
!
!              First component is 1
!
               WORK( 2*N+JE ) = ONE
               XMAX = ONE
!
!              Compute contribution from column JE of A and B to sum
!              (See "Further Details", above.)
!
               DO 260 JR = 1, JE - 1
                  WORK( 2*N+JR ) = BCOEFR*B( JR, JE ) - &
                                   ACOEF*A( JR, JE )
  260          CONTINUE
            ELSE
!
!              Complex eigenvalue
!
               CALL DLAG2( A( JE-1, JE-1 ), LDA, B( JE-1, JE-1 ), LDB, &
                           SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2, &
                           BCOEFI )
               IF( BCOEFI.EQ.ZERO ) THEN
                  INFO = JE - 1
                  RETURN
               END IF
!
!              Scale to avoid over/underflow
!
               ACOEFA = ABS( ACOEF )
               BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
               SCALE = ONE
               IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN ) &
                  SCALE = ( SAFMIN / ULP ) / ACOEFA
               IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN ) &
                  SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
               IF( SAFMIN*ACOEFA.GT.ASCALE ) &
                  SCALE = ASCALE / ( SAFMIN*ACOEFA )
               IF( SAFMIN*BCOEFA.GT.BSCALE ) &
                  SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
               IF( SCALE.NE.ONE ) THEN
                  ACOEF = SCALE*ACOEF
                  ACOEFA = ABS( ACOEF )
                  BCOEFR = SCALE*BCOEFR
                  BCOEFI = SCALE*BCOEFI
                  BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
               END IF
!
!              Compute first two components of eigenvector
!              and contribution to sums
!
               TEMP = ACOEF*A( JE, JE-1 )
               TEMP2R = ACOEF*A( JE, JE ) - BCOEFR*B( JE, JE )
               TEMP2I = -BCOEFI*B( JE, JE )
               IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
                  WORK( 2*N+JE ) = ONE
                  WORK( 3*N+JE ) = ZERO
                  WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
                  WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
               ELSE
                  WORK( 2*N+JE-1 ) = ONE
                  WORK( 3*N+JE-1 ) = ZERO
                  TEMP = ACOEF*A( JE-1, JE )
                  WORK( 2*N+JE ) = ( BCOEFR*B( JE-1, JE-1 )-ACOEF* &
                                   A( JE-1, JE-1 ) ) / TEMP
                  WORK( 3*N+JE ) = BCOEFI*B( JE-1, JE-1 ) / TEMP
               END IF
!
               XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ), &
                      ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
!
!              Compute contribution from columns JE and JE-1
!              of A and B to the sums.
!
               CREALA = ACOEF*WORK( 2*N+JE-1 )
               CIMAGA = ACOEF*WORK( 3*N+JE-1 )
               CREALB = BCOEFR*WORK( 2*N+JE-1 ) - &
                        BCOEFI*WORK( 3*N+JE-1 )
               CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) + &
                        BCOEFR*WORK( 3*N+JE-1 )
               CRE2A = ACOEF*WORK( 2*N+JE )
               CIM2A = ACOEF*WORK( 3*N+JE )
               CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
               CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
               DO 270 JR = 1, JE - 2
                  WORK( 2*N+JR ) = -CREALA*A( JR, JE-1 ) + &
                                   CREALB*B( JR, JE-1 ) - &
                                   CRE2A*A( JR, JE ) + CRE2B*B( JR, JE )
                  WORK( 3*N+JR ) = -CIMAGA*A( JR, JE-1 ) + &
                                   CIMAGB*B( JR, JE-1 ) - &
                                   CIM2A*A( JR, JE ) + CIM2B*B( JR, JE )
  270          CONTINUE
            END IF
!
            DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
!
!           Columnwise triangular solve of  (a A - b B)  x = 0
!
            IL2BY2 = .FALSE.
            DO 370 J = JE - NW, 1, -1
!
!              If a 2-by-2 block, is in position j-1:j, wait until
!              next iteration to process it (when it will be j:j+1)
!
               IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
                  IF( A( J, J-1 ).NE.ZERO ) THEN
                     IL2BY2 = .TRUE.
                     GO TO 370
                  END IF
               END IF
               BDIAG( 1 ) = B( J, J )
               IF( IL2BY2 ) THEN
                  NA = 2
                  BDIAG( 2 ) = B( J+1, J+1 )
               ELSE
                  NA = 1
               END IF
!
!              Compute x(j) (and x(j+1), if 2-by-2 block)
!
               CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, A( J, J ), &
                            LDA, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ), &
                            N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP, &
                            IINFO )
               IF( SCALE.LT.ONE ) THEN
!
                  DO 290 JW = 0, NW - 1
                     DO 280 JR = 1, JE
                        WORK( ( JW+2 )*N+JR ) = SCALE* &
                           WORK( ( JW+2 )*N+JR )
  280                CONTINUE
  290             CONTINUE
               END IF
               XMAX = MAX( SCALE*XMAX, TEMP )
!
               DO 310 JW = 1, NW
                  DO 300 JA = 1, NA
                     WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
  300             CONTINUE
  310          CONTINUE
!
!              w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling
!
               IF( J.GT.1 ) THEN
!
!                 Check whether scaling is necessary for sum.
!
                  XSCALE = ONE / MAX( ONE, XMAX )
                  TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
                  IF( IL2BY2 ) &
                     TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA* &
                            WORK( N+J+1 ) )
                  TEMP = MAX( TEMP, ACOEFA, BCOEFA )
                  IF( TEMP.GT.BIGNUM*XSCALE ) THEN
!
                     DO 330 JW = 0, NW - 1
                        DO 320 JR = 1, JE
                           WORK( ( JW+2 )*N+JR ) = XSCALE* &
                              WORK( ( JW+2 )*N+JR )
  320                   CONTINUE
  330                CONTINUE
                     XMAX = XMAX*XSCALE
                  END IF
!
!                 Compute the contributions of the off-diagonals of
!                 column j (and j+1, if 2-by-2 block) of A and B to the
!                 sums.
!
!
                  DO 360 JA = 1, NA
                     IF( ILCPLX ) THEN
                        CREALA = ACOEF*WORK( 2*N+J+JA-1 )
                        CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
                        CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) - &
                                 BCOEFI*WORK( 3*N+J+JA-1 )
                        CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) + &
                                 BCOEFR*WORK( 3*N+J+JA-1 )
                        DO 340 JR = 1, J - 1
                           WORK( 2*N+JR ) = WORK( 2*N+JR ) - &
                                            CREALA*A( JR, J+JA-1 ) + &
                                            CREALB*B( JR, J+JA-1 )
                           WORK( 3*N+JR ) = WORK( 3*N+JR ) - &
                                            CIMAGA*A( JR, J+JA-1 ) + &
                                            CIMAGB*B( JR, J+JA-1 )
  340                   CONTINUE
                     ELSE
                        CREALA = ACOEF*WORK( 2*N+J+JA-1 )
                        CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
                        DO 350 JR = 1, J - 1
                           WORK( 2*N+JR ) = WORK( 2*N+JR ) - &
                                            CREALA*A( JR, J+JA-1 ) + &
                                            CREALB*B( JR, J+JA-1 )
  350                   CONTINUE
                     END IF
  360             CONTINUE
               END IF
!
               IL2BY2 = .FALSE.
  370       CONTINUE
!
!           Copy eigenvector to VR, back transforming if
!           HOWMNY='B'.
!
            IEIG = IEIG - NW
            IF( ILBACK ) THEN
!
               DO 410 JW = 0, NW - 1
                  DO 380 JR = 1, N
                     WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )* &
                                             VR( JR, 1 )
  380             CONTINUE
!
!                 A series of compiler directives to defeat
!                 vectorization for the next loop
!
!
                  DO 400 JC = 2, JE
                     DO 390 JR = 1, N
                        WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) + &
                           WORK( ( JW+2 )*N+JC )*VR( JR, JC )
  390                CONTINUE
  400             CONTINUE
  410          CONTINUE
!
               DO 430 JW = 0, NW - 1
                  DO 420 JR = 1, N
                     VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
  420             CONTINUE
  430          CONTINUE
!
               IEND = N
            ELSE
               DO 450 JW = 0, NW - 1
                  DO 440 JR = 1, N
                     VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
  440             CONTINUE
  450          CONTINUE
!
               IEND = JE
            END IF
!
!           Scale eigenvector
!
            XMAX = ZERO
            IF( ILCPLX ) THEN
               DO 460 J = 1, IEND
                  XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+ &
                         ABS( VR( J, IEIG+1 ) ) )
  460          CONTINUE
            ELSE
               DO 470 J = 1, IEND
                  XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
  470          CONTINUE
            END IF
!
            IF( XMAX.GT.SAFMIN ) THEN
               XSCALE = ONE / XMAX
               DO 490 JW = 0, NW - 1
                  DO 480 JR = 1, IEND
                     VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
  480             CONTINUE
  490          CONTINUE
            END IF
  500    CONTINUE
      END IF
!
      RETURN
!
!     End of DTGEVC
!
      END
      SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, J1, N1, N2, WORK, LWORK, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ), &
                         WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
!  of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
!  (A, B) by an orthogonal equivalence transformation.
!
!  (A, B) must be in generalized real Schur canonical form (as returned
!  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
!  diagonal blocks. B is upper triangular.
!
!  Optionally, the matrices Q and Z of generalized Schur vectors are
!  updated.
!
!         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
!         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
!
!
!  Arguments
!  =========
!
!  WANTQ   (input) LOGICAL
!          .TRUE. : update the left transformation matrix Q;
!          .FALSE.: do not update Q.
!
!  WANTZ   (input) LOGICAL
!          .TRUE. : update the right transformation matrix Z;
!          .FALSE.: do not update Z.
!
!  N       (input) INTEGER
!          The order of the matrices A and B. N >= 0.
!
!  A      (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N)
!          On entry, the matrix A in the pair (A, B).
!          On exit, the updated matrix A.
!
!  LDA     (input)  INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B      (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N)
!          On entry, the matrix B in the pair (A, B).
!          On exit, the updated matrix B.
!
!  LDB     (input)  INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
!          On exit, the updated matrix Q.
!          Not referenced if WANTQ = .FALSE..
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= 1.
!          If WANTQ = .TRUE., LDQ >= N.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
!          On exit, the updated matrix Z.
!          Not referenced if WANTZ = .FALSE..
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z. LDZ >= 1.
!          If WANTZ = .TRUE., LDZ >= N.
!
!  J1      (input) INTEGER
!          The index to the first block (A11, B11). 1 <= J1 <= N.
!
!  N1      (input) INTEGER
!          The order of the first block (A11, B11). N1 = 0, 1 or 2.
!
!  N2      (input) INTEGER
!          The order of the second block (A22, B22). N2 = 0, 1 or 2.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK).
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          LWORK >=  MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
!
!  INFO    (output) INTEGER
!            =0: Successful exit
!            >0: If INFO = 1, the transformed matrix (A, B) would be
!                too far from generalized Schur form; the blocks are
!                not swapped and (A, B) and (Q, Z) are unchanged.
!                The problem of swapping is too ill-conditioned.
!            <0: If INFO = -16: LWORK is too small. Appropriate value
!                for LWORK is returned in WORK(1).
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  In the current code both weak and strong stability tests are
!  performed. The user can omit the strong stability test by changing
!  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
!  details.
!
!  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
!      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!
!  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
!      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
!      Estimation: Theory, Algorithms and Software,
!      Report UMINF - 94.04, Department of Computing Science, Umea
!      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
!      Note 87. To appear in Numerical Algorithms, 1996.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 1.0D+01 )
      INTEGER            LDST
      PARAMETER          ( LDST = 4 )
      LOGICAL            WANDS
      PARAMETER          ( WANDS = .TRUE. )
!     ..
!     .. Local Scalars ..
      LOGICAL            DTRONG, WEAK
      INTEGER            I, IDUM, LINFO, M
      DOUBLE PRECISION   BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, &
                         F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
!     ..
!     .. Local Arrays ..
      INTEGER            IWORK( LDST )
      DOUBLE PRECISION   AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ), &
                         IRCOP( LDST, LDST ), LI( LDST, LDST ), &
                         LICOP( LDST, LDST ), S( LDST, LDST ), &
                         SCPY( LDST, LDST ), T( LDST, LDST ), &
                         TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
      double precision zero_vec(1)
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, &
                         DLARTG, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, &
                         DROT, DSCAL, DTGSY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      INFO = 0
      zero_vec(1) = 0.0D+00
!
!     Quick return if possible
!
      IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 ) &
         RETURN
      IF( N1.GT.N .OR. ( J1+N1 ).GT.N ) &
         RETURN
      M = N1 + N2
      IF( LWORK.LT.MAX( N*M, M*M*2 ) ) THEN
         INFO = -16
         WORK( 1 ) = MAX( N*M, M*M*2 )
         RETURN
      END IF
!
      WEAK = .FALSE.
      DTRONG = .FALSE.
!
!     Make a local copy of selected block
!
      CALL DCOPY( LDST*LDST, zero_vec, 0, LI, 1 )
      CALL DCOPY( LDST*LDST, zero_vec, 0, IR, 1 )
      CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
      CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
!
!     Compute threshold for testing acceptance of swapping.
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      DSCALE = ZERO
      DSUM = ONE
      CALL DLACPY( 'Full', M, M, S, LDST, WORK, M )
      CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
      CALL DLACPY( 'Full', M, M, T, LDST, WORK, M )
      CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
      DNORM = DSCALE*SQRT( DSUM )
      THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
!
      IF( M.EQ.2 ) THEN
!
!        CASE 1: Swap 1-by-1 and 1-by-1 blocks.
!
!        Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
!        using Givens rotations and perform the swap tentatively.
!
         F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
         G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
         SB = ABS( T( 2, 2 ) )
         SA = ABS( S( 2, 2 ) )
         CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
         IR( 2, 1 ) = -IR( 1, 2 )
         IR( 2, 2 ) = IR( 1, 1 )
         CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ), &
                    IR( 2, 1 ) )
         CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ), &
                    IR( 2, 1 ) )
         IF( SA.GE.SB ) THEN
            CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), &
                         DDUM )
         ELSE
            CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ), &
                         DDUM )
         END IF
         CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ), &
                    LI( 2, 1 ) )
         CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ), &
                    LI( 2, 1 ) )
         LI( 2, 2 ) = LI( 1, 1 )
         LI( 1, 2 ) = -LI( 2, 1 )
!
!        Weak stability test:
!           |S21| + |T21| <= O(EPS * F-norm((S, T)))
!
         WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
         WEAK = WS.LE.THRESH
         IF( .NOT.WEAK ) &
            GO TO 70
!
         IF( WANDS ) THEN
!
!           Strong stability test:
!             F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
!
            CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), &
                         M )
            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, &
                        WORK, M )
            CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, &
                        WORK( M*M+1 ), M )
            DSCALE = ZERO
            DSUM = ONE
            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
!
            CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), &
                         M )
            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, &
                        WORK, M )
            CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE, &
                        WORK( M*M+1 ), M )
            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
            SS = DSCALE*SQRT( DSUM )
            DTRONG = SS.LE.THRESH
            IF( .NOT.DTRONG ) &
               GO TO 70
         END IF
!
!        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
!               (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
!
         CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ), &
                    IR( 2, 1 ) )
         CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ), &
                    IR( 2, 1 ) )
         CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, &
                    LI( 1, 1 ), LI( 2, 1 ) )
         CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, &
                    LI( 1, 1 ), LI( 2, 1 ) )
!
!        Set  N1-by-N2 (2,1) - blocks to ZERO.
!
         A( J1+1, J1 ) = ZERO
         B( J1+1, J1 ) = ZERO
!
!        Accumulate transformations into Q and Z if requested.
!
         IF( WANTZ ) &
            CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ), &
                       IR( 2, 1 ) )
         IF( WANTQ ) &
            CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ), &
                       LI( 2, 1 ) )
!
!        Exit with INFO = 0 if swap was successfully performed.
!
         RETURN
!
      ELSE
!
!        CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
!                and 2-by-2 blocks.
!
!        Solve the generalized Sylvester equation
!                 S11 * R - L * S22 = SCALE * S12
!                 T11 * R - L * T22 = SCALE * T12
!        for R and L. Solutions in LI and IR.
!
         CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
         CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST, &
                      IR( N2+1, N1+1 ), LDST )
         CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST, &
                      IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ), &
                      LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM, &
                      LINFO )
!
!        Compute orthogonal matrix QL:
!
!                    QL' * LI = [ TL ]
!                               [ 0  ]
!        where
!                    LI =  [      -L              ]
!                          [ SCALE * identity(N2) ]
!
         DO I = 1, N2
            CALL DSCAL( N1, -ONE, LI( 1, I ), 1 )
            LI( N1+I, I ) = SCALE
         end do
         CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
         CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
!
!        Compute orthogonal matrix RQ:
!
!                    IR * RQ' =   [ 0  TR],
!
!         where IR = [ SCALE * identity(N1), R ]
!
         DO I = 1, N1
            IR( N2+I, I ) = SCALE
         end do
         CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
         CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
!
!        Perform the swapping tentatively:
!
         CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, &
                     WORK, M )
         CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S, &
                     LDST )
         CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, &
                     WORK, M )
         CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T, &
                     LDST )
         CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST )
         CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST )
         CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
         CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
!
!        Triangularize the B-part by an RQ factorization.
!        Apply transformation (from left) to A-part, giving S.
!
         CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
         CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK, &
                      LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
         CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK, &
                      LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
!
!        Compute F-norm(S21) in BRQA21. (T21 is 0.)
!
         DSCALE = ZERO
         DSUM = ONE
         DO I = 1, N2
            CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
         end do
         BRQA21 = DSCALE*SQRT( DSUM )
!
!        Triangularize the B-part by a QR factorization.
!        Apply transformation (from right) to A-part, giving S.
!
         CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
         CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST, &
                      WORK, INFO )
         CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST, &
                      WORK, INFO )
         IF( LINFO.NE.0 ) &
            GO TO 70
!
!        Compute F-norm(S21) in BQRA21. (T21 is 0.)
!
         DSCALE = ZERO
         DSUM = ONE
         DO I = 1, N2
            CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
         end do
         BQRA21 = DSCALE*SQRT( DSUM )
!
!        Decide which method to use.
!          Weak stability test:
!             F-norm(S21) <= O(EPS * F-norm((S, T)))
!
         IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
            CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST )
            CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST )
            CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
            CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
         ELSE IF( BRQA21.GE.THRESH ) THEN
            GO TO 70
         END IF
!
!        Set lower triangle of B-part to zero
!
         DO I = 2, M
            CALL DCOPY( M-I+1, zero_vec, 0, T( I, I-1 ), 1 )
         end do
!
         IF( WANDS ) THEN
!
!           Strong stability test:
!              F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
!
            CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ), &
                         M )
            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO, &
                        WORK, M )
            CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, &
                        WORK( M*M+1 ), M )
            DSCALE = ZERO
            DSUM = ONE
            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
!
            CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ), &
                         M )
            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO, &
                        WORK, M )
            CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE, &
                        WORK( M*M+1 ), M )
            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
            SS = DSCALE*SQRT( DSUM )
            DTRONG = ( SS.LE.THRESH )
            IF( .NOT.DTRONG ) &
               GO TO 70
!
         END IF
!
!        If the swap is accepted ("weakly" and "strongly"), apply the
!        transformations and set N1-by-N2 (2,1)-block to zero.
!
         DO 60 I = 1, N2
            CALL DCOPY( N1, zero_vec, 0, S( N2+1, I ), 1 )
   60    CONTINUE
!
!        copy back M-by-M diagonal block starting at index J1 of (A, B)
!
         CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
         CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
         CALL DCOPY( LDST*LDST, zero_vec, 0, T, 1 )
!
!        Standardize existing 2-by-2 blocks.
!
         CALL DCOPY( M*M, zero_vec, 0, WORK, 1 )
         WORK( 1 ) = ONE
         T( 1, 1 ) = ONE
         IDUM = LWORK - M*M - 2
         IF( N2.GT.1 ) THEN
            CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE, &
                         WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
            WORK( M+1 ) = -WORK( 2 )
            WORK( M+2 ) = WORK( 1 )
            T( N2, N2 ) = T( 1, 1 )
            T( 1, 2 ) = -T( 2, 1 )
         END IF
         WORK( M*M ) = ONE
         T( M, M ) = ONE
!
         IF( N1.GT.1 ) THEN
            CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB, &
                         TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ), &
                         WORK( N2*M+N2+2 ), T( N2+1, N2+1 ), &
                         T( M, M-1 ) )
            WORK( M*M ) = WORK( N2*M+N2+1 )
            WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
            T( M, M ) = T( N2+1, N2+1 )
            T( M-1, M ) = -T( M, M-1 )
         END IF
         CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ), &
                     LDA, ZERO, WORK( M*M+1 ), N2 )
         CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ), &
                      LDA )
         CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ), &
                     LDB, ZERO, WORK( M*M+1 ), N2 )
         CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ), &
                      LDB )
         CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO, &
                     WORK( M*M+1 ), M )
         CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
         CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA, &
                     T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
         CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
         CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDA, &
                     T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
         CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
         CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO, &
                     WORK, M )
         CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST )
!
!        Accumulate transformations into Q and Z if requested.
!
         IF( WANTQ ) THEN
            CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI, &
                        LDST, ZERO, WORK, N )
            CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
!
         END IF
!
         IF( WANTZ ) THEN
            CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR, &
                        LDST, ZERO, WORK, N )
            CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
!
         END IF
!
!        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
!                (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
!
         I = J1 + M
         IF( I.LE.N ) THEN
            CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, &
                        A( J1, I ), LDA, ZERO, WORK, M )
            CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
            CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST, &
                        B( J1, I ), LDA, ZERO, WORK, M )
            CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDA )
         END IF
         I = J1 - 1
         IF( I.GT.0 ) THEN
            CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR, &
                        LDST, ZERO, WORK, I )
            CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
            CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR, &
                        LDST, ZERO, WORK, I )
            CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
         END IF
!
!        Exit with INFO = 0 if swap was successfully performed.
!
         RETURN
!
      END IF
!
!     Exit with INFO = 1 if swap was rejected.
!
   70 CONTINUE
!
      INFO = 1
      RETURN
!
!     End of DTGEX2
!
      END
      SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, IFST, ILST, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ), &
                         WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DTGEXC reorders the generalized real Schur decomposition of a real
!  matrix pair (A,B) using an orthogonal equivalence transformation
!
!                 (A, B) = Q * (A, B) * Z',
!
!  so that the diagonal block of (A, B) with row index IFST is moved
!  to row ILST.
!
!  (A, B) must be in generalized real Schur canonical form (as returned
!  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
!  diagonal blocks. B is upper triangular.
!
!  Optionally, the matrices Q and Z of generalized Schur vectors are
!  updated.
!
!         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
!         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
!
!
!  Arguments
!  =========
!
!  WANTQ   (input) LOGICAL
!          .TRUE. : update the left transformation matrix Q;
!          .FALSE.: do not update Q.
!
!  WANTZ   (input) LOGICAL
!          .TRUE. : update the right transformation matrix Z;
!          .FALSE.: do not update Z.
!
!  N       (input) INTEGER
!          The order of the matrices A and B. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the matrix A in generalized real Schur canonical
!          form.
!          On exit, the updated matrix A, again in generalized
!          real Schur canonical form.
!
!  LDA     (input)  INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the matrix B in generalized real Schur canonical
!          form (A,B).
!          On exit, the updated matrix B, again in generalized
!          real Schur canonical form (A,B).
!
!  LDB     (input)  INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
!          On exit, the updated matrix Q.
!          If WANTQ = .FALSE., Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= 1.
!          If WANTQ = .TRUE., LDQ >= N.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
!          On exit, the updated matrix Z.
!          If WANTZ = .FALSE., Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z. LDZ >= 1.
!          If WANTZ = .TRUE., LDZ >= N.
!
!  IFST    (input/output) INTEGER
!  ILST    (input/output) INTEGER
!          Specify the reordering of the diagonal blocks of (A, B).
!          The block with row index IFST is moved to row ILST, by a
!          sequence of swapping between adjacent blocks.
!          On exit, if IFST pointed on entry to the second row of
!          a 2-by-2 block, it is changed to point to the first row;
!          ILST always points to the first row of the block in its
!          final position (which may differ from its input value by
!          +1 or -1). 1 <= IFST, ILST <= N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= 4*N + 16.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!           =0:  successful exit.
!           <0:  if INFO = -i, the i-th argument had an illegal value.
!           =1:  The transformed matrix pair (A, B) would be too far
!                from generalized Schur form; the problem is ill-
!                conditioned. (A, B) may have been partially reordered,
!                and ILST points to the first row of the current
!                position of the block being moved.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
!      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            HERE, LWMIN, NBF, NBL, NBNEXT
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTGEX2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Decode and test input arguments.
!
      INFO = 0
      LWMIN = MAX( 1, 4*N+16 )
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
         INFO = -11
      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
         INFO = -12
      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
         INFO = -13
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -15
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGEXC', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.1 ) &
         RETURN
!
!     Determine the first row of the specified block and find out
!     if it is 1-by-1 or 2-by-2.
!
      IF( IFST.GT.1 ) THEN
         IF( A( IFST, IFST-1 ).NE.ZERO ) &
            IFST = IFST - 1
      END IF
      NBF = 1
      IF( IFST.LT.N ) THEN
         IF( A( IFST+1, IFST ).NE.ZERO ) &
            NBF = 2
      END IF
!
!     Determine the first row of the final block
!     and find out if it is 1-by-1 or 2-by-2.
!
      IF( ILST.GT.1 ) THEN
         IF( A( ILST, ILST-1 ).NE.ZERO ) &
            ILST = ILST - 1
      END IF
      NBL = 1
      IF( ILST.LT.N ) THEN
         IF( A( ILST+1, ILST ).NE.ZERO ) &
            NBL = 2
      END IF
      IF( IFST.EQ.ILST ) &
         RETURN
!
      IF( IFST.LT.ILST ) THEN
!
!        Update ILST.
!
         IF( NBF.EQ.2 .AND. NBL.EQ.1 ) &
            ILST = ILST - 1
         IF( NBF.EQ.1 .AND. NBL.EQ.2 ) &
            ILST = ILST + 1
!
         HERE = IFST
!
   10    CONTINUE
!
!        Swap with next one below.
!
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
!
!           Current block either 1-by-1 or 2-by-2.
!
            NBNEXT = 1
            IF( HERE+NBF+1.LE.N ) THEN
               IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE + NBNEXT
!
!           Test if 2-by-2 block breaks into two 1-by-1 blocks.
!
            IF( NBF.EQ.2 ) THEN
               IF( A( HERE+1, HERE ).EQ.ZERO ) &
                  NBF = 3
            END IF
!
         ELSE
!
!           Current block consists of two 1-by-1 blocks, each of which
!           must be swapped individually.
!
            NBNEXT = 1
            IF( HERE+3.LE.N ) THEN
               IF( A( HERE+3, HERE+2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
!
!              Swap two 1-by-1 blocks.
!
               CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                            LDZ, HERE, 1, 1, WORK, LWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE + 1
!
            ELSE
!
!              Recompute NBNEXT in case of 2-by-2 split.
!
               IF( A( HERE+2, HERE+1 ).EQ.ZERO ) &
                  NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
!
!                 2-by-2 block did not split.
!
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK, &
                               INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 2
               ELSE
!
!                 2-by-2 block did split.
!
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 1
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 1
               END IF
!
            END IF
         END IF
         IF( HERE.LT.ILST ) &
            GO TO 10
      ELSE
         HERE = IFST
!
   20    CONTINUE
!
!        Swap with next one below.
!
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
!
!           Current block either 1-by-1 or 2-by-2.
!
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( A( HERE-1, HERE-2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK, &
                         INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE - NBNEXT
!
!           Test if 2-by-2 block breaks into two 1-by-1 blocks.
!
            IF( NBF.EQ.2 ) THEN
               IF( A( HERE+1, HERE ).EQ.ZERO ) &
                  NBF = 3
            END IF
!
         ELSE
!
!           Current block consists of two 1-by-1 blocks, each of which
!           must be swapped individually.
!
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( A( HERE-1, HERE-2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                         LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK, &
                         INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
!
!              Swap two 1-by-1 blocks.
!
               CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, &
                            LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE - 1
            ELSE
!
!             Recompute NBNEXT in case of 2-by-2 split.
!
               IF( A( HERE, HERE-1 ).EQ.ZERO ) &
                  NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
!
!                 2-by-2 block did not split.
!
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 2
               ELSE
!
!                 2-by-2 block did split.
!
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 1
                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 1
               END IF
            END IF
         END IF
         IF( HERE.GT.ILST ) &
            GO TO 20
      END IF
      ILST = HERE
      WORK( 1 ) = LWMIN
      RETURN
!
!     End of DTGEXC
!
      END
      SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, &
                         ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, &
                         PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, &
                         M, N
      DOUBLE PRECISION   PL, PR
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ), &
                         B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), &
                         WORK( * ), Z( LDZ, * )
!     ..
!
!  Purpose
!  =======
!
!  DTGSEN reorders the generalized real Schur decomposition of a real
!  matrix pair (A, B) (in terms of an orthonormal equivalence trans-
!  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
!  appears in the leading diagonal blocks of the upper quasi-triangular
!  matrix A and the upper triangular B. The leading columns of Q and
!  Z form orthonormal bases of the corresponding left and right eigen-
!  spaces (deflating subspaces). (A, B) must be in generalized real
!  Schur canonical form (as returned by DGGES), i.e. A is block upper
!  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
!  triangular.
!
!  DTGSEN also computes the generalized eigenvalues
!
!              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
!
!  of the reordered matrix pair (A, B).
!
!  Optionally, DTGSEN computes the estimates of reciprocal condition
!  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
!  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
!  between the matrix pairs (A11, B11) and (A22,B22) that correspond to
!  the selected cluster and the eigenvalues outside the cluster, resp.,
!  and norms of "projections" onto left and right eigenspaces w.r.t.
!  the selected cluster in the (1,1)-block.
!
!  Arguments
!  =========
!
!  IJOB    (input) INTEGER
!          Specifies whether condition numbers are required for the
!          cluster of eigenvalues (PL and PR) or the deflating subspaces
!          (Difu and Difl):
!           =0: Only reorder w.r.t. SELECT. No extras.
!           =1: Reciprocal of norms of "projections" onto left and right
!               eigenspaces w.r.t. the selected cluster (PL and PR).
!           =2: Upper bounds on Difu and Difl. F-norm-based estimate
!               (DIF(1:2)).
!           =3: Estimate of Difu and Difl. 1-norm-based estimate
!               (DIF(1:2)).
!               About 5 times as expensive as IJOB = 2.
!           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
!               version to get it all.
!           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
!
!  WANTQ   (input) LOGICAL
!          .TRUE. : update the left transformation matrix Q;
!          .FALSE.: do not update Q.
!
!  WANTZ   (input) LOGICAL
!          .TRUE. : update the right transformation matrix Z;
!          .FALSE.: do not update Z.
!
!  SELECT  (input) LOGICAL array, dimension (N)
!          SELECT specifies the eigenvalues in the selected cluster.
!          To select a real eigenvalue w(j), SELECT(j) must be set to
!          .TRUE.. To select a complex conjugate pair of eigenvalues
!          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
!          either SELECT(j) or SELECT(j+1) or both must be set to
!          .TRUE.; a complex conjugate pair of eigenvalues must be
!          either both included in the cluster or both excluded.
!
!  N       (input) INTEGER
!          The order of the matrices A and B. N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension(LDA,N)
!          On entry, the upper quasi-triangular matrix A, with (A, B) in
!          generalized real Schur canonical form.
!          On exit, A is overwritten by the reordered matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension(LDB,N)
!          On entry, the upper triangular matrix B, with (A, B) in
!          generalized real Schur canonical form.
!          On exit, B is overwritten by the reordered matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
!  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
!          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
!          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
!          form (S,T) that would result if the 2-by-2 diagonal blocks of
!          the real generalized Schur form of (A,B) were further reduced
!          to triangular form using complex unitary transformations.
!          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
!          positive, then the j-th and (j+1)-st eigenvalues are a
!          complex conjugate pair, with ALPHAI(j+1) negative.
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
!          On exit, Q has been postmultiplied by the left orthogonal
!          transformation matrix which reorder (A, B); The leading M
!          columns of Q form orthonormal bases for the specified pair of
!          left eigenspaces (deflating subspaces).
!          If WANTQ = .FALSE., Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  LDQ >= 1;
!          and if WANTQ = .TRUE., LDQ >= N.
!
!  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
!          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
!          On exit, Z has been postmultiplied by the left orthogonal
!          transformation matrix which reorder (A, B); The leading M
!          columns of Z form orthonormal bases for the specified pair of
!          left eigenspaces (deflating subspaces).
!          If WANTZ = .FALSE., Z is not referenced.
!
!  LDZ     (input) INTEGER
!          The leading dimension of the array Z. LDZ >= 1;
!          If WANTZ = .TRUE., LDZ >= N.
!
!  M       (output) INTEGER
!          The dimension of the specified pair of left and right eigen-
!          spaces (deflating subspaces). 0 <= M <= N.
!
!  PL, PR  (output) DOUBLE PRECISION
!          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
!          reciprocal of the norm of "projections" onto left and right
!          eigenspaces with respect to the selected cluster.
!          0 < PL, PR <= 1.
!          If M = 0 or M = N, PL = PR  = 1.
!          If IJOB = 0, 2 or 3, PL and PR are not referenced.
!
!  DIF     (output) DOUBLE PRECISION array, dimension (2).
!          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
!          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
!          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
!          estimates of Difu and Difl.
!          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
!          If IJOB = 0 or 1, DIF is not referenced.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          IF IJOB = 0, WORK is not referenced.  Otherwise,
!          on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >=  4*N+16.
!          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
!          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
!          IF IJOB = 0, IWORK is not referenced.  Otherwise,
!          on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK. LIWORK >= 1.
!          If IJOB = 1, 2 or 4, LIWORK >=  N+6.
!          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!            =0: Successful exit.
!            <0: If INFO = -i, the i-th argument had an illegal value.
!            =1: Reordering of (A, B) failed because the transformed
!                matrix pair (A, B) would be too far from generalized
!                Schur form; the problem is very ill-conditioned.
!                (A, B) may have been partially reordered.
!                If requested, 0 is returned in DIF(*), PL and PR.
!
!  Further Details
!  ===============
!
!  DTGSEN first collects the selected eigenvalues by computing
!  orthogonal U and W that move them to the top left corner of (A, B).
!  In other words, the selected eigenvalues are the eigenvalues of
!  (A11, B11) in:
!
!                U'*(A, B)*W = (A11 A12) (B11 B12) n1
!                              ( 0  A22),( 0  B22) n2
!                                n1  n2    n1  n2
!
!  where N = n1+n2 and U' means the transpose of U. The first n1 columns
!  of U and W span the specified pair of left and right eigenspaces
!  (deflating subspaces) of (A, B).
!
!  If (A, B) has been obtained from the generalized real Schur
!  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
!  reordered generalized real Schur form of (C, D) is given by
!
!           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
!
!  and the first n1 columns of Q*U and Z*W span the corresponding
!  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
!
!  Note that if the selected eigenvalue is sufficiently ill-conditioned,
!  then its value may differ significantly from its value before
!  reordering.
!
!  The reciprocal condition numbers of the left and right eigenspaces
!  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
!  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
!
!  The Difu and Difl are defined as:
!
!       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
!  and
!       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
!
!  where sigma-min(Zu) is the smallest singular value of the
!  (2*n1*n2)-by-(2*n1*n2) matrix
!
!       Zu = [ kron(In2, A11)  -kron(A22', In1) ]
!            [ kron(In2, B11)  -kron(B22', In1) ].
!
!  Here, Inx is the identity matrix of size nx and A22' is the
!  transpose of A22. kron(X, Y) is the Kronecker product between
!  the matrices X and Y.
!
!  When DIF(2) is small, small changes in (A, B) can cause large changes
!  in the deflating subspace. An approximate (asymptotic) bound on the
!  maximum angular error in the computed deflating subspaces is
!
!       EPS * norm((A, B)) / DIF(2),
!
!  where EPS is the machine precision.
!
!  The reciprocal norm of the projectors on the left and right
!  eigenspaces associated with (A11, B11) may be returned in PL and PR.
!  They are computed as follows. First we compute L and R so that
!  P*(A, B)*Q is block diagonal, where
!
!       P = ( I -L ) n1           Q = ( I R ) n1
!           ( 0  I ) n2    and        ( 0 I ) n2
!             n1 n2                    n1 n2
!
!  and (L, R) is the solution to the generalized Sylvester equation
!
!       A11*R - L*A22 = -A12
!       B11*R - L*B22 = -B12
!
!  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
!  An approximate (asymptotic) bound on the average absolute error of
!  the selected eigenvalues is
!
!       EPS * norm((A, B)) / PL.
!
!  There are also global error bounds which valid for perturbations up
!  to a certain restriction:  A lower bound (x) on the smallest
!  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
!  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
!  (i.e. (A + E, B + F), is
!
!   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
!
!  An approximate bound on x can be computed from DIF(1:2), PL and PR.
!
!  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
!  (L', R') and unperturbed (L, R) left and right deflating subspaces
!  associated with the selected cluster in the (1,1)-blocks can be
!  bounded as
!
!   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
!   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
!
!  See LAPACK User's Guide section 4.11 or the following references
!  for more information.
!
!  Note that if the default method for computing the Frobenius-norm-
!  based estimate DIF is not wanted (see DLATDF), then the parameter
!  IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
!  (IJOB = 2 will be used)). See DTGSYL for more details.
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  References
!  ==========
!
!  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
!      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!
!  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
!      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
!      Estimation: Theory, Algorithms and Software,
!      Report UMINF - 94.04, Department of Computing Science, Umea
!      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
!      Note 87. To appear in Numerical Algorithms, 1996.
!
!  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
!      for Solving the Generalized Sylvester Equation and Estimating the
!      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
!      Department of Computing Science, Umea University, S-901 87 Umea,
!      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
!      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
!      1996.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            IDIFJB
      PARAMETER          ( IDIFJB = 3 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2, &
                         WANTP
      INTEGER            I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN, &
                         MN2, N1, N2
      DOUBLE PRECISION   DSCALE, DSUM, EPS, RDSCAL, SMLNUM
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL, &
                         XERBLA
!     ..
!     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, SIGN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
!
      IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -16
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSEN', -INFO )
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      IERR = 0
!
      WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
      WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
      WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
      WANTD = WANTD1 .OR. WANTD2
!
!     Set M to the dimension of the specified pair of deflating
!     subspaces.
!
      M = 0
      PAIR = .FALSE.
      DO 10 K = 1, N
         IF( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            IF( K.LT.N ) THEN
               IF( A( K+1, K ).EQ.ZERO ) THEN
                  IF( SELECT( K ) ) &
                     M = M + 1
               ELSE
                  PAIR = .TRUE.
                  IF( SELECT( K ) .OR. SELECT( K+1 ) ) &
                     M = M + 2
               END IF
            ELSE
               IF( SELECT( N ) ) &
                  M = M + 1
            END IF
         END IF
   10 CONTINUE
!
      IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
         LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) )
         LIWMIN = MAX( 1, N+6 )
      ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
         LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) )
         LIWMIN = MAX( 1, 2*M*( N-M ), N+6 )
      ELSE
         LWMIN = MAX( 1, 4*N+16 )
         LIWMIN = 1
      END IF
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -22
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -24
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSEN', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( M.EQ.N .OR. M.EQ.0 ) THEN
         IF( WANTP ) THEN
            PL = ONE
            PR = ONE
         END IF
         IF( WANTD ) THEN
            DSCALE = ZERO
            DSUM = ONE
            DO 20 I = 1, N
               CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
               CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
   20       CONTINUE
            DIF( 1 ) = DSCALE*SQRT( DSUM )
            DIF( 2 ) = DIF( 1 )
         END IF
         GO TO 60
      END IF
!
!     Collect the selected blocks at the top-left corner of (A, B).
!
      KS = 0
      PAIR = .FALSE.
      DO 30 K = 1, N
         IF( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
!
            SWAP = SELECT( K )
            IF( K.LT.N ) THEN
               IF( A( K+1, K ).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  SWAP = SWAP .OR. SELECT( K+1 )
               END IF
            END IF
!
            IF( SWAP ) THEN
               KS = KS + 1
!
!              Swap the K-th block to position KS.
!              Perform the reordering of diagonal blocks in (A, B)
!              by orthogonal transformation matrices and update
!              Q and Z accordingly (if requested):
!
               KK = K
               IF( K.NE.KS ) &
                  CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, &
                               Z, LDZ, KK, KS, WORK, LWORK, IERR )
!
               IF( IERR.GT.0 ) THEN
!
!                 Swap is rejected: exit.
!
                  INFO = 1
                  IF( WANTP ) THEN
                     PL = ZERO
                     PR = ZERO
                  END IF
                  IF( WANTD ) THEN
                     DIF( 1 ) = ZERO
                     DIF( 2 ) = ZERO
                  END IF
                  GO TO 60
               END IF
!
               IF( PAIR ) &
                  KS = KS + 1
            END IF
         END IF
   30 CONTINUE
      IF( WANTP ) THEN
!
!        Solve generalized Sylvester equation for R and L
!        and compute PL and PR.
!
         N1 = M
         N2 = N - M
         I = N1 + 1
         IJB = 0
         CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
         CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), &
                      N1 )
         CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, &
                      N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, &
                      DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), &
                      LWORK-2*N1*N2, IWORK, IERR )
!
!        Estimate the reciprocal of norms of "projections" onto left
!        and right eigenspaces.
!
         RDSCAL = ZERO
         DSUM = ONE
         CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
         PL = RDSCAL*SQRT( DSUM )
         IF( PL.EQ.ZERO ) THEN
            PL = ONE
         ELSE
            PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
         END IF
         RDSCAL = ZERO
         DSUM = ONE
         CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
         PR = RDSCAL*SQRT( DSUM )
         IF( PR.EQ.ZERO ) THEN
            PR = ONE
         ELSE
            PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
         END IF
      END IF
!
      IF( WANTD ) THEN
!
!        Compute estimates of Difu and Difl.
!
         IF( WANTD1 ) THEN
            N1 = M
            N2 = N - M
            I = N1 + 1
            IJB = IDIFJB
!
!           Frobenius norm-based Difu-estimate.
!
            CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, &
                         N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), &
                         N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ), &
                         LWORK-2*N1*N2, IWORK, IERR )
!
!           Frobenius norm-based Difl-estimate.
!
            CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, &
                         N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), &
                         N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ), &
                         LWORK-2*N1*N2, IWORK, IERR )
         ELSE
!
!
!           Compute 1-norm-based estimates of Difu and Difl using
!           reversed communication with DLACON. In each step a
!           generalized Sylvester equation or a transposed variant
!           is solved.
!
            KASE = 0
            N1 = M
            N2 = N - M
            I = N1 + 1
            IJB = 0
            MN2 = 2*N1*N2
!
!           1-norm-based estimate of Difu.
!
   40       CONTINUE
            CALL DLACON( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ), &
                         KASE )
            IF( KASE.NE.0 ) THEN
               IF( KASE.EQ.1 ) THEN
!
!                 Solve generalized Sylvester equation.
!
                  CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, &
                               WORK, N1, B, LDB, B( I, I ), LDB, &
                               WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), &
                               WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, &
                               IERR )
               ELSE
!
!                 Solve the transposed variant.
!
                  CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA, &
                               WORK, N1, B, LDB, B( I, I ), LDB, &
                               WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), &
                               WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, &
                               IERR )
               END IF
               GO TO 40
            END IF
            DIF( 1 ) = DSCALE / DIF( 1 )
!
!           1-norm-based estimate of Difl.
!
   50       CONTINUE
            CALL DLACON( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ), &
                         KASE )
            IF( KASE.NE.0 ) THEN
               IF( KASE.EQ.1 ) THEN
!
!                 Solve generalized Sylvester equation.
!
                  CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, &
                               WORK, N2, B( I, I ), LDB, B, LDB, &
                               WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), &
                               WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, &
                               IERR )
               ELSE
!
!                 Solve the transposed variant.
!
                  CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA, &
                               WORK, N2, B( I, I ), LDB, B, LDB, &
                               WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), &
                               WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK, &
                               IERR )
               END IF
               GO TO 50
            END IF
            DIF( 2 ) = DSCALE / DIF( 2 )
!
         END IF
      END IF
!
   60 CONTINUE
!
!     Compute generalized eigenvalues of reordered pair (A, B) and
!     normalize the generalized Schur form.
!
      PAIR = .FALSE.
      DO 80 K = 1, N
         IF( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
!
            IF( K.LT.N ) THEN
               IF( A( K+1, K ).NE.ZERO ) THEN
                  PAIR = .TRUE.
               END IF
            END IF
!
            IF( PAIR ) THEN
!
!             Compute the eigenvalue(s) at position K.
!
               WORK( 1 ) = A( K, K )
               WORK( 2 ) = A( K+1, K )
               WORK( 3 ) = A( K, K+1 )
               WORK( 4 ) = A( K+1, K+1 )
               WORK( 5 ) = B( K, K )
               WORK( 6 ) = B( K+1, K )
               WORK( 7 ) = B( K, K+1 )
               WORK( 8 ) = B( K+1, K+1 )
               CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ), &
                           BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ), &
                           ALPHAI( K ) )
               ALPHAI( K+1 ) = -ALPHAI( K )
!
            ELSE
!
               IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
!
!                 If B(K,K) is negative, make it positive
!
                  DO 70 I = 1, N
                     A( K, I ) = -A( K, I )
                     B( K, I ) = -B( K, I )
                     Q( I, K ) = -Q( I, K )
   70             CONTINUE
               END IF
!
               ALPHAR( K ) = A( K, K )
               ALPHAI( K ) = ZERO
               BETA( K ) = B( K, K )
!
            END IF
         END IF
   80 CONTINUE
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DTGSEN
!
      END
      SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, &
                         LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, &
                         Q, LDQ, WORK, NCYCLE, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          JOBQ, JOBU, JOBV
      INTEGER            INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, &
                         NCYCLE, P
      DOUBLE PRECISION   TOLA, TOLB
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHA( * ), B( LDB, * ), &
                         BETA( * ), Q( LDQ, * ), U( LDU, * ), &
                         V( LDV, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTGSJA computes the generalized singular value decomposition (GSVD)
!  of two real upper triangular (or trapezoidal) matrices A and B.
!
!  On entry, it is assumed that matrices A and B have the following
!  forms, which may be obtained by the preprocessing subroutine DGGSVP
!  from a general M-by-N matrix A and P-by-N matrix B:
!
!               N-K-L  K    L
!     A =    K ( 0    A12  A13 ) if M-K-L >= 0;
!            L ( 0     0   A23 )
!        M-K-L ( 0     0    0  )
!
!             N-K-L  K    L
!     A =  K ( 0    A12  A13 ) if M-K-L < 0;
!        M-K ( 0     0   A23 )
!
!             N-K-L  K    L
!     B =  L ( 0     0   B13 )
!        P-L ( 0     0    0  )
!
!  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
!  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
!  otherwise A23 is (M-K)-by-L upper trapezoidal.
!
!  On exit,
!
!              U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),
!
!  where U, V and Q are orthogonal matrices, Z' denotes the transpose
!  of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
!  ``diagonal'' matrices, which are of the following structures:
!
!  If M-K-L >= 0,
!
!                      K  L
!         D1 =     K ( I  0 )
!                  L ( 0  C )
!              M-K-L ( 0  0 )
!
!                    K  L
!         D2 = L   ( 0  S )
!              P-L ( 0  0 )
!
!                 N-K-L  K    L
!    ( 0 R ) = K (  0   R11  R12 ) K
!              L (  0    0   R22 ) L
!
!  where
!
!    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
!    S = diag( BETA(K+1),  ... , BETA(K+L) ),
!    C**2 + S**2 = I.
!
!    R is stored in A(1:K+L,N-K-L+1:N) on exit.
!
!  If M-K-L < 0,
!
!                 K M-K K+L-M
!      D1 =   K ( I  0    0   )
!           M-K ( 0  C    0   )
!
!                   K M-K K+L-M
!      D2 =   M-K ( 0  S    0   )
!           K+L-M ( 0  0    I   )
!             P-L ( 0  0    0   )
!
!                 N-K-L  K   M-K  K+L-M
! ( 0 R ) =    K ( 0    R11  R12  R13  )
!            M-K ( 0     0   R22  R23  )
!          K+L-M ( 0     0    0   R33  )
!
!  where
!  C = diag( ALPHA(K+1), ... , ALPHA(M) ),
!  S = diag( BETA(K+1),  ... , BETA(M) ),
!  C**2 + S**2 = I.
!
!  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
!      (  0  R22 R23 )
!  in B(M-K+1:L,N+M-K-L+1:N) on exit.
!
!  The computation of the orthogonal transformation matrices U, V or Q
!  is optional.  These matrices may either be formed explicitly, or they
!  may be postmultiplied into input matrices U1, V1, or Q1.
!
!  Arguments
!  =========
!
!  JOBU    (input) CHARACTER*1
!          = 'U':  U must contain an orthogonal matrix U1 on entry, and
!                  the product U1*U is returned;
!          = 'I':  U is initialized to the unit matrix, and the
!                  orthogonal matrix U is returned;
!          = 'N':  U is not computed.
!
!  JOBV    (input) CHARACTER*1
!          = 'V':  V must contain an orthogonal matrix V1 on entry, and
!                  the product V1*V is returned;
!          = 'I':  V is initialized to the unit matrix, and the
!                  orthogonal matrix V is returned;
!          = 'N':  V is not computed.
!
!  JOBQ    (input) CHARACTER*1
!          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and
!                  the product Q1*Q is returned;
!          = 'I':  Q is initialized to the unit matrix, and the
!                  orthogonal matrix Q is returned;
!          = 'N':  Q is not computed.
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  P       (input) INTEGER
!          The number of rows of the matrix B.  P >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrices A and B.  N >= 0.
!
!  K       (input) INTEGER
!  L       (input) INTEGER
!          K and L specify the subblocks in the input matrices A and B:
!          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
!          of A and B, whose GSVD is going to be computed by DTGSJA.
!          See Further details.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix A.
!          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
!          matrix R or part of R.  See Purpose for details.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
!          On entry, the P-by-N matrix B.
!          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
!          a part of R.  See Purpose for details.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,P).
!
!  TOLA    (input) DOUBLE PRECISION
!  TOLB    (input) DOUBLE PRECISION
!          TOLA and TOLB are the convergence criteria for the Jacobi-
!          Kogbetliantz iteration procedure. Generally, they are the
!          same as used in the preprocessing step, say
!              TOLA = max(M,N)*norm(A)*MAZHEPS,
!              TOLB = max(P,N)*norm(B)*MAZHEPS.
!
!  ALPHA   (output) DOUBLE PRECISION array, dimension (N)
!  BETA    (output) DOUBLE PRECISION array, dimension (N)
!          On exit, ALPHA and BETA contain the generalized singular
!          value pairs of A and B;
!            ALPHA(1:K) = 1,
!            BETA(1:K)  = 0,
!          and if M-K-L >= 0,
!            ALPHA(K+1:K+L) = diag(C),
!            BETA(K+1:K+L)  = diag(S),
!          or if M-K-L < 0,
!            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
!            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
!          Furthermore, if K+L < N,
!            ALPHA(K+L+1:N) = 0 and
!            BETA(K+L+1:N)  = 0.
!
!  U       (input/output) DOUBLE PRECISION array, dimension (LDU,M)
!          On entry, if JOBU = 'U', U must contain a matrix U1 (usually
!          the orthogonal matrix returned by DGGSVP).
!          On exit,
!          if JOBU = 'I', U contains the orthogonal matrix U;
!          if JOBU = 'U', U contains the product U1*U.
!          If JOBU = 'N', U is not referenced.
!
!  LDU     (input) INTEGER
!          The leading dimension of the array U. LDU >= max(1,M) if
!          JOBU = 'U'; LDU >= 1 otherwise.
!
!  V       (input/output) DOUBLE PRECISION array, dimension (LDV,P)
!          On entry, if JOBV = 'V', V must contain a matrix V1 (usually
!          the orthogonal matrix returned by DGGSVP).
!          On exit,
!          if JOBV = 'I', V contains the orthogonal matrix V;
!          if JOBV = 'V', V contains the product V1*V.
!          If JOBV = 'N', V is not referenced.
!
!  LDV     (input) INTEGER
!          The leading dimension of the array V. LDV >= max(1,P) if
!          JOBV = 'V'; LDV >= 1 otherwise.
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
!          the orthogonal matrix returned by DGGSVP).
!          On exit,
!          if JOBQ = 'I', Q contains the orthogonal matrix Q;
!          if JOBQ = 'Q', Q contains the product Q1*Q.
!          If JOBQ = 'N', Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q. LDQ >= max(1,N) if
!          JOBQ = 'Q'; LDQ >= 1 otherwise.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
!
!  NCYCLE  (output) INTEGER
!          The number of cycles required for convergence.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value.
!          = 1:  the procedure does not converge after MAXIT cycles.
!
!  Internal Parameters
!  ===================
!
!  MAXIT   INTEGER
!          MAXIT specifies the total loops that the iterative procedure
!          may take. If after MAXIT cycles, the routine fails to
!          converge, we return INFO = 1.
!
!  Further Details
!  ===============
!
!  DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
!  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
!  matrix B13 to the form:
!
!           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
!
!  where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
!  of Z.  C1 and S1 are diagonal matrices satisfying
!
!                C1**2 + S1**2 = I,
!
!  and R1 is an L-by-L nonsingular upper triangular matrix.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 40 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
!
      LOGICAL            INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
      INTEGER            I, J, KCYCLE
      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR, &
                         GAMMA, RWK, SNQ, SNU, SNV, SSMIN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT, &
                         DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      INITU = LSAME( JOBU, 'I' )
      WANTU = INITU .OR. LSAME( JOBU, 'U' )
!
      INITV = LSAME( JOBV, 'I' )
      WANTV = INITV .OR. LSAME( JOBV, 'V' )
!
      INITQ = LSAME( JOBQ, 'I' )
      WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
!
      INFO = 0
      IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
         INFO = -18
      ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
         INFO = -20
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -22
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSJA', -INFO )
         RETURN
      END IF
!
!     Initialize U, V and Q, if necessary
!
      IF( INITU ) &
         CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU )
      IF( INITV ) &
         CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV )
      IF( INITQ ) &
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
!
!     Loop until convergence
!
      UPPER = .FALSE.
      DO 40 KCYCLE = 1, MAXIT
!
         UPPER = .NOT.UPPER
!
         DO 20 I = 1, L - 1
            DO 10 J = I + 1, L
!
               A1 = ZERO
               A2 = ZERO
               A3 = ZERO
               IF( K+I.LE.M ) &
                  A1 = A( K+I, N-L+I )
               IF( K+J.LE.M ) &
                  A3 = A( K+J, N-L+J )
!
               B1 = B( I, N-L+I )
               B3 = B( J, N-L+J )
!
               IF( UPPER ) THEN
                  IF( K+I.LE.M ) &
                     A2 = A( K+I, N-L+J )
                  B2 = B( I, N-L+J )
               ELSE
                  IF( K+J.LE.M ) &
                     A2 = A( K+J, N-L+I )
                  B2 = B( J, N-L+I )
               END IF
!
               CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, &
                            CSV, SNV, CSQ, SNQ )
!
!              Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
!
               IF( K+J.LE.M ) &
                  CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ), &
                             LDA, CSU, SNU )
!
!              Update I-th and J-th rows of matrix B: V'*B
!
               CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB, &
                          CSV, SNV )
!
!              Update (N-L+I)-th and (N-L+J)-th columns of matrices
!              A and B: A*Q and B*Q
!
               CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1, &
                          A( 1, N-L+I ), 1, CSQ, SNQ )
!
               CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ, &
                          SNQ )
!
               IF( UPPER ) THEN
                  IF( K+I.LE.M ) &
                     A( K+I, N-L+J ) = ZERO
                  B( I, N-L+J ) = ZERO
               ELSE
                  IF( K+J.LE.M ) &
                     A( K+J, N-L+I ) = ZERO
                  B( J, N-L+I ) = ZERO
               END IF
!
!              Update orthogonal matrices U, V, Q, if desired.
!
               IF( WANTU .AND. K+J.LE.M ) &
                  CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU, &
                             SNU )
!
               IF( WANTV ) &
                  CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
!
               IF( WANTQ ) &
                  CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ, &
                             SNQ )
!
   10       CONTINUE
   20    CONTINUE
!
         IF( .NOT.UPPER ) THEN
!
!           The matrices A13 and B13 were lower triangular at the start
!           of the cycle, and are now upper triangular.
!
!           Convergence test: test the parallelism of the corresponding
!           rows of A and B.
!
            ERROR = ZERO
            DO 30 I = 1, MIN( L, M-K )
               CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
               CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
               CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
               ERROR = MAX( ERROR, SSMIN )
   30       CONTINUE
!
            IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) ) &
               GO TO 50
         END IF
!
!        End of cycle loop
!
   40 CONTINUE
!
!     The algorithm has not converged after MAXIT cycles.
!
      INFO = 1
      GO TO 100
!
   50 CONTINUE
!
!     If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
!     Compute the generalized singular value pairs (ALPHA, BETA), and
!     set the triangular matrix R to array A.
!
      DO 60 I = 1, K
         ALPHA( I ) = ONE
         BETA( I ) = ZERO
   60 CONTINUE
!
      DO 70 I = 1, MIN( L, M-K )
!
         A1 = A( K+I, N-L+I )
         B1 = B( I, N-L+I )
!
         IF( A1.NE.ZERO ) THEN
            GAMMA = B1 / A1
!
!           change sign if necessary
!
            IF( GAMMA.LT.ZERO ) THEN
               CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
               IF( WANTV ) &
                  CALL DSCAL( P, -ONE, V( 1, I ), 1 )
            END IF
!
            CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ), &
                         RWK )
!
            IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
               CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ), &
                           LDA )
            ELSE
               CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ), &
                           LDB )
               CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), &
                           LDA )
            END IF
!
         ELSE
!
            ALPHA( K+I ) = ZERO
            BETA( K+I ) = ONE
            CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ), &
                        LDA )
!
         END IF
!
   70 CONTINUE
!
!     Post-assignment
!
      DO 80 I = M + 1, K + L
         ALPHA( I ) = ZERO
         BETA( I ) = ONE
   80 CONTINUE
!
      IF( K+L.LT.N ) THEN
         DO 90 I = K + L + 1, N
            ALPHA( I ) = ZERO
            BETA( I ) = ZERO
   90    CONTINUE
      END IF
!
  100 CONTINUE
      NCYCLE = KCYCLE
      RETURN
!
!     End of DTGSJA
!
      END
      SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, &
                         LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          HOWMNY, JOB
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), &
                         VL( LDVL, * ), VR( LDVR, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTGSNA estimates reciprocal condition numbers for specified
!  eigenvalues and/or eigenvectors of a matrix pair (A, B) in
!  generalized real Schur canonical form (or of any matrix pair
!  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
!  Z' denotes the transpose of Z.
!
!  (A, B) must be in generalized real Schur form (as returned by DGGES),
!  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
!  blocks. B is upper triangular.
!
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies whether condition numbers are required for
!          eigenvalues (S) or eigenvectors (DIF):
!          = 'E': for eigenvalues only (S);
!          = 'V': for eigenvectors only (DIF);
!          = 'B': for both eigenvalues and eigenvectors (S and DIF).
!
!  HOWMNY  (input) CHARACTER*1
!          = 'A': compute condition numbers for all eigenpairs;
!          = 'S': compute condition numbers for selected eigenpairs
!                 specified by the array SELECT.
!
!  SELECT  (input) LOGICAL array, dimension (N)
!          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
!          condition numbers are required. To select condition numbers
!          for the eigenpair corresponding to a real eigenvalue w(j),
!          SELECT(j) must be set to .TRUE.. To select condition numbers
!          corresponding to a complex conjugate pair of eigenvalues w(j)
!          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
!          set to .TRUE..
!          If HOWMNY = 'A', SELECT is not referenced.
!
!  N       (input) INTEGER
!          The order of the square matrix pair (A, B). N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The upper quasi-triangular matrix A in the pair (A,B).
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
!          The upper triangular matrix B in the pair (A,B).
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)
!          If JOB = 'E' or 'B', VL must contain left eigenvectors of
!          (A, B), corresponding to the eigenpairs specified by HOWMNY
!          and SELECT. The eigenvectors must be stored in consecutive
!          columns of VL, as returned by DTGEVC.
!          If JOB = 'V', VL is not referenced.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL. LDVL >= 1.
!          If JOB = 'E' or 'B', LDVL >= N.
!
!  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)
!          If JOB = 'E' or 'B', VR must contain right eigenvectors of
!          (A, B), corresponding to the eigenpairs specified by HOWMNY
!          and SELECT. The eigenvectors must be stored in consecutive
!          columns ov VR, as returned by DTGEVC.
!          If JOB = 'V', VR is not referenced.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR. LDVR >= 1.
!          If JOB = 'E' or 'B', LDVR >= N.
!
!  S       (output) DOUBLE PRECISION array, dimension (MM)
!          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!          selected eigenvalues, stored in consecutive elements of the
!          array. For a complex conjugate pair of eigenvalues two
!          consecutive elements of S are set to the same value. Thus
!          S(j), DIF(j), and the j-th columns of VL and VR all
!          correspond to the same eigenpair (but not in general the
!          j-th eigenpair, unless all eigenpairs are selected).
!          If JOB = 'V', S is not referenced.
!
!  DIF     (output) DOUBLE PRECISION array, dimension (MM)
!          If JOB = 'V' or 'B', the estimated reciprocal condition
!          numbers of the selected eigenvectors, stored in consecutive
!          elements of the array. For a complex eigenvector two
!          consecutive elements of DIF are set to the same value. If
!          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
!          is set to 0; this can only occur when the true value would be
!          very small anyway.
!          If JOB = 'E', DIF is not referenced.
!
!  MM      (input) INTEGER
!          The number of elements in the arrays S and DIF. MM >= M.
!
!  M       (output) INTEGER
!          The number of elements of the arrays S and DIF used to store
!          the specified condition numbers; for each selected real
!          eigenvalue one element is used, and for each selected complex
!          conjugate pair of eigenvalues, two elements are used.
!          If HOWMNY = 'A', M is set to N.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          If JOB = 'E', WORK is not referenced.  Otherwise,
!          on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK >= N.
!          If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (N + 6)
!          If JOB = 'E', IWORK is not referenced.
!
!  INFO    (output) INTEGER
!          =0: Successful exit
!          <0: If INFO = -i, the i-th argument had an illegal value
!
!
!  Further Details
!  ===============
!
!  The reciprocal of the condition number of a generalized eigenvalue
!  w = (a, b) is defined as
!
!       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
!
!  where u and v are the left and right eigenvectors of (A, B)
!  corresponding to w; |z| denotes the absolute value of the complex
!  number, and norm(u) denotes the 2-norm of the vector u.
!  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
!  of the matrix pair (A, B). If both a and b equal zero, then (A B) is
!  singular and S(I) = -1 is returned.
!
!  An approximate error bound on the chordal distance between the i-th
!  computed generalized eigenvalue w and the corresponding exact
!  eigenvalue lambda is
!
!       chord(w, lambda) <= EPS * norm(A, B) / S(I)
!
!  where EPS is the machine precision.
!
!  The reciprocal of the condition number DIF(i) of right eigenvector u
!  and left eigenvector v corresponding to the generalized eigenvalue w
!  is defined as follows:
!
!  a) If the i-th eigenvalue w = (a,b) is real
!
!     Suppose U and V are orthogonal transformations such that
!
!                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1
!                                        ( 0  S22 ),( 0 T22 )  n-1
!                                          1  n-1     1 n-1
!
!     Then the reciprocal condition number DIF(i) is
!
!                Difl((a, b), (S22, T22)) = sigma-min( Zl ),
!
!     where sigma-min(Zl) denotes the smallest singular value of the
!     2(n-1)-by-2(n-1) matrix
!
!         Zl = [ kron(a, In-1)  -kron(1, S22) ]
!              [ kron(b, In-1)  -kron(1, T22) ] .
!
!     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
!     Kronecker product between the matrices X and Y.
!
!     Note that if the default method for computing DIF(i) is wanted
!     (see DLATDF), then the parameter DIFDRI (see below) should be
!     changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
!     See DTGSYL for more details.
!
!  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
!
!     Suppose U and V are orthogonal transformations such that
!
!                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2
!                                       ( 0    S22 ),( 0    T22) n-2
!                                         2    n-2     2    n-2
!
!     and (S11, T11) corresponds to the complex conjugate eigenvalue
!     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
!     that
!
!         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )
!                      (  0  s22 )                    (  0  t22 )
!
!     where the generalized eigenvalues w = s11/t11 and
!     conjg(w) = s22/t22.
!
!     Then the reciprocal condition number DIF(i) is bounded by
!
!         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
!
!     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
!     Z1 is the complex 2-by-2 matrix
!
!              Z1 =  [ s11  -s22 ]
!                    [ t11  -t22 ],
!
!     This is done by computing (using real arithmetic) the
!     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
!     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
!     the determinant of X.
!
!     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
!     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
!
!              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]
!                   [ kron(T11', In-2)  -kron(I2, T22) ]
!
!     Note that if the default method for computing DIF is wanted (see
!     DLATDF), then the parameter DIFDRI (see below) should be changed
!     from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
!     for more details.
!
!  For each eigenvalue/vector specified by SELECT, DIF stores a
!  Frobenius norm-based estimate of Difl.
!
!  An approximate error bound for the i-th computed eigenvector VL(i) or
!  VR(i) is given by
!
!             EPS * norm(A, B) / DIF(i).
!
!  See ref. [2-3] for more details and further references.
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  References
!  ==========
!
!  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
!      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
!      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
!      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
!
!  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
!      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
!      Estimation: Theory, Algorithms and Software,
!      Report UMINF - 94.04, Department of Computing Science, Umea
!      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
!      Note 87. To appear in Numerical Algorithms, 1996.
!
!  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
!      for Solving the Generalized Sylvester Equation and Estimating the
!      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
!      Department of Computing Science, Umea University, S-901 87 Umea,
!      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
!      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
!      No 1, 1996.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            DIFDRI
      PARAMETER          ( DIFDRI = 3 )
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, &
                         FOUR = 4.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
      INTEGER            I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
      DOUBLE PRECISION   ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND, &
                         EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM, &
                         TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV, &
                         UHBVI
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DUMMY( 1 ), DUMMY1( 1 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2, DNRM2
      EXTERNAL           LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
!
      SOMCON = LSAME( HOWMNY, 'S' )
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
!
      IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
         LWMIN = MAX( 1, 2*N*( N+2 )+16 )
      ELSE
         LWMIN = 1
      END IF
!
      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
         INFO = -10
      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
         INFO = -12
      ELSE
!
!        Set M to the number of eigenpairs for which condition numbers
!        are required, and test MM.
!
         IF( SOMCON ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 K = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
               ELSE
                  IF( K.LT.N ) THEN
                     IF( A( K+1, K ).EQ.ZERO ) THEN
                        IF( SELECT( K ) ) &
                           M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( K ) .OR. SELECT( K+1 ) ) &
                           M = M + 2
                     END IF
                  ELSE
                     IF( SELECT( N ) ) &
                        M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
!
         IF( MM.LT.M ) THEN
            INFO = -15
         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -18
!        ELSE IF( WANTDF .AND. LWORK.LT.2*N*( N+2 )+16 ) THEN
!           INFO = -18
         END IF
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSNA', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      KS = 0
      PAIR = .FALSE.
!
      DO 20 K = 1, N
!
!        Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
!
         IF( PAIR ) THEN
            PAIR = .FALSE.
            GO TO 20
         ELSE
            IF( K.LT.N ) &
               PAIR = A( K+1, K ).NE.ZERO
         END IF
!
!        Determine whether condition numbers are required for the k-th
!        eigenpair.
!
         IF( SOMCON ) THEN
            IF( PAIR ) THEN
               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) &
                  GO TO 20
            ELSE
               IF( .NOT.SELECT( K ) ) &
                  GO TO 20
            END IF
         END IF
!
         KS = KS + 1
!
         IF( WANTS ) THEN
!
!           Compute the reciprocal condition number of the k-th
!           eigenvalue.
!
            IF( PAIR ) THEN
!
!              Complex eigenvalue pair.
!
               RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), &
                      DNRM2( N, VR( 1, KS+1 ), 1 ) )
               LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), &
                      DNRM2( N, VL( 1, KS+1 ), 1 ) )
               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, &
                           WORK, 1 )
               TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1, &
                           ZERO, WORK, 1 )
               TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               UHAV = TMPRR + TMPII
               UHAVI = TMPIR - TMPRI
               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, &
                           WORK, 1 )
               TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1, &
                           ZERO, WORK, 1 )
               TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               UHBV = TMPRR + TMPII
               UHBVI = TMPIR - TMPRI
               UHAV = DLAPY2( UHAV, UHAVI )
               UHBV = DLAPY2( UHBV, UHBVI )
               COND = DLAPY2( UHAV, UHBV )
               S( KS ) = COND / ( RNRM*LNRM )
               S( KS+1 ) = S( KS )
!
            ELSE
!
!              Real eigenvalue.
!
               RNRM = DNRM2( N, VR( 1, KS ), 1 )
               LNRM = DNRM2( N, VL( 1, KS ), 1 )
               CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO, &
                           WORK, 1 )
               UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO, &
                           WORK, 1 )
               UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
               COND = DLAPY2( UHAV, UHBV )
               IF( COND.EQ.ZERO ) THEN
                  S( KS ) = -ONE
               ELSE
                  S( KS ) = COND / ( RNRM*LNRM )
               END IF
            END IF
         END IF
!
         IF( WANTDF ) THEN
            IF( N.EQ.1 ) THEN
               DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) )
               GO TO 20
            END IF
!
!           Estimate the reciprocal condition number of the k-th
!           eigenvectors.
            IF( PAIR ) THEN
!
!              Copy the  2-by 2 pencil beginning at (A(k,k), B(k, k)).
!              Compute the eigenvalue(s) at position K.
!
               WORK( 1 ) = A( K, K )
               WORK( 2 ) = A( K+1, K )
               WORK( 3 ) = A( K, K+1 )
               WORK( 4 ) = A( K+1, K+1 )
               WORK( 5 ) = B( K, K )
               WORK( 6 ) = B( K+1, K )
               WORK( 7 ) = B( K, K+1 )
               WORK( 8 ) = B( K+1, K+1 )
               CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA, &
                           DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
               ALPRQT = ONE
               C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
               C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
               ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 )
               ROOT2 = C2 / ROOT1
               ROOT1 = ROOT1 / TWO
               COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
            END IF
!
!           Copy the matrix (A, B) to the array WORK and swap the
!           diagonal block beginning at A(k,k) to the (1,1) position.
!
            CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
            CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
            IFST = K
            ILST = 1
!
            CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N, &
                         DUMMY, 1, DUMMY1, 1, IFST, ILST, &
                         WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
!
            IF( IERR.GT.0 ) THEN
!
!              Ill-conditioned problem - swap rejected.
!
               DIF( KS ) = ZERO
            ELSE
!
!              Reordering successful, solve generalized Sylvester
!              equation for R and L,
!                         A22 * R - L * A11 = A12
!                         B22 * R - L * B11 = B12,
!              and compute estimate of Difl((A11,B11), (A22, B22)).
!
               N1 = 1
               IF( WORK( 2 ).NE.ZERO ) &
                  N1 = 2
               N2 = N - N1
               IF( N2.EQ.0 ) THEN
                  DIF( KS ) = COND
               ELSE
                  I = N*N + 1
                  IZ = 2*N*N + 1
                  CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ), &
                               N, WORK, N, WORK( N1+1 ), N, &
                               WORK( N*N1+N1+I ), N, WORK( I ), N, &
                               WORK( N1+I ), N, SCALE, DIF( KS ), &
                               WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
!
                  IF( PAIR ) &
                     DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ), &
                                 COND )
               END IF
            END IF
            IF( PAIR ) &
               DIF( KS+1 ) = DIF( KS )
         END IF
         IF( PAIR ) &
            KS = KS + 1
!
   20 CONTINUE
      WORK( 1 ) = LWMIN
      RETURN
!
!     End of DTGSNA
!
      END
      SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, &
                         LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, &
                         IWORK, PQ, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, &
                         PQ
      DOUBLE PRECISION   RDSCAL, RDSUM, SCALE
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ), &
                         D( LDD, * ), E( LDE, * ), F( LDF, * )
!     ..
!
!  Purpose
!  =======
!
!  DTGSY2 solves the generalized Sylvester equation:
!
!              A * R - L * B = scale * C                (1)
!              D * R - L * E = scale * F,
!
!  using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
!  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
!  N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
!  must be in generalized Schur canonical form, i.e. A, B are upper
!  quasi triangular and D, E are upper triangular. The solution (R, L)
!  overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
!  chosen to avoid overflow.
!
!  In matrix notation solving equation (1) corresponds to solve
!  Z*x = scale*b, where Z is defined as
!
!         Z = [ kron(In, A)  -kron(B', Im) ]             (2)
!             [ kron(In, D)  -kron(E', Im) ],
!
!  Ik is the identity matrix of size k and X' is the transpose of X.
!  kron(X, Y) is the Kronecker product between the matrices X and Y.
!  In the process of solving (1), we solve a number of such systems
!  where Dim(In), Dim(In) = 1 or 2.
!
!  If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
!  which is equivalent to solve for R and L in
!
!              A' * R  + D' * L   = scale *  C           (3)
!              R  * B' + L  * E'  = scale * -F
!
!  This case is used to compute an estimate of Dif[(A, D), (B, E)] =
!  sigma_min(Z) using reverse communicaton with DLACON.
!
!  DTGSY2 also (IJOB >= 1) contributes to the computation in STGSYL
!  of an upper bound on the separation between to matrix pairs. Then
!  the input (A, D), (B, E) are sub-pencils of the matrix pair in
!  DTGSYL. See STGSYL for details.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER
!          = 'N', solve the generalized Sylvester equation (1).
!          = 'T': solve the 'transposed' system (3).
!
!  IJOB    (input) INTEGER
!          Specifies what kind of functionality to be performed.
!          = 0: solve (1) only.
!          = 1: A contribution from this subsystem to a Frobenius
!               norm-based estimate of the separation between two matrix
!               pairs is computed. (look ahead strategy is used).
!          = 2: A contribution from this subsystem to a Frobenius
!               norm-based estimate of the separation between two matrix
!               pairs is computed. (DGECON on sub-systems is used.)
!          Not referenced if TRANS = 'T'.
!
!  M       (input) INTEGER
!          On entry, M specifies the order of A and D, and the row
!          dimension of C, F, R and L.
!
!  N       (input) INTEGER
!          On entry, N specifies the order of B and E, and the column
!          dimension of C, F, R and L.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA, M)
!          On entry, A contains an upper quasi triangular matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the matrix A. LDA >= max(1, M).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
!          On entry, B contains an upper quasi triangular matrix.
!
!  LDB     (input) INTEGER
!          The leading dimension of the matrix B. LDB >= max(1, N).
!
!  C       (input/ output) DOUBLE PRECISION array, dimension (LDC, N)
!          On entry, C contains the right-hand-side of the first matrix
!          equation in (1).
!          On exit, if IJOB = 0, C has been overwritten by the
!          solution R.
!
!  LDC     (input) INTEGER
!          The leading dimension of the matrix C. LDC >= max(1, M).
!
!  D       (input) DOUBLE PRECISION array, dimension (LDD, M)
!          On entry, D contains an upper triangular matrix.
!
!  LDD     (input) INTEGER
!          The leading dimension of the matrix D. LDD >= max(1, M).
!
!  E       (input) DOUBLE PRECISION array, dimension (LDE, N)
!          On entry, E contains an upper triangular matrix.
!
!  LDE     (input) INTEGER
!          The leading dimension of the matrix E. LDE >= max(1, N).
!
!  F       (input/ output) DOUBLE PRECISION array, dimension (LDF, N)
!          On entry, F contains the right-hand-side of the second matrix
!          equation in (1).
!          On exit, if IJOB = 0, F has been overwritten by the
!          solution L.
!
!  LDF     (input) INTEGER
!          The leading dimension of the matrix F. LDF >= max(1, M).
!
!  SCALE   (output) DOUBLE PRECISION
!          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
!          R and L (C and F on entry) will hold the solutions to a
!          slightly perturbed system but the input matrices A, B, D and
!          E have not been changed. If SCALE = 0, R and L will hold the
!          solutions to the homogeneous system with C = F = 0. Normally,
!          SCALE = 1.
!
!  RDSUM   (input/output) DOUBLE PRECISION
!          On entry, the sum of squares of computed contributions to
!          the Dif-estimate under computation by DTGSYL, where the
!          scaling factor RDSCAL (see below) has been factored out.
!          On exit, the corresponding sum of squares updated with the
!          contributions from the current sub-system.
!          If TRANS = 'T' RDSUM is not touched.
!          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
!
!  RDSCAL  (input/output) DOUBLE PRECISION
!          On entry, scaling factor used to prevent overflow in RDSUM.
!          On exit, RDSCAL is updated w.r.t. the current contributions
!          in RDSUM.
!          If TRANS = 'T', RDSCAL is not touched.
!          NOTE: RDSCAL only makes sense when DTGSY2 is called by
!                DTGSYL.
!
!  IWORK   (workspace) INTEGER array, dimension (M+N+2)
!
!  PQ      (output) INTEGER
!          On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
!          8-by-8) solved by this routine.
!
!  INFO    (output) INTEGER
!          On exit, if INFO is set to
!            =0: Successful exit
!            <0: If INFO = -i, the i-th argument had an illegal value.
!            >0: The matrix pairs (A, D) and (B, E) have common or very
!                close eigenvalues.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            LDZ
      PARAMETER          ( LDZ = 8 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
      INTEGER            I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, &
                         K, MB, NB, P, Q, ZDIM
      DOUBLE PRECISION   ALPHA, SCALOC
!     ..
!     .. Local Arrays ..
      INTEGER            IPIV( LDZ ), JPIV( LDZ )
      DOUBLE PRECISION   RHS( LDZ ), Z( LDZ, LDZ )
      double precision zero_vec(1)
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, &
                         DGETC2, DLATDF, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
      zero_vec(1) = 0.0D+00
!
!     Decode and test input parameters
!
      INFO = 0
      IERR = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -1
      ELSE IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
         INFO = -2
      ELSE IF( M.LE.0 ) THEN
         INFO = -3
      ELSE IF( N.LE.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSY2', -INFO )
         RETURN
      END IF
!
!     Determine block structure of A
!
      PQ = 0
      P = 0
      I = 1
   10 CONTINUE
      IF( I.GT.M ) &
         GO TO 20
      P = P + 1
      IWORK( P ) = I
      IF( I.EQ.M ) &
         GO TO 20
      IF( A( I+1, I ).NE.ZERO ) THEN
         I = I + 2
      ELSE
         I = I + 1
      END IF
      GO TO 10
   20 CONTINUE
      IWORK( P+1 ) = M + 1
!
!     Determine block structure of B
!
      Q = P + 1
      J = 1
   30 CONTINUE
      IF( J.GT.N ) &
         GO TO 40
      Q = Q + 1
      IWORK( Q ) = J
      IF( J.EQ.N ) &
         GO TO 40
      IF( B( J+1, J ).NE.ZERO ) THEN
         J = J + 2
      ELSE
         J = J + 1
      END IF
      GO TO 30
   40 CONTINUE
      IWORK( Q+1 ) = N + 1
      PQ = P*( Q-P-1 )
!
      IF( NOTRAN ) THEN
!
!        Solve (I, J) - subsystem
!           A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
!           D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
!        for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
!
         SCALE = ONE
         SCALOC = ONE
         DO 120 J = P + 2, Q
            JS = IWORK( J )
            JSP1 = JS + 1
            JE = IWORK( J+1 ) - 1
            NB = JE - JS + 1
            DO 110 I = P, 1, -1
!
               IS = IWORK( I )
               ISP1 = IS + 1
               IE = IWORK( I+1 ) - 1
               MB = IE - IS + 1
               ZDIM = MB*NB*2
!
               IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
!
!                 Build a 2-by-2 system Z * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = D( IS, IS )
                  Z( 1, 2 ) = -B( JS, JS )
                  Z( 2, 2 ) = -E( JS, JS )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = F( IS, JS )
!
!                 Solve Z * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
!
                  IF( IJOB.EQ.0 ) THEN
                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, &
                                  SCALOC )
                     IF( SCALOC.NE.ONE ) THEN
                        DO K = 1, N
                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
                        end do
                        SCALE = SCALE*SCALOC
                     END IF
                  ELSE
                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, &
                                  RDSCAL, IPIV, JPIV )
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  F( IS, JS ) = RHS( 2 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( I.GT.1 ) THEN
                     ALPHA = -RHS( 1 )
                     CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), &
                                 1 )
                     CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), &
                                 1 )
                  END IF
                  IF( J.LT.Q ) THEN
                     CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, &
                                 C( IS, JE+1 ), LDC )
                     CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, &
                                 F( IS, JE+1 ), LDF )
                  END IF
!
               ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
!
!                 Build a 4-by-4 system Z * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = ZERO
                  Z( 3, 1 ) = D( IS, IS )
                  Z( 4, 1 ) = ZERO
!
                  Z( 1, 2 ) = ZERO
                  Z( 2, 2 ) = A( IS, IS )
                  Z( 3, 2 ) = ZERO
                  Z( 4, 2 ) = D( IS, IS )
!
                  Z( 1, 3 ) = -B( JS, JS )
                  Z( 2, 3 ) = -B( JS, JSP1 )
                  Z( 3, 3 ) = -E( JS, JS )
                  Z( 4, 3 ) = -E( JS, JSP1 )
!
                  Z( 1, 4 ) = -B( JSP1, JS )
                  Z( 2, 4 ) = -B( JSP1, JSP1 )
                  Z( 3, 4 ) = ZERO
                  Z( 4, 4 ) = -E( JSP1, JSP1 )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = C( IS, JSP1 )
                  RHS( 3 ) = F( IS, JS )
                  RHS( 4 ) = F( IS, JSP1 )
!
!                 Solve Z * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
!
                  IF( IJOB.EQ.0 ) THEN
                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, &
                                  SCALOC )
                     IF( SCALOC.NE.ONE ) THEN
                        DO 60 K = 1, N
                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
   60                   CONTINUE
                        SCALE = SCALE*SCALOC
                     END IF
                  ELSE
                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, &
                                  RDSCAL, IPIV, JPIV )
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  C( IS, JSP1 ) = RHS( 2 )
                  F( IS, JS ) = RHS( 3 )
                  F( IS, JSP1 ) = RHS( 4 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( I.GT.1 ) THEN
                     CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), &
                                1, C( 1, JS ), LDC )
                     CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), &
                                1, F( 1, JS ), LDF )
                  END IF
                  IF( J.LT.Q ) THEN
                     CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, &
                                 C( IS, JE+1 ), LDC )
                     CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, &
                                 F( IS, JE+1 ), LDF )
                     CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, &
                                 C( IS, JE+1 ), LDC )
                     CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, &
                                 F( IS, JE+1 ), LDF )
                  END IF
!
               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
!
!                 Build a 4-by-4 system Z * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = A( ISP1, IS )
                  Z( 3, 1 ) = D( IS, IS )
                  Z( 4, 1 ) = ZERO
!
                  Z( 1, 2 ) = A( IS, ISP1 )
                  Z( 2, 2 ) = A( ISP1, ISP1 )
                  Z( 3, 2 ) = D( IS, ISP1 )
                  Z( 4, 2 ) = D( ISP1, ISP1 )
!
                  Z( 1, 3 ) = -B( JS, JS )
                  Z( 2, 3 ) = ZERO
                  Z( 3, 3 ) = -E( JS, JS )
                  Z( 4, 3 ) = ZERO
!
                  Z( 1, 4 ) = ZERO
                  Z( 2, 4 ) = -B( JS, JS )
                  Z( 3, 4 ) = ZERO
                  Z( 4, 4 ) = -E( JS, JS )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = C( ISP1, JS )
                  RHS( 3 ) = F( IS, JS )
                  RHS( 4 ) = F( ISP1, JS )
!
!                 Solve Z * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
                  IF( IJOB.EQ.0 ) THEN
                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, &
                                  SCALOC )
                     IF( SCALOC.NE.ONE ) THEN
                        DO 70 K = 1, N
                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
   70                   CONTINUE
                        SCALE = SCALE*SCALOC
                     END IF
                  ELSE
                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, &
                                  RDSCAL, IPIV, JPIV )
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  C( ISP1, JS ) = RHS( 2 )
                  F( IS, JS ) = RHS( 3 )
                  F( ISP1, JS ) = RHS( 4 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( I.GT.1 ) THEN
                     CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, &
                                 RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
                     CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, &
                                 RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
                  END IF
                  IF( J.LT.Q ) THEN
                     CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, &
                                B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
                     CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, &
                                E( JS, JE+1 ), LDB, F( IS, JE+1 ), LDC )
                  END IF
!
               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
!
!                 Build an 8-by-8 system Z * x = RHS
!
                  CALL DCOPY( LDZ*LDZ, zero_vec, 0, Z, 1 )
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = A( ISP1, IS )
                  Z( 5, 1 ) = D( IS, IS )
!
                  Z( 1, 2 ) = A( IS, ISP1 )
                  Z( 2, 2 ) = A( ISP1, ISP1 )
                  Z( 5, 2 ) = D( IS, ISP1 )
                  Z( 6, 2 ) = D( ISP1, ISP1 )
!
                  Z( 3, 3 ) = A( IS, IS )
                  Z( 4, 3 ) = A( ISP1, IS )
                  Z( 7, 3 ) = D( IS, IS )
!
                  Z( 3, 4 ) = A( IS, ISP1 )
                  Z( 4, 4 ) = A( ISP1, ISP1 )
                  Z( 7, 4 ) = D( IS, ISP1 )
                  Z( 8, 4 ) = D( ISP1, ISP1 )
!
                  Z( 1, 5 ) = -B( JS, JS )
                  Z( 3, 5 ) = -B( JS, JSP1 )
                  Z( 5, 5 ) = -E( JS, JS )
                  Z( 7, 5 ) = -E( JS, JSP1 )
!
                  Z( 2, 6 ) = -B( JS, JS )
                  Z( 4, 6 ) = -B( JS, JSP1 )
                  Z( 6, 6 ) = -E( JS, JS )
                  Z( 8, 6 ) = -E( JS, JSP1 )
!
                  Z( 1, 7 ) = -B( JSP1, JS )
                  Z( 3, 7 ) = -B( JSP1, JSP1 )
                  Z( 7, 7 ) = -E( JSP1, JSP1 )
!
                  Z( 2, 8 ) = -B( JSP1, JS )
                  Z( 4, 8 ) = -B( JSP1, JSP1 )
                  Z( 8, 8 ) = -E( JSP1, JSP1 )
!
!                 Set up right hand side(s)
!
                  K = 1
                  II = MB*NB + 1
                  DO 80 JJ = 0, NB - 1
                     CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
                     CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
                     K = K + MB
                     II = II + MB
   80             CONTINUE
!
!                 Solve Z * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
                  IF( IJOB.EQ.0 ) THEN
                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, &
                                  SCALOC )
                     IF( SCALOC.NE.ONE ) THEN
                        DO K = 1, N
                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
                        end do
                        SCALE = SCALE*SCALOC
                     END IF
                  ELSE
                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, &
                                  RDSCAL, IPIV, JPIV )
                  END IF
!
!                 Unpack solution vector(s)
!
                  K = 1
                  II = MB*NB + 1
                  DO 100 JJ = 0, NB - 1
                     CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
                     CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
                     K = K + MB
                     II = II + MB
  100             CONTINUE
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( I.GT.1 ) THEN
                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, &
                                 A( 1, IS ), LDA, RHS( 1 ), MB, ONE, &
                                 C( 1, JS ), LDC )
                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, &
                                 D( 1, IS ), LDD, RHS( 1 ), MB, ONE, &
                                 F( 1, JS ), LDF )
                  END IF
                  IF( J.LT.Q ) THEN
                     K = MB*NB + 1
                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), &
                                 MB, B( JS, JE+1 ), LDB, ONE, &
                                 C( IS, JE+1 ), LDC )
                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), &
                                 MB, E( JS, JE+1 ), LDE, ONE, &
                                 F( IS, JE+1 ), LDF )
                  END IF
!
               END IF
!
  110       CONTINUE
  120    CONTINUE
      ELSE
!
!        Solve (I, J) - subsystem
!             A(I, I)' * R(I, J) + D(I, I)' * L(J, J)  =  C(I, J)
!             R(I, I)  * B(J, J) + L(I, J)  * E(J, J)  = -F(I, J)
!        for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
!
         SCALE = ONE
         SCALOC = ONE
         DO 200 I = 1, P
!
            IS = IWORK( I )
            ISP1 = IS + 1
            IE = IWORK( I+1 ) - 1
            MB = IE - IS + 1
            DO 190 J = Q, P + 2, -1
!
               JS = IWORK( J )
               JSP1 = JS + 1
               JE = IWORK( J+1 ) - 1
               NB = JE - JS + 1
               ZDIM = MB*NB*2
               IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
!
!                 Build a 2-by-2 system Z' * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = -B( JS, JS )
                  Z( 1, 2 ) = D( IS, IS )
                  Z( 2, 2 ) = -E( JS, JS )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = F( IS, JS )
!
!                 Solve Z' * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
!
                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
                  IF( SCALOC.NE.ONE ) THEN
                     DO 130 K = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  130                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  F( IS, JS ) = RHS( 2 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( J.GT.P+2 ) THEN
                     ALPHA = RHS( 1 )
                     CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), &
                                 LDF )
                     ALPHA = RHS( 2 )
                     CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), &
                                 LDF )
                  END IF
                  IF( I.LT.P ) THEN
                     ALPHA = -RHS( 1 )
                     CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, &
                                 C( IE+1, JS ), 1 )
                     ALPHA = -RHS( 2 )
                     CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, &
                                 C( IE+1, JS ), 1 )
                  END IF
!
               ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
!
!                 Build a 4-by-4 system Z' * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = ZERO
                  Z( 3, 1 ) = -B( JS, JS )
                  Z( 4, 1 ) = -B( JSP1, JS )
!
                  Z( 1, 2 ) = ZERO
                  Z( 2, 2 ) = A( IS, IS )
                  Z( 3, 2 ) = -B( JS, JSP1 )
                  Z( 4, 2 ) = -B( JSP1, JSP1 )
!
                  Z( 1, 3 ) = D( IS, IS )
                  Z( 2, 3 ) = ZERO
                  Z( 3, 3 ) = -E( JS, JS )
                  Z( 4, 3 ) = ZERO
!
                  Z( 1, 4 ) = ZERO
                  Z( 2, 4 ) = D( IS, IS )
                  Z( 3, 4 ) = -E( JS, JSP1 )
                  Z( 4, 4 ) = -E( JSP1, JSP1 )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = C( IS, JSP1 )
                  RHS( 3 ) = F( IS, JS )
                  RHS( 4 ) = F( IS, JSP1 )
!
!                 Solve Z' * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
                  IF( SCALOC.NE.ONE ) THEN
                     DO 140 K = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  140                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  C( IS, JSP1 ) = RHS( 2 )
                  F( IS, JS ) = RHS( 3 )
                  F( IS, JSP1 ) = RHS( 4 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( J.GT.P+2 ) THEN
                     CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, &
                                 F( IS, 1 ), LDF )
                     CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, &
                                 F( IS, 1 ), LDF )
                     CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, &
                                 F( IS, 1 ), LDF )
                     CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, &
                                 F( IS, 1 ), LDF )
                  END IF
                  IF( I.LT.P ) THEN
                     CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, &
                                RHS( 1 ), 1, C( IE+1, JS ), LDC )
                     CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, &
                                RHS( 3 ), 1, C( IE+1, JS ), LDC )
                  END IF
!
               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
!
!                 Build a 4-by-4 system Z' * x = RHS
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = A( IS, ISP1 )
                  Z( 3, 1 ) = -B( JS, JS )
                  Z( 4, 1 ) = ZERO
!
                  Z( 1, 2 ) = A( ISP1, IS )
                  Z( 2, 2 ) = A( ISP1, ISP1 )
                  Z( 3, 2 ) = ZERO
                  Z( 4, 2 ) = -B( JS, JS )
!
                  Z( 1, 3 ) = D( IS, IS )
                  Z( 2, 3 ) = D( IS, ISP1 )
                  Z( 3, 3 ) = -E( JS, JS )
                  Z( 4, 3 ) = ZERO
!
                  Z( 1, 4 ) = ZERO
                  Z( 2, 4 ) = D( ISP1, ISP1 )
                  Z( 3, 4 ) = ZERO
                  Z( 4, 4 ) = -E( JS, JS )
!
!                 Set up right hand side(s)
!
                  RHS( 1 ) = C( IS, JS )
                  RHS( 2 ) = C( ISP1, JS )
                  RHS( 3 ) = F( IS, JS )
                  RHS( 4 ) = F( ISP1, JS )
!
!                 Solve Z' * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
!
                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
                  IF( SCALOC.NE.ONE ) THEN
                     DO K = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
                     end do
                     SCALE = SCALE*SCALOC
                  END IF
!
!                 Unpack solution vector(s)
!
                  C( IS, JS ) = RHS( 1 )
                  C( ISP1, JS ) = RHS( 2 )
                  F( IS, JS ) = RHS( 3 )
                  F( ISP1, JS ) = RHS( 4 )
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( J.GT.P+2 ) THEN
                     CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), &
                                1, F( IS, 1 ), LDF )
                     CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), &
                                1, F( IS, 1 ), LDF )
                  END IF
                  IF( I.LT.P ) THEN
                     CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), &
                                 LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), &
                                 1 )
                     CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), &
                                 LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), &
                                 1 )
                  END IF
!
               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
!
!                 Build an 8-by-8 system Z' * x = RHS
!
                  CALL DCOPY( LDZ*LDZ, zero_vec, 0, Z, 1 )
!
                  Z( 1, 1 ) = A( IS, IS )
                  Z( 2, 1 ) = A( IS, ISP1 )
                  Z( 5, 1 ) = -B( JS, JS )
                  Z( 7, 1 ) = -B( JSP1, JS )
!
                  Z( 1, 2 ) = A( ISP1, IS )
                  Z( 2, 2 ) = A( ISP1, ISP1 )
                  Z( 6, 2 ) = -B( JS, JS )
                  Z( 8, 2 ) = -B( JSP1, JS )
!
                  Z( 3, 3 ) = A( IS, IS )
                  Z( 4, 3 ) = A( IS, ISP1 )
                  Z( 5, 3 ) = -B( JS, JSP1 )
                  Z( 7, 3 ) = -B( JSP1, JSP1 )
!
                  Z( 3, 4 ) = A( ISP1, IS )
                  Z( 4, 4 ) = A( ISP1, ISP1 )
                  Z( 6, 4 ) = -B( JS, JSP1 )
                  Z( 8, 4 ) = -B( JSP1, JSP1 )
!
                  Z( 1, 5 ) = D( IS, IS )
                  Z( 2, 5 ) = D( IS, ISP1 )
                  Z( 5, 5 ) = -E( JS, JS )
!
                  Z( 2, 6 ) = D( ISP1, ISP1 )
                  Z( 6, 6 ) = -E( JS, JS )
!
                  Z( 3, 7 ) = D( IS, IS )
                  Z( 4, 7 ) = D( IS, ISP1 )
                  Z( 5, 7 ) = -E( JS, JSP1 )
                  Z( 7, 7 ) = -E( JSP1, JSP1 )
!
                  Z( 4, 8 ) = D( ISP1, ISP1 )
                  Z( 6, 8 ) = -E( JS, JSP1 )
                  Z( 8, 8 ) = -E( JSP1, JSP1 )
!
!                 Set up right hand side(s)
!
                  K = 1
                  II = MB*NB + 1
                  DO 160 JJ = 0, NB - 1
                     CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
                     CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
                     K = K + MB
                     II = II + MB
  160             CONTINUE
!
!
!                 Solve Z' * x = RHS
!
                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
                  IF( IERR.GT.0 ) &
                     INFO = IERR
!
                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
                  IF( SCALOC.NE.ONE ) THEN
                     DO 170 K = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  170                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
!
!                 Unpack solution vector(s)
!
                  K = 1
                  II = MB*NB + 1
                  DO 180 JJ = 0, NB - 1
                     CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
                     CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
                     K = K + MB
                     II = II + MB
  180             CONTINUE
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( J.GT.P+2 ) THEN
                     CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, &
                                 C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, &
                                 F( IS, 1 ), LDF )
                     CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, &
                                 F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, &
                                 F( IS, 1 ), LDF )
                  END IF
                  IF( I.LT.P ) THEN
                     CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, &
                                 A( IS, IE+1 ), LDA, C( IS, JS ), LDC, &
                                 ONE, C( IE+1, JS ), LDC )
                     CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, &
                                 D( IS, IE+1 ), LDD, F( IS, JS ), LDF, &
                                 ONE, C( IE+1, JS ), LDC )
                  END IF
!
               END IF
!
  190       CONTINUE
  200    CONTINUE
!
      END IF
      RETURN
!
!     End of DTGSY2
!
      END
      SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, &
                         LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, &
                         LWORK, M, N
      DOUBLE PRECISION   DIF, SCALE
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ), &
                         D( LDD, * ), E( LDE, * ), F( LDF, * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTGSYL solves the generalized Sylvester equation:
!
!              A * R - L * B = scale * C                 (1)
!              D * R - L * E = scale * F
!
!  where R and L are unknown m-by-n matrices, (A, D), (B, E) and
!  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
!  respectively, with real entries. (A, D) and (B, E) must be in
!  generalized (real) Schur canonical form, i.e. A, B are upper quasi
!  triangular and D, E are upper triangular.
!
!  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
!  scaling factor chosen to avoid overflow.
!
!  In matrix notation (1) is equivalent to solve  Zx = scale b, where
!  Z is defined as
!
!             Z = [ kron(In, A)  -kron(B', Im) ]         (2)
!                 [ kron(In, D)  -kron(E', Im) ].
!
!  Here Ik is the identity matrix of size k and X' is the transpose of
!  X. kron(X, Y) is the Kronecker product between the matrices X and Y.
!
!  If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,
!  which is equivalent to solve for R and L in
!
!              A' * R  + D' * L   = scale *  C           (3)
!              R  * B' + L  * E'  = scale * (-F)
!
!  This case (TRANS = 'T') is used to compute an one-norm-based estimate
!  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
!  and (B,E), using DLACON.
!
!  If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate
!  of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
!  reciprocal of the smallest singular value of Z. See [1-2] for more
!  information.
!
!  This is a level 3 BLAS algorithm.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          = 'N', solve the generalized Sylvester equation (1).
!          = 'T', solve the 'transposed' system (3).
!
!  IJOB    (input) INTEGER
!          Specifies what kind of functionality to be performed.
!           =0: solve (1) only.
!           =1: The functionality of 0 and 3.
!           =2: The functionality of 0 and 4.
!           =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
!               (look ahead strategy IJOB  = 1 is used).
!           =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
!               ( DGECON on sub-systems is used ).
!          Not referenced if TRANS = 'T'.
!
!  M       (input) INTEGER
!          The order of the matrices A and D, and the row dimension of
!          the matrices C, F, R and L.
!
!  N       (input) INTEGER
!          The order of the matrices B and E, and the column dimension
!          of the matrices C, F, R and L.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA, M)
!          The upper quasi triangular matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1, M).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
!          The upper quasi triangular matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1, N).
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC, N)
!          On entry, C contains the right-hand-side of the first matrix
!          equation in (1) or (3).
!          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
!          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
!          the solution achieved during the computation of the
!          Dif-estimate.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1, M).
!
!  D       (input) DOUBLE PRECISION array, dimension (LDD, M)
!          The upper triangular matrix D.
!
!  LDD     (input) INTEGER
!          The leading dimension of the array D. LDD >= max(1, M).
!
!  E       (input) DOUBLE PRECISION array, dimension (LDE, N)
!          The upper triangular matrix E.
!
!  LDE     (input) INTEGER
!          The leading dimension of the array E. LDE >= max(1, N).
!
!  F       (input/output) DOUBLE PRECISION array, dimension (LDF, N)
!          On entry, F contains the right-hand-side of the second matrix
!          equation in (1) or (3).
!          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
!          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
!          the solution achieved during the computation of the
!          Dif-estimate.
!
!  LDF     (input) INTEGER
!          The leading dimension of the array F. LDF >= max(1, M).
!
!  DIF     (output) DOUBLE PRECISION
!          On exit DIF is the reciprocal of a lower bound of the
!          reciprocal of the Dif-function, i.e. DIF is an upper bound of
!          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
!          IF IJOB = 0 or TRANS = 'T', DIF is not touched.
!
!  SCALE   (output) DOUBLE PRECISION
!          On exit SCALE is the scaling factor in (1) or (3).
!          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
!          to a slightly perturbed system but the input matrices A, B, D
!          and E have not been changed. If SCALE = 0, C and F hold the
!          solutions R and L, respectively, to the homogeneous system
!          with C = F = 0. Normally, SCALE = 1.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          If IJOB = 0, WORK is not referenced.  Otherwise,
!          on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK. LWORK > = 1.
!          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*N.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (M+N+6)
!
!  INFO    (output) INTEGER
!            =0: successful exit
!            <0: If INFO = -i, the i-th argument had an illegal value.
!            >0: (A, D) and (B, E) have common or close eigenvalues.
!
!  Further Details
!  ===============
!
!  Based on contributions by
!     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
!     Umea University, S-901 87 Umea, Sweden.
!
!  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
!      for Solving the Generalized Sylvester Equation and Estimating the
!      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
!      Department of Computing Science, Umea University, S-901 87 Umea,
!      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
!      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
!      No 1, 1996.
!
!  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
!      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
!      Appl., 15(4):1045-1060, 1994
!
!  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
!      Condition Estimators for Solving the Generalized Sylvester
!      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
!      July 1989, pp 745-751.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, NOTRAN
      INTEGER            I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K, &
                         LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
      DOUBLE PRECISION   DSCALE, DSUM, SCALE2, SCALOC

      double precision zero_vec(1)
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLACPY, DSCAL, DTGSY2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
      zero_vec(1) = 0.0D+00
!
!     Decode and test input parameters
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      LQUERY = ( LWORK.EQ.-1 )
!
      IF( ( IJOB.EQ.1 .OR. IJOB.EQ.2 ) .AND. NOTRAN ) THEN
         LWMIN = MAX( 1, 2*M*N )
      ELSE
         LWMIN = 1
      END IF
!
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -1
      ELSE IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
         INFO = -2
      ELSE IF( M.LE.0 ) THEN
         INFO = -3
      ELSE IF( N.LE.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -20
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTGSYL', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Determine optimal block sizes MB and NB
!
      MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 )
      NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 )
!
      ISOLVE = 1
      IFUNC = 0
      IF( IJOB.GE.3 .AND. NOTRAN ) THEN
         IFUNC = IJOB - 2
         DO J = 1, N
            CALL DCOPY( M, zero_vec, 0, C( 1, J ), 1 )
            CALL DCOPY( M, zero_vec, 0, F( 1, J ), 1 )
         end do
      ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
         ISOLVE = 2
      END IF
!
      IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) ) &
           THEN
!
         DO 30 IROUND = 1, ISOLVE
!
!           Use unblocked Level 2 solver
!
            DSCALE = ZERO
            DSUM = ONE
            PQ = 0
            CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D, &
                         LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE, &
                         IWORK, PQ, INFO )
            IF( DSCALE.NE.ZERO ) THEN
               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
               ELSE
                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
               END IF
            END IF
!
            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
               IFUNC = IJOB
               SCALE2 = SCALE
               CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
               CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
               DO J = 1, N
                  CALL DCOPY( M, zero_vec, 0, C( 1, J ), 1 )
                  CALL DCOPY( M, zero_vec, 0, F( 1, J ), 1 )
               end do
            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
               CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
               CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
               SCALE = SCALE2
            END IF
   30    CONTINUE
!
         RETURN
      END IF
!
!     Determine block structure of A
!
      P = 0
      I = 1
   40 CONTINUE
      IF( I.GT.M ) &
         GO TO 50
      P = P + 1
      IWORK( P ) = I
      I = I + MB
      IF( I.GE.M ) &
         GO TO 50
      IF( A( I, I-1 ).NE.ZERO ) &
         I = I + 1
      GO TO 40
   50 CONTINUE
!
      IWORK( P+1 ) = M + 1
      IF( IWORK( P ).EQ.IWORK( P+1 ) ) &
         P = P - 1
!
!     Determine block structure of B
!
      Q = P + 1
      J = 1
   60 CONTINUE
      IF( J.GT.N ) &
         GO TO 70
      Q = Q + 1
      IWORK( Q ) = J
      J = J + NB
      IF( J.GE.N ) &
         GO TO 70
      IF( B( J, J-1 ).NE.ZERO ) &
         J = J + 1
      GO TO 60
   70 CONTINUE
!
      IWORK( Q+1 ) = N + 1
      IF( IWORK( Q ).EQ.IWORK( Q+1 ) ) &
         Q = Q - 1
!
      IF( NOTRAN ) THEN
!
         DO 150 IROUND = 1, ISOLVE
!
!           Solve (I, J)-subsystem
!               A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
!               D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
!           for I = P, P - 1,..., 1; J = 1, 2,..., Q
!
            DSCALE = ZERO
            DSUM = ONE
            PQ = 0
            SCALE = ONE
            DO 130 J = P + 2, Q
               JS = IWORK( J )
               JE = IWORK( J+1 ) - 1
               NB = JE - JS + 1
               DO 120 I = P, 1, -1
                  IS = IWORK( I )
                  IE = IWORK( I+1 ) - 1
                  MB = IE - IS + 1
                  PPQQ = 0
                  CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, &
                               B( JS, JS ), LDB, C( IS, JS ), LDC, &
                               D( IS, IS ), LDD, E( JS, JS ), LDE, &
                               F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, &
                               IWORK( Q+2 ), PPQQ, LINFO )
                  IF( LINFO.GT.0 ) &
                     INFO = LINFO
!
                  PQ = PQ + PPQQ
                  IF( SCALOC.NE.ONE ) THEN
                     DO 80 K = 1, JS - 1
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
   80                CONTINUE
                     DO 90 K = JS, JE
                        CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
   90                CONTINUE
                     DO 100 K = JS, JE
                        CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
                        CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
  100                CONTINUE
                     DO 110 K = JE + 1, N
                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  110                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
!
!                 Substitute R(I, J) and L(I, J) into remaining
!                 equation.
!
                  IF( I.GT.1 ) THEN
                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, &
                                 A( 1, IS ), LDA, C( IS, JS ), LDC, ONE, &
                                 C( 1, JS ), LDC )
                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, &
                                 D( 1, IS ), LDD, C( IS, JS ), LDC, ONE, &
                                 F( 1, JS ), LDF )
                  END IF
                  IF( J.LT.Q ) THEN
                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, &
                                 F( IS, JS ), LDF, B( JS, JE+1 ), LDB, &
                                 ONE, C( IS, JE+1 ), LDC )
                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, &
                                 F( IS, JS ), LDF, E( JS, JE+1 ), LDE, &
                                 ONE, F( IS, JE+1 ), LDF )
                  END IF
  120          CONTINUE
  130       CONTINUE
            IF( DSCALE.NE.ZERO ) THEN
               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
               ELSE
                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
               END IF
            END IF
            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
               IFUNC = IJOB
               SCALE2 = SCALE
               CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
               CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
               DO J = 1, N
                  CALL DCOPY( M, zero_vec, 0, C( 1, J ), 1 )
                  CALL DCOPY( M, zero_vec, 0, F( 1, J ), 1 )
               end do
            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
               CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
               CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
               SCALE = SCALE2
            END IF
  150    CONTINUE
!
      ELSE
!
!        Solve transposed (I, J)-subsystem
!             A(I, I)' * R(I, J)  + D(I, I)' * L(I, J)  =  C(I, J)
!             R(I, J)  * B(J, J)' + L(I, J)  * E(J, J)' = -F(I, J)
!        for I = 1,2,..., P; J = Q, Q-1,..., 1
!
         SCALE = ONE
         DO 210 I = 1, P
            IS = IWORK( I )
            IE = IWORK( I+1 ) - 1
            MB = IE - IS + 1
            DO 200 J = Q, P + 2, -1
               JS = IWORK( J )
               JE = IWORK( J+1 ) - 1
               NB = JE - JS + 1
               CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA, &
                            B( JS, JS ), LDB, C( IS, JS ), LDC, &
                            D( IS, IS ), LDD, E( JS, JS ), LDE, &
                            F( IS, JS ), LDF, SCALOC, DSUM, DSCALE, &
                            IWORK( Q+2 ), PPQQ, LINFO )
               IF( LINFO.GT.0 ) &
                  INFO = LINFO
               IF( SCALOC.NE.ONE ) THEN
                  DO 160 K = 1, JS - 1
                     CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                     CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  160             CONTINUE
                  DO 170 K = JS, JE
                     CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
                     CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
  170             CONTINUE
                  DO 180 K = JS, JE
                     CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
                     CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
  180             CONTINUE
                  DO 190 K = JE + 1, N
                     CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
                     CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
  190             CONTINUE
                  SCALE = SCALE*SCALOC
               END IF
!
!              Substitute R(I, J) and L(I, J) into remaining equation.
!
               IF( J.GT.P+2 ) THEN
                  CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ), &
                              LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ), &
                              LDF )
                  CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ), &
                              LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ), &
                              LDF )
               END IF
               IF( I.LT.P ) THEN
                  CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, &
                              A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE, &
                              C( IE+1, JS ), LDC )
                  CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, &
                              D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE, &
                              C( IE+1, JS ), LDC )
               END IF
  200       CONTINUE
  210    CONTINUE
!
      END IF
!
      WORK( 1 ) = LWMIN
!
      RETURN
!
!     End of DTGSYL
!
      END
      SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            INFO, N
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AP( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTPCON estimates the reciprocal of the condition number of a packed
!  triangular matrix A, in either the 1-norm or the infinity-norm.
!
!  The norm of A is computed and an estimate is obtained for
!  norm(inv(A)), then the reciprocal of the condition number is
!  computed as
!     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangular matrix A, packed columnwise in
!          a linear array.  The j-th column of A is stored in the array
!          AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!          If DIAG = 'U', the diagonal elements of A are not referenced
!          and are assumed to be 1.
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, ONENRM, UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTP
      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTP
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATPS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
!
      RCOND = ZERO
      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
!
!     Compute the norm of the triangular matrix A.
!
      ANORM = DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
!
!     Continue only if ANORM > 0.
!
      IF( ANORM.GT.ZERO ) THEN
!
!        Estimate the norm of the inverse of A.
!
         AINVNM = ZERO
         NORMIN = 'N'
         IF( ONENRM ) THEN
            KASE1 = 1
         ELSE
            KASE1 = 2
         END IF
         KASE = 0
   10    CONTINUE
         CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.KASE1 ) THEN
!
!              Multiply by inv(A).
!
               CALL DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP, &
                            WORK, SCALE, WORK( 2*N+1 ), INFO )
            ELSE
!
!              Multiply by inv(A').
!
               CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP, &
                            WORK, SCALE, WORK( 2*N+1 ), INFO )
            END IF
            NORMIN = 'Y'
!
!           Multiply by 1/SCALE if doing so will not cause overflow.
!
            IF( SCALE.NE.ONE ) THEN
               IX = IDAMAX( N, WORK, 1 )
               XNORM = ABS( WORK( IX ) )
               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) &
                  GO TO 20
               CALL DRSCL( N, SCALE, WORK, 1 )
            END IF
            GO TO 10
         END IF
!
!        Compute the estimate of the reciprocal condition number.
!
         IF( AINVNM.NE.ZERO ) &
            RCOND = ( ONE / ANORM ) / AINVNM
      END IF
!
   20 CONTINUE
      RETURN
!
!     End of DTPCON
!
      END
      SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, &
                         FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   AP( * ), B( LDB, * ), BERR( * ), FERR( * ), &
                         WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DTPRFS provides error bounds and backward error estimates for the
!  solution to a system of linear equations with a triangular packed
!  coefficient matrix.
!
!  The solution matrix X must be computed by DTPTRS or some other
!  means before entering this routine.  DTPRFS does not do iterative
!  refinement because doing so cannot improve the backward error.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangular matrix A, packed columnwise in
!          a linear array.  The j-th column of A is stored in the array
!          AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!          If DIAG = 'U', the diagonal elements of A are not referenced
!          and are assumed to be 1.
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          The solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      CHARACTER          TRANST
      INTEGER            I, J, K, KASE, KC, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DTPMV, DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 250 J = 1, NRHS
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A or A', depending on TRANS.
!
         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 20 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   20    CONTINUE
!
         IF( NOTRAN ) THEN
!
!           Compute abs(A)*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               KC = 1
               IF( NOUNIT ) THEN
                  DO 40 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 30 I = 1, K
                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
   30                CONTINUE
                     KC = KC + K
   40             CONTINUE
               ELSE
                  DO 60 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 50 I = 1, K - 1
                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
   50                CONTINUE
                     WORK( K ) = WORK( K ) + XK
                     KC = KC + K
   60             CONTINUE
               END IF
            ELSE
               KC = 1
               IF( NOUNIT ) THEN
                  DO 80 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 70 I = K, N
                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
   70                CONTINUE
                     KC = KC + N - K + 1
   80             CONTINUE
               ELSE
                  DO 100 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 90 I = K + 1, N
                        WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
   90                CONTINUE
                     WORK( K ) = WORK( K ) + XK
                     KC = KC + N - K + 1
  100             CONTINUE
               END IF
            END IF
         ELSE
!
!           Compute abs(A')*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               KC = 1
               IF( NOUNIT ) THEN
                  DO 120 K = 1, N
                     S = ZERO
                     DO 110 I = 1, K
                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
  110                CONTINUE
                     WORK( K ) = WORK( K ) + S
                     KC = KC + K
  120             CONTINUE
               ELSE
                  DO 140 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 130 I = 1, K - 1
                        S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
  130                CONTINUE
                     WORK( K ) = WORK( K ) + S
                     KC = KC + K
  140             CONTINUE
               END IF
            ELSE
               KC = 1
               IF( NOUNIT ) THEN
                  DO 160 K = 1, N
                     S = ZERO
                     DO 150 I = K, N
                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
  150                CONTINUE
                     WORK( K ) = WORK( K ) + S
                     KC = KC + N - K + 1
  160             CONTINUE
               ELSE
                  DO 180 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 170 I = K + 1, N
                        S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
  170                CONTINUE
                     WORK( K ) = WORK( K ) + S
                     KC = KC + N - K + 1
  180             CONTINUE
               END IF
            END IF
         END IF
         S = ZERO
         DO 190 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
  190    CONTINUE
         BERR( J ) = S
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 200 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
  200    CONTINUE
!
         KASE = 0
  210    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)').
!
               CALL DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
               DO 220 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  220          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 230 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  230          CONTINUE
               CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
            END IF
            GO TO 210
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 240 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  240    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  250 CONTINUE
!
      RETURN
!
!     End of DTPRFS
!
      END
      SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
!     ..
!
!  Purpose
!  =======
!
!  DTPTRI computes the inverse of a real upper or lower triangular
!  matrix A stored in packed format.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          On entry, the upper or lower triangular matrix A, stored
!          columnwise in a linear array.  The j-th column of A is stored
!          in the array AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
!          See below for further details.
!          On exit, the (triangular) inverse of the original matrix, in
!          the same packed storage format.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, A(i,i) is exactly zero.  The triangular
!                matrix is singular and its inverse can not be computed.
!
!  Further Details
!  ===============
!
!  A triangular matrix A can be transferred to packed storage using one
!  of the following program segments:
!
!  UPLO = 'U':                      UPLO = 'L':
!
!        JC = 1                           JC = 1
!        DO 2 J = 1, N                    DO 2 J = 1, N
!           DO 1 I = 1, J                    DO 1 I = J, N
!              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
!      1    CONTINUE                    1    CONTINUE
!           JC = JC + J                      JC = JC + N - J + 1
!      2 CONTINUE                       2 CONTINUE
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JC, JCLAST, JJ
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DTPMV, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPTRI', -INFO )
         RETURN
      END IF
!
!     Check for singularity if non-unit.
!
      IF( NOUNIT ) THEN
         IF( UPPER ) THEN
            JJ = 0
            DO 10 INFO = 1, N
               JJ = JJ + INFO
               IF( AP( JJ ).EQ.ZERO ) &
                  RETURN
   10       CONTINUE
         ELSE
            JJ = 1
            DO 20 INFO = 1, N
               IF( AP( JJ ).EQ.ZERO ) &
                  RETURN
               JJ = JJ + N - INFO + 1
   20       CONTINUE
         END IF
         INFO = 0
      END IF
!
      IF( UPPER ) THEN
!
!        Compute inverse of upper triangular matrix.
!
         JC = 1
         DO 30 J = 1, N
            IF( NOUNIT ) THEN
               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
               AJJ = -AP( JC+J-1 )
            ELSE
               AJJ = -ONE
            END IF
!
!           Compute elements 1:j-1 of j-th column.
!
            CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, &
                        AP( JC ), 1 )
            CALL DSCAL( J-1, AJJ, AP( JC ), 1 )
            JC = JC + J
   30    CONTINUE
!
      ELSE
!
!        Compute inverse of lower triangular matrix.
!
         JC = N*( N+1 ) / 2
         DO 40 J = N, 1, -1
            IF( NOUNIT ) THEN
               AP( JC ) = ONE / AP( JC )
               AJJ = -AP( JC )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
!
!              Compute elements j+1:n of j-th column.
!
               CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J, &
                           AP( JCLAST ), AP( JC+1 ), 1 )
               CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )
            END IF
            JCLAST = JC
            JC = JC - N + J - 2
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DTPTRI
!
      END
      SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTPTRS solves a triangular system of the form
!
!     A * X = B  or  A**T * X = B,
!
!  where A is a triangular matrix of order N stored in packed format,
!  and B is an N-by-NRHS matrix.  A check is made to verify that A is
!  nonsingular.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
!          The upper or lower triangular matrix A, packed columnwise in
!          a linear array.  The j-th column of A is stored in the array
!          AP as follows:
!          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, if INFO = 0, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, the i-th diagonal element of A is zero,
!                indicating that the matrix is singular and the
!                solutions X have not been computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JC
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTPSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. &
               LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check for singularity.
!
      IF( NOUNIT ) THEN
         IF( UPPER ) THEN
            JC = 1
            DO 10 INFO = 1, N
               IF( AP( JC+INFO-1 ).EQ.ZERO ) &
                  RETURN
               JC = JC + INFO
   10       CONTINUE
         ELSE
            JC = 1
            DO 20 INFO = 1, N
               IF( AP( JC ).EQ.ZERO ) &
                  RETURN
               JC = JC + N - INFO + 1
   20       CONTINUE
         END IF
      END IF
      INFO = 0
!
!     Solve A * x = b  or  A' * x = b.
!
      DO 30 J = 1, NRHS
         CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
   30 CONTINUE
!
      RETURN
!
!     End of DTPTRS
!
      END
      SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, &
                         IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, NORM, UPLO
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   RCOND
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTRCON estimates the reciprocal of the condition number of a
!  triangular matrix A, in either the 1-norm or the infinity-norm.
!
!  The norm of A is computed and an estimate is obtained for
!  norm(inv(A)), then the reciprocal of the condition number is
!  computed as
!     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!
!  Arguments
!  =========
!
!  NORM    (input) CHARACTER*1
!          Specifies whether the 1-norm condition number or the
!          infinity-norm condition number is required:
!          = '1' or 'O':  1-norm;
!          = 'I':         Infinity-norm.
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of the array A contains the upper
!          triangular matrix, and the strictly lower triangular part of
!          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of the array A contains the lower triangular
!          matrix, and the strictly upper triangular part of A is not
!          referenced.  If DIAG = 'U', the diagonal elements of A are
!          also not referenced and are assumed to be 1.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  RCOND   (output) DOUBLE PRECISION
!          The reciprocal of the condition number of the matrix A,
!          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, ONENRM, UPPER
      CHARACTER          NORMIN
      INTEGER            IX, KASE, KASE1
      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTR
      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTR
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLATRS, DRSCL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRCON', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
!
      RCOND = ZERO
      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
!
!     Compute the norm of the triangular matrix A.
!
      ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
!
!     Continue only if ANORM > 0.
!
      IF( ANORM.GT.ZERO ) THEN
!
!        Estimate the norm of the inverse of A.
!
         AINVNM = ZERO
         NORMIN = 'N'
         IF( ONENRM ) THEN
            KASE1 = 1
         ELSE
            KASE1 = 2
         END IF
         KASE = 0
   10    CONTINUE
         CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.KASE1 ) THEN
!
!              Multiply by inv(A).
!
               CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A, &
                            LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
            ELSE
!
!              Multiply by inv(A').
!
               CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA, &
                            WORK, SCALE, WORK( 2*N+1 ), INFO )
            END IF
            NORMIN = 'Y'
!
!           Multiply by 1/SCALE if doing so will not cause overflow.
!
            IF( SCALE.NE.ONE ) THEN
               IX = IDAMAX( N, WORK, 1 )
               XNORM = ABS( WORK( IX ) )
               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) &
                  GO TO 20
               CALL DRSCL( N, SCALE, WORK, 1 )
            END IF
            GO TO 10
         END IF
!
!        Compute the estimate of the reciprocal condition number.
!
         IF( AINVNM.NE.ZERO ) &
            RCOND = ( ONE / ANORM ) / AINVNM
      END IF
!
   20 CONTINUE
      RETURN
!
!     End of DTRCON
!
      END
      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, &
                         LDVR, MM, M, WORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          HOWMNY, SIDE
      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      DOUBLE PRECISION   T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), &
                         WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTREVC computes some or all of the right and/or left eigenvectors of
!  a real upper quasi-triangular matrix T.
!
!  The right eigenvector x and the left eigenvector y of T corresponding
!  to an eigenvalue w are defined by:
!
!               T*x = w*x,     y'*T = w*y'
!
!  where y' denotes the conjugate transpose of the vector y.
!
!  If all eigenvectors are requested, the routine may either return the
!  matrices X and/or Y of right or left eigenvectors of T, or the
!  products Q*X and/or Q*Y, where Q is an input orthogonal
!  matrix. If T was obtained from the real-Schur factorization of an
!  original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
!  right or left eigenvectors of A.
!
!  T must be in Schur canonical form (as returned by DHSEQR), that is,
!  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!  2-by-2 diagonal block has its diagonal elements equal and its
!  off-diagonal elements of opposite sign.  Corresponding to each 2-by-2
!  diagonal block is a complex conjugate pair of eigenvalues and
!  eigenvectors; only one eigenvector of the pair is computed, namely
!  the one corresponding to the eigenvalue with positive imaginary part.
!
!  Arguments
!  =========
!
!  SIDE    (input) CHARACTER*1
!          = 'R':  compute right eigenvectors only;
!          = 'L':  compute left eigenvectors only;
!          = 'B':  compute both right and left eigenvectors.
!
!  HOWMNY  (input) CHARACTER*1
!          = 'A':  compute all right and/or left eigenvectors;
!          = 'B':  compute all right and/or left eigenvectors,
!                  and backtransform them using the input matrices
!                  supplied in VR and/or VL;
!          = 'S':  compute selected right and/or left eigenvectors,
!                  specified by the logical array SELECT.
!
!  SELECT  (input/output) LOGICAL array, dimension (N)
!          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!          computed.
!          If HOWMNY = 'A' or 'B', SELECT is not referenced.
!          To select the real eigenvector corresponding to a real
!          eigenvalue w(j), SELECT(j) must be set to .TRUE..  To select
!          the complex eigenvector corresponding to a complex conjugate
!          pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be
!          set to .TRUE.; then on exit SELECT(j) is .TRUE. and
!          SELECT(j+1) is .FALSE..
!
!  N       (input) INTEGER
!          The order of the matrix T. N >= 0.
!
!  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
!          The upper quasi-triangular matrix T in Schur canonical form.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= max(1,N).
!
!  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
!          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!          contain an N-by-N matrix Q (usually the orthogonal matrix Q
!          of Schur vectors returned by DHSEQR).
!          On exit, if SIDE = 'L' or 'B', VL contains:
!          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
!                           VL has the same quasi-lower triangular form
!                           as T'. If T(i,i) is a real eigenvalue, then
!                           the i-th column VL(i) of VL  is its
!                           corresponding eigenvector. If T(i:i+1,i:i+1)
!                           is a 2-by-2 block whose eigenvalues are
!                           complex-conjugate eigenvalues of T, then
!                           VL(i)+sqrt(-1)*VL(i+1) is the complex
!                           eigenvector corresponding to the eigenvalue
!                           with positive real part.
!          if HOWMNY = 'B', the matrix Q*Y;
!          if HOWMNY = 'S', the left eigenvectors of T specified by
!                           SELECT, stored consecutively in the columns
!                           of VL, in the same order as their
!                           eigenvalues.
!          A complex eigenvector corresponding to a complex eigenvalue
!          is stored in two consecutive columns, the first holding the
!          real part, and the second the imaginary part.
!          If SIDE = 'R', VL is not referenced.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL.  LDVL >= max(1,N) if
!          SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
!
!  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
!          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!          contain an N-by-N matrix Q (usually the orthogonal matrix Q
!          of Schur vectors returned by DHSEQR).
!          On exit, if SIDE = 'R' or 'B', VR contains:
!          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
!                           VR has the same quasi-upper triangular form
!                           as T. If T(i,i) is a real eigenvalue, then
!                           the i-th column VR(i) of VR  is its
!                           corresponding eigenvector. If T(i:i+1,i:i+1)
!                           is a 2-by-2 block whose eigenvalues are
!                           complex-conjugate eigenvalues of T, then
!                           VR(i)+sqrt(-1)*VR(i+1) is the complex
!                           eigenvector corresponding to the eigenvalue
!                           with positive real part.
!          if HOWMNY = 'B', the matrix Q*X;
!          if HOWMNY = 'S', the right eigenvectors of T specified by
!                           SELECT, stored consecutively in the columns
!                           of VR, in the same order as their
!                           eigenvalues.
!          A complex eigenvector corresponding to a complex eigenvalue
!          is stored in two consecutive columns, the first holding the
!          real part and the second the imaginary part.
!          If SIDE = 'L', VR is not referenced.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.  LDVR >= max(1,N) if
!          SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
!
!  MM      (input) INTEGER
!          The number of columns in the arrays VL and/or VR. MM >= M.
!
!  M       (output) INTEGER
!          The number of columns in the arrays VL and/or VR actually
!          used to store the eigenvectors.
!          If HOWMNY = 'A' or 'B', M is set to N.
!          Each selected real eigenvector occupies one column and each
!          selected complex eigenvector occupies two columns.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The algorithm used in this program is basically backward (forward)
!  substitution, with scaling to make the the code robust against
!  possible overflow.
!
!  Each eigenvector is normalized so that the element of largest
!  magnitude has magnitude 1; here the magnitude of a complex number
!  (x,y) is taken to be |x| + |y|.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
      INTEGER            I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
      DOUBLE PRECISION   BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, &
                         SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, &
                         XNORM
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   X( 2, 2 )
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      BOTHV = LSAME( SIDE, 'B' )
      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
!
      ALLV = LSAME( HOWMNY, 'A' )
      OVER = LSAME( HOWMNY, 'B' )
      SOMEV = LSAME( HOWMNY, 'S' )
!
      INFO = 0
      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
         INFO = -1
      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      ELSE
!
!        Set M to the number of columns required to store the selected
!        eigenvectors, standardize the array SELECT if necessary, and
!        test MM.
!
         IF( SOMEV ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 J = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
                  SELECT( J ) = .FALSE.
               ELSE
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).EQ.ZERO ) THEN
                        IF( SELECT( J ) ) &
                           M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
                           SELECT( J ) = .TRUE.
                           M = M + 2
                        END IF
                     END IF
                  ELSE
                     IF( SELECT( N ) ) &
                        M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
!
         IF( MM.LT.M ) THEN
            INFO = -11
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTREVC', -INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Set the constants to control overflow.
!
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( N / ULP )
      BIGNUM = ( ONE-ULP ) / SMLNUM
!
!     Compute 1-norm of each column of strictly upper triangular
!     part of T to control overflow in triangular solver.
!
      WORK( 1 ) = ZERO
      DO 30 J = 2, N
         WORK( J ) = ZERO
         DO 20 I = 1, J - 1
            WORK( J ) = WORK( J ) + ABS( T( I, J ) )
   20    CONTINUE
   30 CONTINUE
!
!     Index IP is used to specify the real or complex eigenvalue:
!       IP = 0, real eigenvalue,
!            1, first of conjugate complex pair: (wr,wi)
!           -1, second of conjugate complex pair: (wr,wi)
!
      N2 = 2*N
!
      IF( RIGHTV ) THEN
!
!        Compute right eigenvectors.
!
         IP = 0
         IS = M
         DO 140 KI = N, 1, -1
!
            IF( IP.EQ.1 ) &
               GO TO 130
            IF( KI.EQ.1 ) &
               GO TO 40
            IF( T( KI, KI-1 ).EQ.ZERO ) &
               GO TO 40
            IP = -1
!
   40       CONTINUE
            IF( SOMEV ) THEN
               IF( IP.EQ.0 ) THEN
                  IF( .NOT.SELECT( KI ) ) &
                     GO TO 130
               ELSE
                  IF( .NOT.SELECT( KI-1 ) ) &
                     GO TO 130
               END IF
            END IF
!
!           Compute the KI-th eigenvalue (WR,WI).
!
            WR = T( KI, KI )
            WI = ZERO
            IF( IP.NE.0 ) &
               WI = SQRT( ABS( T( KI, KI-1 ) ) )* &
                    SQRT( ABS( T( KI-1, KI ) ) )
            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
!
            IF( IP.EQ.0 ) THEN
!
!              Real right eigenvector
!
               WORK( KI+N ) = ONE
!
!              Form right-hand side
!
               DO 50 K = 1, KI - 1
                  WORK( K+N ) = -T( K, KI )
   50          CONTINUE
!
!              Solve the upper quasi-triangular system:
!                 (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
!
               JNXT = KI - 1
               DO 60 J = KI - 1, 1, -1
                  IF( J.GT.JNXT ) &
                     GO TO 60
                  J1 = J
                  J2 = J
                  JNXT = J - 1
                  IF( J.GT.1 ) THEN
                     IF( T( J, J-1 ).NE.ZERO ) THEN
                        J1 = J - 1
                        JNXT = J - 2
                     END IF
                  END IF
!
                  IF( J1.EQ.J2 ) THEN
!
!                    1-by-1 diagonal block
!
                     CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, &
                                  ZERO, X, 2, SCALE, XNORM, IERR )
!
!                    Scale X(1,1) to avoid overflow when updating
!                    the right-hand side.
!
                     IF( XNORM.GT.ONE ) THEN
                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) &
                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
!
!                    Update right-hand side
!
                     CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, &
                                 WORK( 1+N ), 1 )
!
                  ELSE
!
!                    2-by-2 diagonal block
!
                     CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, &
                                  T( J-1, J-1 ), LDT, ONE, ONE, &
                                  WORK( J-1+N ), N, WR, ZERO, X, 2, &
                                  SCALE, XNORM, IERR )
!
!                    Scale X(1,1) and X(2,1) to avoid overflow when
!                    updating the right-hand side.
!
                     IF( XNORM.GT.ONE ) THEN
                        BETA = MAX( WORK( J-1 ), WORK( J ) )
                        IF( BETA.GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           X( 2, 1 ) = X( 2, 1 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) &
                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
                     WORK( J-1+N ) = X( 1, 1 )
                     WORK( J+N ) = X( 2, 1 )
!
!                    Update right-hand side
!
                     CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, &
                                 WORK( 1+N ), 1 )
                     CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, &
                                 WORK( 1+N ), 1 )
                  END IF
   60          CONTINUE
!
!              Copy the vector x or Q*x to VR and normalize.
!
               IF( .NOT.OVER ) THEN
                  CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
!
                  II = IDAMAX( KI, VR( 1, IS ), 1 )
                  REMAX = ONE / ABS( VR( II, IS ) )
                  CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
!
                  DO 70 K = KI + 1, N
                     VR( K, IS ) = ZERO
   70             CONTINUE
               ELSE
                  IF( KI.GT.1 ) &
                     CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, &
                                 WORK( 1+N ), 1, WORK( KI+N ), &
                                 VR( 1, KI ), 1 )
!
                  II = IDAMAX( N, VR( 1, KI ), 1 )
                  REMAX = ONE / ABS( VR( II, KI ) )
                  CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
               END IF
!
            ELSE
!
!              Complex right eigenvector.
!
!              Initial solve
!                [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
!                [ (T(KI,KI-1)   T(KI,KI)   )               ]
!
               IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
                  WORK( KI-1+N ) = ONE
                  WORK( KI+N2 ) = WI / T( KI-1, KI )
               ELSE
                  WORK( KI-1+N ) = -WI / T( KI, KI-1 )
                  WORK( KI+N2 ) = ONE
               END IF
               WORK( KI+N ) = ZERO
               WORK( KI-1+N2 ) = ZERO
!
!              Form right-hand side
!
               DO 80 K = 1, KI - 2
                  WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
                  WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
   80          CONTINUE
!
!              Solve upper quasi-triangular system:
!              (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
!
               JNXT = KI - 2
               DO 90 J = KI - 2, 1, -1
                  IF( J.GT.JNXT ) &
                     GO TO 90
                  J1 = J
                  J2 = J
                  JNXT = J - 1
                  IF( J.GT.1 ) THEN
                     IF( T( J, J-1 ).NE.ZERO ) THEN
                        J1 = J - 1
                        JNXT = J - 2
                     END IF
                  END IF
!
                  IF( J1.EQ.J2 ) THEN
!
!                    1-by-1 diagonal block
!
                     CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, WI, &
                                  X, 2, SCALE, XNORM, IERR )
!
!                    Scale X(1,1) and X(1,2) to avoid overflow when
!                    updating the right-hand side.
!
                     IF( XNORM.GT.ONE ) THEN
                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
                           X( 1, 1 ) = X( 1, 1 ) / XNORM
                           X( 1, 2 ) = X( 1, 2 ) / XNORM
                           SCALE = SCALE / XNORM
                        END IF
                     END IF
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) THEN
                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
                        CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
!
!                    Update the right-hand side
!
                     CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, &
                                 WORK( 1+N ), 1 )
                     CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, &
                                 WORK( 1+N2 ), 1 )
!
                  ELSE
!
!                    2-by-2 diagonal block
!
                     CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, &
                                  T( J-1, J-1 ), LDT, ONE, ONE, &
                                  WORK( J-1+N ), N, WR, WI, X, 2, SCALE, &
                                  XNORM, IERR )
!
!                    Scale X to avoid overflow when updating
!                    the right-hand side.
!
                     IF( XNORM.GT.ONE ) THEN
                        BETA = MAX( WORK( J-1 ), WORK( J ) )
                        IF( BETA.GT.BIGNUM / XNORM ) THEN
                           REC = ONE / XNORM
                           X( 1, 1 ) = X( 1, 1 )*REC
                           X( 1, 2 ) = X( 1, 2 )*REC
                           X( 2, 1 ) = X( 2, 1 )*REC
                           X( 2, 2 ) = X( 2, 2 )*REC
                           SCALE = SCALE*REC
                        END IF
                     END IF
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) THEN
                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
                        CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
                     END IF
                     WORK( J-1+N ) = X( 1, 1 )
                     WORK( J+N ) = X( 2, 1 )
                     WORK( J-1+N2 ) = X( 1, 2 )
                     WORK( J+N2 ) = X( 2, 2 )
!
!                    Update the right-hand side
!
                     CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, &
                                 WORK( 1+N ), 1 )
                     CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, &
                                 WORK( 1+N ), 1 )
                     CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, &
                                 WORK( 1+N2 ), 1 )
                     CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, &
                                 WORK( 1+N2 ), 1 )
                  END IF
   90          CONTINUE
!
!              Copy the vector x or Q*x to VR and normalize.
!
               IF( .NOT.OVER ) THEN
                  CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
                  CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
!
                  EMAX = ZERO
                  DO 100 K = 1, KI
                     EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ &
                            ABS( VR( K, IS ) ) )
  100             CONTINUE
!
                  REMAX = ONE / EMAX
                  CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
                  CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
!
                  DO 110 K = KI + 1, N
                     VR( K, IS-1 ) = ZERO
                     VR( K, IS ) = ZERO
  110             CONTINUE
!
               ELSE
!
                  IF( KI.GT.2 ) THEN
                     CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, &
                                 WORK( 1+N ), 1, WORK( KI-1+N ), &
                                 VR( 1, KI-1 ), 1 )
                     CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, &
                                 WORK( 1+N2 ), 1, WORK( KI+N2 ), &
                                 VR( 1, KI ), 1 )
                  ELSE
                     CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
                     CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
                  END IF
!
                  EMAX = ZERO
                  DO 120 K = 1, N
                     EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ &
                            ABS( VR( K, KI ) ) )
  120             CONTINUE
                  REMAX = ONE / EMAX
                  CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
                  CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
               END IF
            END IF
!
            IS = IS - 1
            IF( IP.NE.0 ) &
               IS = IS - 1
  130       CONTINUE
            IF( IP.EQ.1 ) &
               IP = 0
            IF( IP.EQ.-1 ) &
               IP = 1
  140    CONTINUE
      END IF
!
      IF( LEFTV ) THEN
!
!        Compute left eigenvectors.
!
         IP = 0
         IS = 1
         DO 260 KI = 1, N
!
            IF( IP.EQ.-1 ) &
               GO TO 250
            IF( KI.EQ.N ) &
               GO TO 150
            IF( T( KI+1, KI ).EQ.ZERO ) &
               GO TO 150
            IP = 1
!
  150       CONTINUE
            IF( SOMEV ) THEN
               IF( .NOT.SELECT( KI ) ) &
                  GO TO 250
            END IF
!
!           Compute the KI-th eigenvalue (WR,WI).
!
            WR = T( KI, KI )
            WI = ZERO
            IF( IP.NE.0 ) &
               WI = SQRT( ABS( T( KI, KI+1 ) ) )* &
                    SQRT( ABS( T( KI+1, KI ) ) )
            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
!
            IF( IP.EQ.0 ) THEN
!
!              Real left eigenvector.
!
               WORK( KI+N ) = ONE
!
!              Form right-hand side
!
               DO 160 K = KI + 1, N
                  WORK( K+N ) = -T( KI, K )
  160          CONTINUE
!
!              Solve the quasi-triangular system:
!                 (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
!
               VMAX = ONE
               VCRIT = BIGNUM
!
               JNXT = KI + 1
               DO 170 J = KI + 1, N
                  IF( J.LT.JNXT ) &
                     GO TO 170
                  J1 = J
                  J2 = J
                  JNXT = J + 1
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).NE.ZERO ) THEN
                        J2 = J + 1
                        JNXT = J + 2
                     END IF
                  END IF
!
                  IF( J1.EQ.J2 ) THEN
!
!                    1-by-1 diagonal block
!
!                    Scale if necessary to avoid overflow when forming
!                    the right-hand side.
!
                     IF( WORK( J ).GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
!
                     WORK( J+N ) = WORK( J+N ) - &
                                   DDOT( J-KI-1, T( KI+1, J ), 1, &
                                   WORK( KI+1+N ), 1 )
!
!                    Solve (T(J,J)-WR)'*X = WORK
!
                     CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, &
                                  ZERO, X, 2, SCALE, XNORM, IERR )
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) &
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
                     VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
!
                  ELSE
!
!                    2-by-2 diagonal block
!
!                    Scale if necessary to avoid overflow when forming
!                    the right-hand side.
!
                     BETA = MAX( WORK( J ), WORK( J+1 ) )
                     IF( BETA.GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
!
                     WORK( J+N ) = WORK( J+N ) - &
                                   DDOT( J-KI-1, T( KI+1, J ), 1, &
                                   WORK( KI+1+N ), 1 )
!
                     WORK( J+1+N ) = WORK( J+1+N ) - &
                                     DDOT( J-KI-1, T( KI+1, J+1 ), 1, &
                                     WORK( KI+1+N ), 1 )
!
!                    Solve
!                      [T(J,J)-WR   T(J,J+1)     ]'* X = SCALE*( WORK1 )
!                      [T(J+1,J)    T(J+1,J+1)-WR]             ( WORK2 )
!
                     CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, &
                                  ZERO, X, 2, SCALE, XNORM, IERR )
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) &
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+1+N ) = X( 2, 1 )
!
                     VMAX = MAX( ABS( WORK( J+N ) ), &
                            ABS( WORK( J+1+N ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
!
                  END IF
  170          CONTINUE
!
!              Copy the vector x or Q*x to VL and normalize.
!
               IF( .NOT.OVER ) THEN
                  CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
!
                  II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
                  REMAX = ONE / ABS( VL( II, IS ) )
                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
!
                  DO 180 K = 1, KI - 1
                     VL( K, IS ) = ZERO
  180             CONTINUE
!
               ELSE
!
                  IF( KI.LT.N ) &
                     CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, &
                                 WORK( KI+1+N ), 1, WORK( KI+N ), &
                                 VL( 1, KI ), 1 )
!
                  II = IDAMAX( N, VL( 1, KI ), 1 )
                  REMAX = ONE / ABS( VL( II, KI ) )
                  CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
!
               END IF
!
            ELSE
!
!              Complex left eigenvector.
!
!               Initial solve:
!                 ((T(KI,KI)    T(KI,KI+1) )' - (WR - I* WI))*X = 0.
!                 ((T(KI+1,KI) T(KI+1,KI+1))                )
!
               IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
                  WORK( KI+N ) = WI / T( KI, KI+1 )
                  WORK( KI+1+N2 ) = ONE
               ELSE
                  WORK( KI+N ) = ONE
                  WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
               END IF
               WORK( KI+1+N ) = ZERO
               WORK( KI+N2 ) = ZERO
!
!              Form right-hand side
!
               DO 190 K = KI + 2, N
                  WORK( K+N ) = -WORK( KI+N )*T( KI, K )
                  WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
  190          CONTINUE
!
!              Solve complex quasi-triangular system:
!              ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
!
               VMAX = ONE
               VCRIT = BIGNUM
!
               JNXT = KI + 2
               DO 200 J = KI + 2, N
                  IF( J.LT.JNXT ) &
                     GO TO 200
                  J1 = J
                  J2 = J
                  JNXT = J + 1
                  IF( J.LT.N ) THEN
                     IF( T( J+1, J ).NE.ZERO ) THEN
                        J2 = J + 1
                        JNXT = J + 2
                     END IF
                  END IF
!
                  IF( J1.EQ.J2 ) THEN
!
!                    1-by-1 diagonal block
!
!                    Scale if necessary to avoid overflow when
!                    forming the right-hand side elements.
!
                     IF( WORK( J ).GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
!
                     WORK( J+N ) = WORK( J+N ) - &
                                   DDOT( J-KI-2, T( KI+2, J ), 1, &
                                   WORK( KI+2+N ), 1 )
                     WORK( J+N2 ) = WORK( J+N2 ) - &
                                    DDOT( J-KI-2, T( KI+2, J ), 1, &
                                    WORK( KI+2+N2 ), 1 )
!
!                    Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
!
                     CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, &
                                  -WI, X, 2, SCALE, XNORM, IERR )
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) THEN
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
                     VMAX = MAX( ABS( WORK( J+N ) ), &
                            ABS( WORK( J+N2 ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
!
                  ELSE
!
!                    2-by-2 diagonal block
!
!                    Scale if necessary to avoid overflow when forming
!                    the right-hand side elements.
!
                     BETA = MAX( WORK( J ), WORK( J+1 ) )
                     IF( BETA.GT.VCRIT ) THEN
                        REC = ONE / VMAX
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
                        CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
                        VMAX = ONE
                        VCRIT = BIGNUM
                     END IF
!
                     WORK( J+N ) = WORK( J+N ) - &
                                   DDOT( J-KI-2, T( KI+2, J ), 1, &
                                   WORK( KI+2+N ), 1 )
!
                     WORK( J+N2 ) = WORK( J+N2 ) - &
                                    DDOT( J-KI-2, T( KI+2, J ), 1, &
                                    WORK( KI+2+N2 ), 1 )
!
                     WORK( J+1+N ) = WORK( J+1+N ) - &
                                     DDOT( J-KI-2, T( KI+2, J+1 ), 1, &
                                     WORK( KI+2+N ), 1 )
!
                     WORK( J+1+N2 ) = WORK( J+1+N2 ) - &
                                      DDOT( J-KI-2, T( KI+2, J+1 ), 1, &
                                      WORK( KI+2+N2 ), 1 )
!
!                    Solve 2-by-2 complex linear equation
!                      ([T(j,j)   T(j,j+1)  ]'-(wr-i*wi)*I)*X = SCALE*B
!                      ([T(j+1,j) T(j+1,j+1)]             )
!
                     CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), &
                                  LDT, ONE, ONE, WORK( J+N ), N, WR, &
                                  -WI, X, 2, SCALE, XNORM, IERR )
!
!                    Scale if necessary
!
                     IF( SCALE.NE.ONE ) THEN
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
                     END IF
                     WORK( J+N ) = X( 1, 1 )
                     WORK( J+N2 ) = X( 1, 2 )
                     WORK( J+1+N ) = X( 2, 1 )
                     WORK( J+1+N2 ) = X( 2, 2 )
                     VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), &
                            ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
                     VCRIT = BIGNUM / VMAX
!
                  END IF
  200          CONTINUE
!
!              Copy the vector x or Q*x to VL and normalize.
!
  210          CONTINUE
               IF( .NOT.OVER ) THEN
                  CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
                  CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), &
                              1 )
!
                  EMAX = ZERO
                  DO 220 K = KI, N
                     EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ &
                            ABS( VL( K, IS+1 ) ) )
  220             CONTINUE
                  REMAX = ONE / EMAX
                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
!
                  DO 230 K = 1, KI - 1
                     VL( K, IS ) = ZERO
                     VL( K, IS+1 ) = ZERO
  230             CONTINUE
               ELSE
                  IF( KI.LT.N-1 ) THEN
                     CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), &
                                 LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), &
                                 VL( 1, KI ), 1 )
                     CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), &
                                 LDVL, WORK( KI+2+N2 ), 1, &
                                 WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
                  ELSE
                     CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
                     CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
                  END IF
!
                  EMAX = ZERO
                  DO 240 K = 1, N
                     EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ &
                            ABS( VL( K, KI+1 ) ) )
  240             CONTINUE
                  REMAX = ONE / EMAX
                  CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
                  CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
!
               END IF
!
            END IF
!
            IS = IS + 1
            IF( IP.NE.0 ) &
               IS = IS + 1
  250       CONTINUE
            IF( IP.EQ.-1 ) &
               IP = 0
            IF( IP.EQ.1 ) &
               IP = -1
!
  260    CONTINUE
!
      END IF
!
      RETURN
!
!     End of DTREVC
!
      END
      SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            IFST, ILST, INFO, LDQ, LDT, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTREXC reorders the real Schur factorization of a real matrix
!  A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
!  moved to row ILST.
!
!  The real Schur form T is reordered by an orthogonal similarity
!  transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
!  is updated by postmultiplying it with Z.
!
!  T must be in Schur canonical form (as returned by DHSEQR), that is,
!  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!  2-by-2 diagonal block has its diagonal elements equal and its
!  off-diagonal elements of opposite sign.
!
!  Arguments
!  =========
!
!  COMPQ   (input) CHARACTER*1
!          = 'V':  update the matrix Q of Schur vectors;
!          = 'N':  do not update Q.
!
!  N       (input) INTEGER
!          The order of the matrix T. N >= 0.
!
!  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
!          On entry, the upper quasi-triangular matrix T, in Schur
!          Schur canonical form.
!          On exit, the reordered upper quasi-triangular matrix, again
!          in Schur canonical form.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
!          On exit, if COMPQ = 'V', Q has been postmultiplied by the
!          orthogonal transformation matrix Z which reorders T.
!          If COMPQ = 'N', Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.  LDQ >= max(1,N).
!
!  IFST    (input/output) INTEGER
!  ILST    (input/output) INTEGER
!          Specify the reordering of the diagonal blocks of T.
!          The block with row index IFST is moved to row ILST, by a
!          sequence of transpositions between adjacent blocks.
!          On exit, if IFST pointed on entry to the second row of a
!          2-by-2 block, it is changed to point to the first row; ILST
!          always points to the first row of the block in its final
!          position (which may differ from its input value by +1 or -1).
!          1 <= IFST <= N; 1 <= ILST <= N.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          = 1:  two adjacent blocks were too close to swap (the problem
!                is very ill-conditioned); T may have been partially
!                reordered, and ILST points to the first row of the
!                current position of the block being moved.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            WANTQ
      INTEGER            HERE, NBF, NBL, NBNEXT
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLAEXC, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input arguments.
!
      INFO = 0
      WANTQ = LSAME( COMPQ, 'V' )
      IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
         INFO = -6
      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
         INFO = -7
      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTREXC', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.LE.1 ) &
         RETURN
!
!     Determine the first row of specified block
!     and find out it is 1 by 1 or 2 by 2.
!
      IF( IFST.GT.1 ) THEN
         IF( T( IFST, IFST-1 ).NE.ZERO ) &
            IFST = IFST - 1
      END IF
      NBF = 1
      IF( IFST.LT.N ) THEN
         IF( T( IFST+1, IFST ).NE.ZERO ) &
            NBF = 2
      END IF
!
!     Determine the first row of the final block
!     and find out it is 1 by 1 or 2 by 2.
!
      IF( ILST.GT.1 ) THEN
         IF( T( ILST, ILST-1 ).NE.ZERO ) &
            ILST = ILST - 1
      END IF
      NBL = 1
      IF( ILST.LT.N ) THEN
         IF( T( ILST+1, ILST ).NE.ZERO ) &
            NBL = 2
      END IF
!
      IF( IFST.EQ.ILST ) &
         RETURN
!
      IF( IFST.LT.ILST ) THEN
!
!        Update ILST
!
         IF( NBF.EQ.2 .AND. NBL.EQ.1 ) &
            ILST = ILST - 1
         IF( NBF.EQ.1 .AND. NBL.EQ.2 ) &
            ILST = ILST + 1
!
         HERE = IFST
!
   10    CONTINUE
!
!        Swap block with next one below
!
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
!
!           Current block either 1 by 1 or 2 by 2
!
            NBNEXT = 1
            IF( HERE+NBF+1.LE.N ) THEN
               IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, &
                         WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE + NBNEXT
!
!           Test if 2 by 2 block breaks into two 1 by 1 blocks
!
            IF( NBF.EQ.2 ) THEN
               IF( T( HERE+1, HERE ).EQ.ZERO ) &
                  NBF = 3
            END IF
!
         ELSE
!
!           Current block consists of two 1 by 1 blocks each of which
!           must be swapped individually
!
            NBNEXT = 1
            IF( HERE+3.LE.N ) THEN
               IF( T( HERE+3, HERE+2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, &
                         WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
!
!              Swap two 1 by 1 blocks, no problems possible
!
               CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, &
                            WORK, INFO )
               HERE = HERE + 1
            ELSE
!
!              Recompute NBNEXT in case 2 by 2 split
!
               IF( T( HERE+2, HERE+1 ).EQ.ZERO ) &
                  NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
!
!                 2 by 2 Block did not split
!
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, &
                               NBNEXT, WORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 2
               ELSE
!
!                 2 by 2 Block did split
!
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, &
                               WORK, INFO )
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, &
                               WORK, INFO )
                  HERE = HERE + 2
               END IF
            END IF
         END IF
         IF( HERE.LT.ILST ) &
            GO TO 10
!
      ELSE
!
         HERE = IFST
   20    CONTINUE
!
!        Swap block with next one above
!
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
!
!           Current block either 1 by 1 or 2 by 2
!
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( T( HERE-1, HERE-2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, &
                         NBF, WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE - NBNEXT
!
!           Test if 2 by 2 block breaks into two 1 by 1 blocks
!
            IF( NBF.EQ.2 ) THEN
               IF( T( HERE+1, HERE ).EQ.ZERO ) &
                  NBF = 3
            END IF
!
         ELSE
!
!           Current block consists of two 1 by 1 blocks each of which
!           must be swapped individually
!
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( T( HERE-1, HERE-2 ).NE.ZERO ) &
                  NBNEXT = 2
            END IF
            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, &
                         1, WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
!
!              Swap two 1 by 1 blocks, no problems possible
!
               CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, &
                            WORK, INFO )
               HERE = HERE - 1
            ELSE
!
!              Recompute NBNEXT in case 2 by 2 split
!
               IF( T( HERE, HERE-1 ).EQ.ZERO ) &
                  NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
!
!                 2 by 2 Block did not split
!
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, &
                               WORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 2
               ELSE
!
!                 2 by 2 Block did split
!
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, &
                               WORK, INFO )
                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, &
                               WORK, INFO )
                  HERE = HERE - 2
               END IF
            END IF
         END IF
         IF( HERE.GT.ILST ) &
            GO TO 20
      END IF
      ILST = HERE
!
      RETURN
!
!     End of DTREXC
!
      END
      SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, &
                         LDX, FERR, BERR, WORK, IWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, LDX, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), &
                         WORK( * ), X( LDX, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRRFS provides error bounds and backward error estimates for the
!  solution to a system of linear equations with a triangular
!  coefficient matrix.
!
!  The solution matrix X must be computed by DTRTRS or some other
!  means before entering this routine.  DTRRFS does not do iterative
!  refinement because doing so cannot improve the backward error.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrices B and X.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of the array A contains the upper
!          triangular matrix, and the strictly lower triangular part of
!          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of the array A contains the lower triangular
!          matrix, and the strictly upper triangular part of A is not
!          referenced.  If DIAG = 'U', the diagonal elements of A are
!          also not referenced and are assumed to be 1.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          The right hand side matrix B.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
!          The solution matrix X.
!
!  LDX     (input) INTEGER
!          The leading dimension of the array X.  LDX >= max(1,N).
!
!  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The estimated forward error bound for each solution vector
!          X(j) (the j-th column of the solution matrix X).
!          If XTRUE is the true solution corresponding to X(j), FERR(j)
!          is an estimated upper bound for the magnitude of the largest
!          element in (X(j) - XTRUE) divided by the magnitude of the
!          largest element in X(j).  The estimate is as reliable as
!          the estimate for RCOND, and is almost always a slight
!          overestimate of the true error.
!
!  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
!          The componentwise relative backward error of each solution
!          vector X(j) (i.e., the smallest relative change in
!          any element of A or B that makes X(j) an exact solution).
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN, NOUNIT, UPPER
      CHARACTER          TRANST
      INTEGER            I, J, K, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLACON, DTRMV, DTRSV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOTRAN = LSAME( TRANS, 'N' )
      NOUNIT = LSAME( DIAG, 'N' )
!
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. &
               LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRRFS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
!
      IF( NOTRAN ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
!
!     NZ = maximum number of nonzero elements in each row of A, plus 1
!
      NZ = N + 1
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
!
!     Do for each right hand side
!
      DO 250 J = 1, NRHS
!
!        Compute residual R = B - op(A) * X,
!        where op(A) = A or A', depending on TRANS.
!
         CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
         CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
         CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
!
!        Compute componentwise relative backward error from formula
!
!        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
!
!        where abs(Z) is the componentwise absolute value of the matrix
!        or vector Z.  If the i-th component of the denominator is less
!        than SAFE2, then SAFE1 is added to the i-th components of the
!        numerator and denominator before dividing.
!
         DO 20 I = 1, N
            WORK( I ) = ABS( B( I, J ) )
   20    CONTINUE
!
         IF( NOTRAN ) THEN
!
!           Compute abs(A)*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               IF( NOUNIT ) THEN
                  DO 40 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 30 I = 1, K
                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   30                CONTINUE
   40             CONTINUE
               ELSE
                  DO 60 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 50 I = 1, K - 1
                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   50                CONTINUE
                     WORK( K ) = WORK( K ) + XK
   60             CONTINUE
               END IF
            ELSE
               IF( NOUNIT ) THEN
                  DO 80 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 70 I = K, N
                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   70                CONTINUE
   80             CONTINUE
               ELSE
                  DO 100 K = 1, N
                     XK = ABS( X( K, J ) )
                     DO 90 I = K + 1, N
                        WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
   90                CONTINUE
                     WORK( K ) = WORK( K ) + XK
  100             CONTINUE
               END IF
            END IF
         ELSE
!
!           Compute abs(A')*abs(X) + abs(B).
!
            IF( UPPER ) THEN
               IF( NOUNIT ) THEN
                  DO 120 K = 1, N
                     S = ZERO
                     DO 110 I = 1, K
                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
  110                CONTINUE
                     WORK( K ) = WORK( K ) + S
  120             CONTINUE
               ELSE
                  DO 140 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 130 I = 1, K - 1
                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
  130                CONTINUE
                     WORK( K ) = WORK( K ) + S
  140             CONTINUE
               END IF
            ELSE
               IF( NOUNIT ) THEN
                  DO 160 K = 1, N
                     S = ZERO
                     DO 150 I = K, N
                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
  150                CONTINUE
                     WORK( K ) = WORK( K ) + S
  160             CONTINUE
               ELSE
                  DO 180 K = 1, N
                     S = ABS( X( K, J ) )
                     DO 170 I = K + 1, N
                        S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
  170                CONTINUE
                     WORK( K ) = WORK( K ) + S
  180             CONTINUE
               END IF
            END IF
         END IF
         S = ZERO
         DO 190 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
            ELSE
               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / &
                   ( WORK( I )+SAFE1 ) )
            END IF
  190    CONTINUE
         BERR( J ) = S
!
!        Bound error from formula
!
!        norm(X - XTRUE) / norm(X) .le. FERR =
!        norm( abs(inv(op(A)))*
!           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
!
!        where
!          norm(Z) is the magnitude of the largest component of Z
!          inv(op(A)) is the inverse of op(A)
!          abs(Z) is the componentwise absolute value of the matrix or
!             vector Z
!          NZ is the maximum number of nonzeros in any row of A, plus 1
!          EPS is machine epsilon
!
!        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
!        is incremented by SAFE1 if the i-th component of
!        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
!
!        Use DLACON to estimate the infinity-norm of the matrix
!           inv(op(A)) * diag(W),
!        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
!
         DO 200 I = 1, N
            IF( WORK( I ).GT.SAFE2 ) THEN
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
            ELSE
               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
            END IF
  200    CONTINUE
!
         KASE = 0
  210    CONTINUE
         CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), &
                      KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Multiply by diag(W)*inv(op(A)').
!
               CALL DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ), &
                           1 )
               DO 220 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  220          CONTINUE
            ELSE
!
!              Multiply by inv(op(A))*diag(W).
!
               DO 230 I = 1, N
                  WORK( N+I ) = WORK( I )*WORK( N+I )
  230          CONTINUE
               CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), &
                           1 )
            END IF
            GO TO 210
         END IF
!
!        Normalize error.
!
         LSTRES = ZERO
         DO 240 I = 1, N
            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
  240    CONTINUE
         IF( LSTRES.NE.ZERO ) &
            FERR( J ) = FERR( J ) / LSTRES
!
  250 CONTINUE
!
      RETURN
!
!     End of DTRRFS
!
      END
      SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, &
                         M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER          COMPQ, JOB
      INTEGER            INFO, LDQ, LDT, LIWORK, LWORK, M, N
      DOUBLE PRECISION   S, SEP
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), &
                         WR( * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSEN reorders the real Schur factorization of a real matrix
!  A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!  the leading diagonal blocks of the upper quasi-triangular matrix T,
!  and the leading columns of Q form an orthonormal basis of the
!  corresponding right invariant subspace.
!
!  Optionally the routine computes the reciprocal condition numbers of
!  the cluster of eigenvalues and/or the invariant subspace.
!
!  T must be in Schur canonical form (as returned by DHSEQR), that is,
!  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!  2-by-2 diagonal block has its diagonal elemnts equal and its
!  off-diagonal elements of opposite sign.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies whether condition numbers are required for the
!          cluster of eigenvalues (S) or the invariant subspace (SEP):
!          = 'N': none;
!          = 'E': for eigenvalues only (S);
!          = 'V': for invariant subspace only (SEP);
!          = 'B': for both eigenvalues and invariant subspace (S and
!                 SEP).
!
!  COMPQ   (input) CHARACTER*1
!          = 'V': update the matrix Q of Schur vectors;
!          = 'N': do not update Q.
!
!  SELECT  (input) LOGICAL array, dimension (N)
!          SELECT specifies the eigenvalues in the selected cluster. To
!          select a real eigenvalue w(j), SELECT(j) must be set to
!          .TRUE.. To select a complex conjugate pair of eigenvalues
!          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
!          either SELECT(j) or SELECT(j+1) or both must be set to
!          .TRUE.; a complex conjugate pair of eigenvalues must be
!          either both included in the cluster or both excluded.
!
!  N       (input) INTEGER
!          The order of the matrix T. N >= 0.
!
!  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
!          On entry, the upper quasi-triangular matrix T, in Schur
!          canonical form.
!          On exit, T is overwritten by the reordered matrix T, again in
!          Schur canonical form, with the selected eigenvalues in the
!          leading diagonal blocks.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= max(1,N).
!
!  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
!          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
!          On exit, if COMPQ = 'V', Q has been postmultiplied by the
!          orthogonal transformation matrix which reorders T; the
!          leading M columns of Q form an orthonormal basis for the
!          specified invariant subspace.
!          If COMPQ = 'N', Q is not referenced.
!
!  LDQ     (input) INTEGER
!          The leading dimension of the array Q.
!          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
!
!  WR      (output) DOUBLE PRECISION array, dimension (N)
!  WI      (output) DOUBLE PRECISION array, dimension (N)
!          The real and imaginary parts, respectively, of the reordered
!          eigenvalues of T. The eigenvalues are stored in the same
!          order as on the diagonal of T, with WR(i) = T(i,i) and, if
!          T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
!          WI(i+1) = -WI(i). Note that if a complex eigenvalue is
!          sufficiently ill-conditioned, then its value may differ
!          significantly from its value before reordering.
!
!  M       (output) INTEGER
!          The dimension of the specified invariant subspace.
!          0 < = M <= N.
!
!  S       (output) DOUBLE PRECISION
!          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
!          condition number for the selected cluster of eigenvalues.
!          S cannot underestimate the true reciprocal condition number
!          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
!          If JOB = 'N' or 'V', S is not referenced.
!
!  SEP     (output) DOUBLE PRECISION
!          If JOB = 'V' or 'B', SEP is the estimated reciprocal
!          condition number of the specified invariant subspace. If
!          M = 0 or N, SEP = norm(T).
!          If JOB = 'N' or 'E', SEP is not referenced.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.
!          If JOB = 'N', LWORK >= max(1,N);
!          if JOB = 'E', LWORK >= M*(N-M);
!          if JOB = 'V' or 'B', LWORK >= 2*M*(N-M).
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  IWORK   (workspace) INTEGER array, dimension (LIWORK)
!          IF JOB = 'N' or 'E', IWORK is not referenced.
!
!  LIWORK  (input) INTEGER
!          The dimension of the array IWORK.
!          If JOB = 'N' or 'E', LIWORK >= 1;
!          if JOB = 'V' or 'B', LIWORK >= M*(N-M).
!
!          If LIWORK = -1, then a workspace query is assumed; the
!          routine only calculates the optimal size of the IWORK array,
!          returns this value as the first entry of the IWORK array, and
!          no error message related to LIWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          = 1: reordering of T failed because some eigenvalues are too
!               close to separate (the problem is very ill-conditioned);
!               T may have been partially reordered, and WR and WI
!               contain the eigenvalues in the same order as in T; S and
!               SEP (if requested) are set to zero.
!
!  Further Details
!  ===============
!
!  DTRSEN first collects the selected eigenvalues by computing an
!  orthogonal transformation Z to move them to the top left corner of T.
!  In other words, the selected eigenvalues are the eigenvalues of T11
!  in:
!
!                Z'*T*Z = ( T11 T12 ) n1
!                         (  0  T22 ) n2
!                            n1  n2
!
!  where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
!  of Z span the specified invariant subspace of T.
!
!  If T has been obtained from the real Schur factorization of a matrix
!  A = Q*T*Q', then the reordered real Schur factorization of A is given
!  by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
!  the corresponding invariant subspace of A.
!
!  The reciprocal condition number of the average of the eigenvalues of
!  T11 may be returned in S. S lies between 0 (very badly conditioned)
!  and 1 (very well conditioned). It is computed as follows. First we
!  compute R so that
!
!                         P = ( I  R ) n1
!                             ( 0  0 ) n2
!                               n1 n2
!
!  is the projector on the invariant subspace associated with T11.
!  R is the solution of the Sylvester equation:
!
!                        T11*R - R*T22 = T12.
!
!  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
!  the two-norm of M. Then S is computed as the lower bound
!
!                      (1 + F-norm(R)**2)**(-1/2)
!
!  on the reciprocal of 2-norm(P), the true reciprocal condition number.
!  S cannot underestimate 1 / 2-norm(P) by more than a factor of
!  sqrt(N).
!
!  An approximate error bound for the computed average of the
!  eigenvalues of T11 is
!
!                         EPS * norm(T) / S
!
!  where EPS is the machine precision.
!
!  The reciprocal condition number of the right invariant subspace
!  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
!  SEP is defined as the separation of T11 and T22:
!
!                     sep( T11, T22 ) = sigma-min( C )
!
!  where sigma-min(C) is the smallest singular value of the
!  n1*n2-by-n1*n2 matrix
!
!     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
!
!  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
!  product. We estimate sigma-min(C) by the reciprocal of an estimate of
!  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
!  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
!
!  When SEP is small, small changes in T can cause large changes in
!  the invariant subspace. An approximate bound on the maximum angular
!  error in the computed right invariant subspace is
!
!                      EPS * norm(T) / SEP
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS, &
                         WANTSP
      INTEGER            IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2, &
                         NN
      DOUBLE PRECISION   EST, RNORM, SCALE
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLANGE
      EXTERNAL           LSAME, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLACPY, DTREXC, DTRSYL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
      WANTQ = LSAME( COMPQ, 'V' )
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) &
           THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
         INFO = -8
      ELSE
!
!        Set M to the dimension of the specified invariant subspace,
!        and test LWORK and LIWORK.
!
         M = 0
         PAIR = .FALSE.
         DO 10 K = 1, N
            IF( PAIR ) THEN
               PAIR = .FALSE.
            ELSE
               IF( K.LT.N ) THEN
                  IF( T( K+1, K ).EQ.ZERO ) THEN
                     IF( SELECT( K ) ) &
                        M = M + 1
                  ELSE
                     PAIR = .TRUE.
                     IF( SELECT( K ) .OR. SELECT( K+1 ) ) &
                        M = M + 2
                  END IF
               ELSE
                  IF( SELECT( N ) ) &
                     M = M + 1
               END IF
            END IF
   10    CONTINUE
!
         N1 = M
         N2 = N - M
         NN = N1*N2
!
         IF( WANTSP ) THEN
            LWMIN = MAX( 1, 2*NN )
            LIWMIN = MAX( 1, NN )
         ELSE IF( LSAME( JOB, 'N' ) ) THEN
            LWMIN = MAX( 1, N )
            LIWMIN = 1
         ELSE IF( LSAME( JOB, 'E' ) ) THEN
            LWMIN = MAX( 1, NN )
            LIWMIN = 1
         END IF
!
         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -15
         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -17
         END IF
      END IF
!
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRSEN', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( M.EQ.N .OR. M.EQ.0 ) THEN
         IF( WANTS ) &
            S = ONE
         IF( WANTSP ) &
            SEP = DLANGE( '1', N, N, T, LDT, WORK )
         GO TO 40
      END IF
!
!     Collect the selected blocks at the top-left corner of T.
!
      KS = 0
      PAIR = .FALSE.
      DO 20 K = 1, N
         IF( PAIR ) THEN
            PAIR = .FALSE.
         ELSE
            SWAP = SELECT( K )
            IF( K.LT.N ) THEN
               IF( T( K+1, K ).NE.ZERO ) THEN
                  PAIR = .TRUE.
                  SWAP = SWAP .OR. SELECT( K+1 )
               END IF
            END IF
            IF( SWAP ) THEN
               KS = KS + 1
!
!              Swap the K-th block to position KS.
!
               IERR = 0
               KK = K
               IF( K.NE.KS ) &
                  CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, &
                               IERR )
               IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
!
!                 Blocks too close to swap: exit.
!
                  INFO = 1
                  IF( WANTS ) &
                     S = ZERO
                  IF( WANTSP ) &
                     SEP = ZERO
                  GO TO 40
               END IF
               IF( PAIR ) &
                  KS = KS + 1
            END IF
         END IF
   20 CONTINUE
!
      IF( WANTS ) THEN
!
!        Solve Sylvester equation for R:
!
!           T11*R - R*T22 = scale*T12
!
         CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
         CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), &
                      LDT, WORK, N1, SCALE, IERR )
!
!        Estimate the reciprocal of the condition number of the cluster
!        of eigenvalues.
!
         RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK )
         IF( RNORM.EQ.ZERO ) THEN
            S = ONE
         ELSE
            S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* &
                SQRT( RNORM ) )
         END IF
      END IF
!
      IF( WANTSP ) THEN
!
!        Estimate sep(T11,T22).
!
         EST = ZERO
         KASE = 0
   30    CONTINUE
         CALL DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
!
!              Solve  T11*R - R*T22 = scale*X.
!
               CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, &
                            T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, &
                            IERR )
            ELSE
!
!              Solve  T11'*R - R*T22' = scale*X.
!
               CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT, &
                            T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, &
                            IERR )
            END IF
            GO TO 30
         END IF
!
         SEP = SCALE / EST
      END IF
!
   40 CONTINUE
!
!     Store the output eigenvalues in WR and WI.
!
      DO 50 K = 1, N
         WR( K ) = T( K, K )
         WI( K ) = ZERO
   50 CONTINUE
      DO 60 K = 1, N - 1
         IF( T( K+1, K ).NE.ZERO ) THEN
            WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* &
                      SQRT( ABS( T( K+1, K ) ) )
            WI( K+1 ) = -WI( K )
         END IF
   60 CONTINUE
!
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
!
      RETURN
!
!     End of DTRSEN
!
      END
      SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, &
                         LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          HOWMNY, JOB
      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
!     ..
!     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), &
                         VR( LDVR, * ), WORK( LDWORK, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSNA estimates reciprocal condition numbers for specified
!  eigenvalues and/or right eigenvectors of a real upper
!  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
!  orthogonal).
!
!  T must be in Schur canonical form (as returned by DHSEQR), that is,
!  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!  2-by-2 diagonal block has its diagonal elements equal and its
!  off-diagonal elements of opposite sign.
!
!  Arguments
!  =========
!
!  JOB     (input) CHARACTER*1
!          Specifies whether condition numbers are required for
!          eigenvalues (S) or eigenvectors (SEP):
!          = 'E': for eigenvalues only (S);
!          = 'V': for eigenvectors only (SEP);
!          = 'B': for both eigenvalues and eigenvectors (S and SEP).
!
!  HOWMNY  (input) CHARACTER*1
!          = 'A': compute condition numbers for all eigenpairs;
!          = 'S': compute condition numbers for selected eigenpairs
!                 specified by the array SELECT.
!
!  SELECT  (input) LOGICAL array, dimension (N)
!          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
!          condition numbers are required. To select condition numbers
!          for the eigenpair corresponding to a real eigenvalue w(j),
!          SELECT(j) must be set to .TRUE.. To select condition numbers
!          corresponding to a complex conjugate pair of eigenvalues w(j)
!          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
!          set to .TRUE..
!          If HOWMNY = 'A', SELECT is not referenced.
!
!  N       (input) INTEGER
!          The order of the matrix T. N >= 0.
!
!  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
!          The upper quasi-triangular matrix T, in Schur canonical form.
!
!  LDT     (input) INTEGER
!          The leading dimension of the array T. LDT >= max(1,N).
!
!  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)
!          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
!          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
!          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!          must be stored in consecutive columns of VL, as returned by
!          DHSEIN or DTREVC.
!          If JOB = 'V', VL is not referenced.
!
!  LDVL    (input) INTEGER
!          The leading dimension of the array VL.
!          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
!
!  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)
!          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
!          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
!          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
!          must be stored in consecutive columns of VR, as returned by
!          DHSEIN or DTREVC.
!          If JOB = 'V', VR is not referenced.
!
!  LDVR    (input) INTEGER
!          The leading dimension of the array VR.
!          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
!
!  S       (output) DOUBLE PRECISION array, dimension (MM)
!          If JOB = 'E' or 'B', the reciprocal condition numbers of the
!          selected eigenvalues, stored in consecutive elements of the
!          array. For a complex conjugate pair of eigenvalues two
!          consecutive elements of S are set to the same value. Thus
!          S(j), SEP(j), and the j-th columns of VL and VR all
!          correspond to the same eigenpair (but not in general the
!          j-th eigenpair, unless all eigenpairs are selected).
!          If JOB = 'V', S is not referenced.
!
!  SEP     (output) DOUBLE PRECISION array, dimension (MM)
!          If JOB = 'V' or 'B', the estimated reciprocal condition
!          numbers of the selected eigenvectors, stored in consecutive
!          elements of the array. For a complex eigenvector two
!          consecutive elements of SEP are set to the same value. If
!          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
!          is set to 0; this can only occur when the true value would be
!          very small anyway.
!          If JOB = 'E', SEP is not referenced.
!
!  MM      (input) INTEGER
!          The number of elements in the arrays S (if JOB = 'E' or 'B')
!           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
!
!  M       (output) INTEGER
!          The number of elements of the arrays S and/or SEP actually
!          used to store the estimated condition numbers.
!          If HOWMNY = 'A', M is set to N.
!
!  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1)
!          If JOB = 'E', WORK is not referenced.
!
!  LDWORK  (input) INTEGER
!          The leading dimension of the array WORK.
!          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
!
!  IWORK   (workspace) INTEGER array, dimension (N)
!          If JOB = 'E', IWORK is not referenced.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The reciprocal of the condition number of an eigenvalue lambda is
!  defined as
!
!          S(lambda) = |v'*u| / (norm(u)*norm(v))
!
!  where u and v are the right and left eigenvectors of T corresponding
!  to lambda; v' denotes the conjugate-transpose of v, and norm(u)
!  denotes the Euclidean norm. These reciprocal condition numbers always
!  lie between zero (very badly conditioned) and one (very well
!  conditioned). If n = 1, S(lambda) is defined to be 1.
!
!  An approximate error bound for a computed eigenvalue W(i) is given by
!
!                      EPS * norm(T) / S(i)
!
!  where EPS is the machine precision.
!
!  The reciprocal of the condition number of the right eigenvector u
!  corresponding to lambda is defined as follows. Suppose
!
!              T = ( lambda  c  )
!                  (   0    T22 )
!
!  Then the reciprocal condition number is
!
!          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
!
!  where sigma-min denotes the smallest singular value. We approximate
!  the smallest singular value by the reciprocal of an estimate of the
!  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
!  defined to be abs(T(1,1)).
!
!  An approximate error bound for a computed right eigenvector VR(i)
!  is given by
!
!                      EPS * norm(T) / SEP(i)
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            PAIR, SOMCON, WANTBH, WANTS, WANTSP
      INTEGER            I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
      DOUBLE PRECISION   BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM, &
                         MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DUMMY( 1 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2, DNRM2
      EXTERNAL           LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLACON, DLACPY, DLAQTR, DTREXC, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
!
      SOMCON = LSAME( HOWMNY, 'S' )
!
      INFO = 0
      IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      ELSE
!
!        Set M to the number of eigenpairs for which condition numbers
!        are required, and test MM.
!
         IF( SOMCON ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 K = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
               ELSE
                  IF( K.LT.N ) THEN
                     IF( T( K+1, K ).EQ.ZERO ) THEN
                        IF( SELECT( K ) ) &
                           M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( K ) .OR. SELECT( K+1 ) ) &
                           M = M + 2
                     END IF
                  ELSE
                     IF( SELECT( N ) ) &
                        M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
!
         IF( MM.LT.M ) THEN
            INFO = -13
         ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
            INFO = -16
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRSNA', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
      IF( N.EQ.1 ) THEN
         IF( SOMCON ) THEN
            IF( .NOT.SELECT( 1 ) ) &
               RETURN
         END IF
         IF( WANTS ) &
            S( 1 ) = ONE
         IF( WANTSP ) &
            SEP( 1 ) = ABS( T( 1, 1 ) )
         RETURN
      END IF
!
!     Get machine constants
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
!
      KS = 0
      PAIR = .FALSE.
      DO 60 K = 1, N
!
!        Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
!
         IF( PAIR ) THEN
            PAIR = .FALSE.
            GO TO 60
         ELSE
            IF( K.LT.N ) &
               PAIR = T( K+1, K ).NE.ZERO
         END IF
!
!        Determine whether condition numbers are required for the k-th
!        eigenpair.
!
         IF( SOMCON ) THEN
            IF( PAIR ) THEN
               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) ) &
                  GO TO 60
            ELSE
               IF( .NOT.SELECT( K ) ) &
                  GO TO 60
            END IF
         END IF
!
         KS = KS + 1
!
         IF( WANTS ) THEN
!
!           Compute the reciprocal condition number of the k-th
!           eigenvalue.
!
            IF( .NOT.PAIR ) THEN
!
!              Real eigenvalue.
!
               PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
               RNRM = DNRM2( N, VR( 1, KS ), 1 )
               LNRM = DNRM2( N, VL( 1, KS ), 1 )
               S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
            ELSE
!
!              Complex eigenvalue.
!
               PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
               PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ), &
                       1 )
               PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
               PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ), &
                       1 )
               RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ), &
                      DNRM2( N, VR( 1, KS+1 ), 1 ) )
               LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ), &
                      DNRM2( N, VL( 1, KS+1 ), 1 ) )
               COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
               S( KS ) = COND
               S( KS+1 ) = COND
            END IF
         END IF
!
         IF( WANTSP ) THEN
!
!           Estimate the reciprocal condition number of the k-th
!           eigenvector.
!
!           Copy the matrix T to the array WORK and swap the diagonal
!           block beginning at T(k,k) to the (1,1) position.
!
            CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
            IFST = K
            ILST = 1
            CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST, &
                         WORK( 1, N+1 ), IERR )
!
            IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
!
!              Could not swap because blocks not well separated
!
               SCALE = ONE
               EST = BIGNUM
            ELSE
!
!              Reordering successful
!
               IF( WORK( 2, 1 ).EQ.ZERO ) THEN
!
!                 Form C = T22 - lambda*I in WORK(2:N,2:N).
!
                  DO 20 I = 2, N
                     WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
   20             CONTINUE
                  N2 = 1
                  NN = N - 1
               ELSE
!
!                 Triangularize the 2 by 2 block by unitary
!                 transformation U = [  cs   i*ss ]
!                                    [ i*ss   cs  ].
!                 such that the (1,1) position of WORK is complex
!                 eigenvalue lambda with positive imaginary part. (2,2)
!                 position of WORK is the complex eigenvalue lambda
!                 with negative imaginary  part.
!
                  MU = SQRT( ABS( WORK( 1, 2 ) ) )* &
                       SQRT( ABS( WORK( 2, 1 ) ) )
                  DELTA = DLAPY2( MU, WORK( 2, 1 ) )
                  CS = MU / DELTA
                  SN = -WORK( 2, 1 ) / DELTA
!
!                 Form
!
!                 C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
!                                        [   mu                     ]
!                                        [         ..               ]
!                                        [             ..           ]
!                                        [                  mu      ]
!                 where C' is conjugate transpose of complex matrix C,
!                 and RWORK is stored starting in the N+1-st column of
!                 WORK.
!
                  DO 30 J = 3, N
                     WORK( 2, J ) = CS*WORK( 2, J )
                     WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
   30             CONTINUE
                  WORK( 2, 2 ) = ZERO
!
                  WORK( 1, N+1 ) = TWO*MU
                  DO 40 I = 2, N - 1
                     WORK( I, N+1 ) = SN*WORK( 1, I+1 )
   40             CONTINUE
                  N2 = 2
                  NN = 2*( N-1 )
               END IF
!
!              Estimate norm(inv(C'))
!
               EST = ZERO
               KASE = 0
   50          CONTINUE
               CALL DLACON( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK, &
                            EST, KASE )
               IF( KASE.NE.0 ) THEN
                  IF( KASE.EQ.1 ) THEN
                     IF( N2.EQ.1 ) THEN
!
!                       Real eigenvalue: solve C'*x = scale*c.
!
                        CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ), &
                                     LDWORK, DUMMY, DUMM, SCALE, &
                                     WORK( 1, N+4 ), WORK( 1, N+6 ), &
                                     IERR )
                     ELSE
!
!                       Complex eigenvalue: solve
!                       C'*(p+iq) = scale*(c+id) in real arithmetic.
!
                        CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ), &
                                     LDWORK, WORK( 1, N+1 ), MU, SCALE, &
                                     WORK( 1, N+4 ), WORK( 1, N+6 ), &
                                     IERR )
                     END IF
                  ELSE
                     IF( N2.EQ.1 ) THEN
!
!                       Real eigenvalue: solve C*x = scale*c.
!
                        CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ), &
                                     LDWORK, DUMMY, DUMM, SCALE, &
                                     WORK( 1, N+4 ), WORK( 1, N+6 ), &
                                     IERR )
                     ELSE
!
!                       Complex eigenvalue: solve
!                       C*(p+iq) = scale*(c+id) in real arithmetic.
!
                        CALL DLAQTR( .FALSE., .FALSE., N-1, &
                                     WORK( 2, 2 ), LDWORK, &
                                     WORK( 1, N+1 ), MU, SCALE, &
                                     WORK( 1, N+4 ), WORK( 1, N+6 ), &
                                     IERR )
!
                     END IF
                  END IF
!
                  GO TO 50
               END IF
            END IF
!
            SEP( KS ) = SCALE / MAX( EST, SMLNUM )
            IF( PAIR ) &
               SEP( KS+1 ) = SEP( KS )
         END IF
!
         IF( PAIR ) &
            KS = KS + 1
!
   60 CONTINUE
      RETURN
!
!     End of DTRSNA
!
      END
      SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, &
                         LDC, SCALE, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          TRANA, TRANB
      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
      DOUBLE PRECISION   SCALE
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSYL solves the real Sylvester matrix equation:
!
!     op(A)*X + X*op(B) = scale*C or
!     op(A)*X - X*op(B) = scale*C,
!
!  where op(A) = A or A**T, and  A and B are both upper quasi-
!  triangular. A is M-by-M and B is N-by-N; the right hand side C and
!  the solution X are M-by-N; and scale is an output scale factor, set
!  <= 1 to avoid overflow in X.
!
!  A and B must be in Schur canonical form (as returned by DHSEQR), that
!  is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
!  each 2-by-2 diagonal block has its diagonal elements equal and its
!  off-diagonal elements of opposite sign.
!
!  Arguments
!  =========
!
!  TRANA   (input) CHARACTER*1
!          Specifies the option op(A):
!          = 'N': op(A) = A    (No transpose)
!          = 'T': op(A) = A**T (Transpose)
!          = 'C': op(A) = A**H (Conjugate transpose = Transpose)
!
!  TRANB   (input) CHARACTER*1
!          Specifies the option op(B):
!          = 'N': op(B) = B    (No transpose)
!          = 'T': op(B) = B**T (Transpose)
!          = 'C': op(B) = B**H (Conjugate transpose = Transpose)
!
!  ISGN    (input) INTEGER
!          Specifies the sign in the equation:
!          = +1: solve op(A)*X + X*op(B) = scale*C
!          = -1: solve op(A)*X - X*op(B) = scale*C
!
!  M       (input) INTEGER
!          The order of the matrix A, and the number of rows in the
!          matrices X and C. M >= 0.
!
!  N       (input) INTEGER
!          The order of the matrix B, and the number of columns in the
!          matrices X and C. N >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
!          The upper quasi-triangular matrix A, in Schur canonical form.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
!          The upper quasi-triangular matrix B, in Schur canonical form.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B. LDB >= max(1,N).
!
!  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
!          On entry, the M-by-N right hand side matrix C.
!          On exit, C is overwritten by the solution matrix X.
!
!  LDC     (input) INTEGER
!          The leading dimension of the array C. LDC >= max(1,M)
!
!  SCALE   (output) DOUBLE PRECISION
!          The scale factor, scale, set <= 1 to avoid overflow in X.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          = 1: A and B have common or very close eigenvalues; perturbed
!               values were used to solve the equation (but the matrices
!               A and B are unchanged).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRNA, NOTRNB
      INTEGER            IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
      DOUBLE PRECISION   A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, &
                         SMLNUM, SUML, SUMR, XNORM
!     ..
!     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE
      EXTERNAL           LSAME, DDOT, DLAMCH, DLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLALN2, DLASY2, DSCAL, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Decode and Test input parameters
!
      NOTRNA = LSAME( TRANA, 'N' )
      NOTRNB = LSAME( TRANB, 'N' )
!
      INFO = 0
      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. &
          LSAME( TRANA, 'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. &
               LSAME( TRANB, 'C' ) ) THEN
         INFO = -2
      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRSYL', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 ) &
         RETURN
!
!     Set constants to control overflow
!
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SMLNUM*DBLE( M*N ) / EPS
      BIGNUM = ONE / SMLNUM
!
      SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), &
             EPS*DLANGE( 'M', N, N, B, LDB, DUM ) )
!
      SCALE = ONE
      SGN = ISGN
!
      IF( NOTRNA .AND. NOTRNB ) THEN
!
!        Solve    A*X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-left corner column by column by
!
!         A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                  M                         L-1
!        R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
!                I=K+1                       J=1
!
!        Start column loop (index = L)
!        L1 (L2) : column index of the first (first) row of X(K,L).
!
         LNEXT = 1
         DO 60 L = 1, N
            IF( L.LT.LNEXT ) &
               GO TO 60
            IF( L.EQ.N ) THEN
               L1 = L
               L2 = L
            ELSE
               IF( B( L+1, L ).NE.ZERO ) THEN
                  L1 = L
                  L2 = L + 1
                  LNEXT = L + 2
               ELSE
                  L1 = L
                  L2 = L
                  LNEXT = L + 1
               END IF
            END IF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L).
!
            KNEXT = M
            DO 50 K = M, 1, -1
               IF( K.GT.KNEXT ) &
                  GO TO 50
               IF( K.EQ.1 ) THEN
                  K1 = K
                  K2 = K
               ELSE
                  IF( A( K, K-1 ).NE.ZERO ) THEN
                     K1 = K - 1
                     K2 = K
                     KNEXT = K - 2
                  ELSE
                     K1 = K
                     K2 = K
                     KNEXT = K - 1
                  END IF
               END IF
!
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
                  SCALOC = ONE
!
                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 ) &
                        SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 10 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   10                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
!
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), &
                               LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 20 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   20                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
!
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
!
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
!
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), &
                               LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 30 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   30                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
!
                  CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2, &
                               A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, &
                               2, SCALOC, X, 2, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 40 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   40                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
!
   50       CONTINUE
!
   60    CONTINUE
!
      ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
!
!        Solve    A' *X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        upper-left corner column by column by
!
!          A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                   K-1                        L-1
!          R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
!                   I=1                        J=1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         LNEXT = 1
         DO 120 L = 1, N
            IF( L.LT.LNEXT ) &
               GO TO 120
            IF( L.EQ.N ) THEN
               L1 = L
               L2 = L
            ELSE
               IF( B( L+1, L ).NE.ZERO ) THEN
                  L1 = L
                  L2 = L + 1
                  LNEXT = L + 2
               ELSE
                  L1 = L
                  L2 = L
                  LNEXT = L + 1
               END IF
            END IF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
            KNEXT = 1
            DO 110 K = 1, M
               IF( K.LT.KNEXT ) &
                  GO TO 110
               IF( K.EQ.M ) THEN
                  K1 = K
                  K2 = K
               ELSE
                  IF( A( K+1, K ).NE.ZERO ) THEN
                     K1 = K
                     K2 = K + 1
                     KNEXT = K + 2
                  ELSE
                     K1 = K
                     K2 = K
                     KNEXT = K + 1
                  END IF
               END IF
!
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
                  SCALOC = ONE
!
                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 ) &
                        SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 70 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   70                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
!
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), &
                               LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 80 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   80                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
!
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), &
                               LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 90 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
   90                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
!
                  CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), &
                               LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, &
                               2, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 100 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  100                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
!
  110       CONTINUE
  120    CONTINUE
!
      ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
!
!        Solve    A'*X + ISGN*X*B' = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        top-right corner column by column by
!
!           A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
!
!        Where
!                     K-1                          N
!            R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
!                     I=1                        J=L+1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         LNEXT = N
         DO 180 L = N, 1, -1
            IF( L.GT.LNEXT ) &
               GO TO 180
            IF( L.EQ.1 ) THEN
               L1 = L
               L2 = L
            ELSE
               IF( B( L, L-1 ).NE.ZERO ) THEN
                  L1 = L - 1
                  L2 = L
                  LNEXT = L - 2
               ELSE
                  L1 = L
                  L2 = L
                  LNEXT = L - 1
               END IF
            END IF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
            KNEXT = 1
            DO 170 K = 1, M
               IF( K.LT.KNEXT ) &
                  GO TO 170
               IF( K.EQ.M ) THEN
                  K1 = K
                  K2 = K
               ELSE
                  IF( A( K+1, K ).NE.ZERO ) THEN
                     K1 = K
                     K2 = K + 1
                     KNEXT = K + 2
                  ELSE
                     K1 = K
                     K2 = K
                     KNEXT = K + 1
                  END IF
               END IF
!
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, &
                         B( L1, MIN( L1+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
                  SCALOC = ONE
!
                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 ) &
                        SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 130 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  130                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
!
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), &
                               LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 140 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  140                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
!
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), &
                               LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 150 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  150                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
!
                  CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), &
                               LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, &
                               2, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 160 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  160                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
!
  170       CONTINUE
  180    CONTINUE
!
      ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
!
!        Solve    A*X + ISGN*X*B' = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-right corner column by column by
!
!            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
!
!        Where
!                      M                          N
!            R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
!                    I=K+1                      J=L+1
!
!        Start column loop (index = L)
!        L1 (L2): column index of the first (last) row of X(K,L)
!
         LNEXT = N
         DO 240 L = N, 1, -1
            IF( L.GT.LNEXT ) &
               GO TO 240
            IF( L.EQ.1 ) THEN
               L1 = L
               L2 = L
            ELSE
               IF( B( L, L-1 ).NE.ZERO ) THEN
                  L1 = L - 1
                  L2 = L
                  LNEXT = L - 2
               ELSE
                  L1 = L
                  L2 = L
                  LNEXT = L - 1
               END IF
            END IF
!
!           Start row loop (index = K)
!           K1 (K2): row index of the first (last) row of X(K,L)
!
            KNEXT = M
            DO 230 K = M, 1, -1
               IF( K.GT.KNEXT ) &
                  GO TO 230
               IF( K.EQ.1 ) THEN
                  K1 = K
                  K2 = K
               ELSE
                  IF( A( K, K-1 ).NE.ZERO ) THEN
                     K1 = K - 1
                     K2 = K
                     KNEXT = K - 2
                  ELSE
                     K1 = K
                     K2 = K
                     KNEXT = K - 1
                  END IF
               END IF
!
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, &
                         B( L1, MIN( L1+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
                  SCALOC = ONE
!
                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 ) &
                        SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 190 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  190                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
!
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), &
                               LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 200 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  200                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
!
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
!
                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, &
                         C( MIN( K1+1, M ), L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
!
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), &
                               LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), &
                               ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 210 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  210                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
!
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L1 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L1, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
!
                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, &
                         C( MIN( K2+1, M ), L2 ), 1 )
                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, &
                         B( L2, MIN( L2+1, N ) ), LDB )
                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
!
                  CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), &
                               LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, &
                               2, XNORM, IERR )
                  IF( IERR.NE.0 ) &
                     INFO = 1
!
                  IF( SCALOC.NE.ONE ) THEN
                     DO 220 J = 1, N
                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
  220                CONTINUE
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
               END IF
!
  230       CONTINUE
  240    CONTINUE
!
      END IF
!
      RETURN
!
!     End of DTRSYL
!
      END
      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     February 29, 1992
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRTI2 computes the inverse of a real upper or lower triangular
!  matrix.
!
!  This is the Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the triangular matrix A.  If UPLO = 'U', the
!          leading n by n upper triangular part of the array A contains
!          the upper triangular matrix, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading n by n lower triangular part of the array A contains
!          the lower triangular matrix, and the strictly upper
!          triangular part of A is not referenced.  If DIAG = 'U', the
!          diagonal elements of A are also not referenced and are
!          assumed to be 1.
!
!          On exit, the (triangular) inverse of the original matrix, in
!          the same storage format.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DSCAL, DTRMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTI2', -INFO )
         RETURN
      END IF
!
      IF( UPPER ) THEN
!
!        Compute inverse of upper triangular matrix.
!
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
!
!           Compute elements 1:j-1 of j-th column.
!
            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, &
                        A( 1, J ), 1 )
            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
!
!        Compute inverse of lower triangular matrix.
!
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
!
!              Compute elements j+1:n of j-th column.
!
               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, &
                           A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DTRTI2
!
      END
      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRTRI computes the inverse of a real upper or lower triangular
!  matrix A.
!
!  This is the Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the triangular matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of the array A contains
!          the upper triangular matrix, and the strictly lower
!          triangular part of A is not referenced.  If UPLO = 'L', the
!          leading N-by-N lower triangular part of the array A contains
!          the lower triangular matrix, and the strictly upper
!          triangular part of A is not referenced.  If DIAG = 'U', the
!          diagonal elements of A are also not referenced and are
!          assumed to be 1.
!          On exit, the (triangular) inverse of the original matrix, in
!          the same storage format.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
!               matrix is singular and its inverse can not be computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JB, NB, NN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check for singularity if non-unit.
!
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO ) &
               RETURN
   10    CONTINUE
         INFO = 0
      END IF
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
!
!        Use unblocked code
!
         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
      ELSE
!
!        Use blocked code
!
         IF( UPPER ) THEN
!
!           Compute inverse of upper triangular matrix
!
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
!
!              Compute rows 1:j-1 of current block column
!
               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, &
                           JB, ONE, A, LDA, A( 1, J ), LDA )
               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, &
                           JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
!
!              Compute inverse of current diagonal block
!
               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
   20       CONTINUE
         ELSE
!
!           Compute inverse of lower triangular matrix
!
            NN = ( ( N-1 ) / NB )*NB + 1
            DO 30 J = NN, 1, -NB
               JB = MIN( NB, N-J+1 )
               IF( J+JB.LE.N ) THEN
!
!                 Compute rows j+jb:n of current block column
!
                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, &
                              N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, &
                              A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, &
                              N-J-JB+1, JB, -ONE, A( J, J ), LDA, &
                              A( J+JB, J ), LDA )
               END IF
!
!              Compute inverse of current diagonal block
!
               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
   30       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DTRTRI
!
      END
      SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, &
                         INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRTRS solves a triangular system of the form
!
!     A * X = B  or  A**T * X = B,
!
!  where A is a triangular matrix of order N, and B is an N-by-NRHS
!  matrix.  A check is made to verify that A is nonsingular.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          = 'U':  A is upper triangular;
!          = 'L':  A is lower triangular.
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!
!  DIAG    (input) CHARACTER*1
!          = 'N':  A is non-unit triangular;
!          = 'U':  A is unit triangular.
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
!          upper triangular part of the array A contains the upper
!          triangular matrix, and the strictly lower triangular part of
!          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
!          triangular part of the array A contains the lower triangular
!          matrix, and the strictly upper triangular part of A is not
!          referenced.  If DIAG = 'U', the diagonal elements of A are
!          also not referenced and are assumed to be 1.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, if INFO = 0, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = i, the i-th diagonal element of A is zero,
!               indicating that the matrix is singular and the solutions
!               X have not been computed.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. &
               LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 ) &
         RETURN
!
!     Check for singularity.
!
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO ) &
               RETURN
   10    CONTINUE
      END IF
      INFO = 0
!
!     Solve A * x = b  or  A' * x = b.
!
      CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, &
                  LDB )
!
      RETURN
!
!     End of DTRTRS
!
      END
      SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * )
!     ..
!
!  Purpose
!  =======
!
!  This routine is deprecated and has been replaced by routine DTZRZF.
!
!  DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
!  to upper triangular form by means of orthogonal transformations.
!
!  The upper trapezoidal matrix A is factored as
!
!     A = ( R  0 ) * Z,
!
!  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
!  triangular matrix.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= M.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the leading M-by-N upper trapezoidal part of the
!          array A must contain the matrix to be factorized.
!          On exit, the leading M-by-M upper triangular part of A
!          contains the upper triangular matrix R, and elements M+1 to
!          N of the first M rows of A, with the array TAU, represent the
!          orthogonal matrix Z as a product of M elementary reflectors.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (M)
!          The scalar factors of the elementary reflectors.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  The factorization is obtained by Householder's method.  The kth
!  transformation matrix, Z( k ), which is used to introduce zeros into
!  the ( m - k + 1 )th row of A, is given in the form
!
!     Z( k ) = ( I     0   ),
!              ( 0  T( k ) )
!
!  where
!
!     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
!                                                 (   0    )
!                                                 ( z( k ) )
!
!  tau is a scalar and z( k ) is an ( n - m ) element vector.
!  tau and z( k ) are chosen to annihilate the elements of the kth row
!  of X.
!
!  The scalar tau is returned in the kth element of TAU and the vector
!  u( k ) in the kth row of A, such that the elements of z( k ) are
!  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
!  the upper triangular part of A.
!
!  Z is given by
!
!     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, K, M1
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTZRQF', -INFO )
         RETURN
      END IF
!
!     Perform the factorization.
!
      IF( M.EQ.0 ) &
         RETURN
      IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
      ELSE
         M1 = MIN( M+1, N )
         DO 20 K = M, 1, -1
!
!           Use a Householder reflection to zero the kth row of A.
!           First set up the reflection.
!
            CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
!
            IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
!
!              We now perform the operation  A := A*P( k ).
!
!              Use the first ( k - 1 ) elements of TAU to store  a( k ),
!              where  a( k ) consists of the first ( k - 1 ) elements of
!              the  kth column  of  A.  Also  let  B  denote  the  first
!              ( k - 1 ) rows of the last ( n - m ) columns of A.
!
               CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 )
!
!              Form   w = a( k ) + B*z( k )  in TAU.
!
               CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ), &
                           LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
!
!              Now form  a( k ) := a( k ) - tau*w
!              and       B      := B      - tau*w*z( k )'.
!
               CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
               CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA, &
                          A( 1, M1 ), LDA )
            END IF
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of DTZRQF
!
      END
      SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
!     ..
!
!  Purpose
!  =======
!
!  DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
!  to upper triangular form by means of orthogonal transformations.
!
!  The upper trapezoidal matrix A is factored as
!
!     A = ( R  0 ) * Z,
!
!  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
!  triangular matrix.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the leading M-by-N upper trapezoidal part of the
!          array A must contain the matrix to be factorized.
!          On exit, the leading M-by-M upper triangular part of A
!          contains the upper triangular matrix R, and elements M+1 to
!          N of the first M rows of A, with the array TAU, represent the
!          orthogonal matrix Z as a product of M elementary reflectors.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  TAU     (output) DOUBLE PRECISION array, dimension (M)
!          The scalar factors of the elementary reflectors.
!
!  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
!          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!
!  LWORK   (input) INTEGER
!          The dimension of the array WORK.  LWORK >= max(1,M).
!          For optimum performance LWORK >= M*NB, where NB is
!          the optimal blocksize.
!
!          If LWORK = -1, then a workspace query is assumed; the routine
!          only calculates the optimal size of the WORK array, returns
!          this value as the first entry of the WORK array, and no error
!          message related to LWORK is issued by XERBLA.
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  Further Details
!  ===============
!
!  Based on contributions by
!    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
!  The factorization is obtained by Householder's method.  The kth
!  transformation matrix, Z( k ), which is used to introduce zeros into
!  the ( m - k + 1 )th row of A, is given in the form
!
!     Z( k ) = ( I     0   ),
!              ( 0  T( k ) )
!
!  where
!
!     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
!                                                 (   0    )
!                                                 ( z( k ) )
!
!  tau is a scalar and z( k ) is an ( n - m ) element vector.
!  tau and z( k ) are chosen to annihilate the elements of the kth row
!  of X.
!
!  The scalar tau is returned in the kth element of TAU and the vector
!  u( k ) in the kth row of A, such that the elements of z( k ) are
!  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
!  the upper triangular part of A.
!
!  Z is given by
!
!     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB, &
                         NBMIN, NX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLARZB, DLARZT, DLATRZ, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
!
      IF( INFO.EQ.0 ) THEN
!
!        Determine the block size.
!
         NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
         LWKOPT = M*NB
         WORK( 1 ) = LWKOPT
      END IF
!
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTZRZF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      ELSE IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
         WORK( 1 ) = 1
         RETURN
      END IF
!
      NBMIN = 2
      NX = 1
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.M ) THEN
!
!        Determine when to cross over from blocked to unblocked code.
!
         NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.M ) THEN
!
!           Determine if workspace is large enough for blocked code.
!
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
!
!              Not enough workspace to use optimal NB:  reduce NB and
!              determine the minimum value of NB.
!
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1, &
                       -1 ) )
            END IF
         END IF
      END IF
!
      IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
!
!        Use blocked code initially.
!        The last kk rows are handled by the block method.
!
         M1 = MIN( M+1, N )
         KI = ( ( M-NX-1 ) / NB )*NB
         KK = MIN( M, KI+NB )
!
         DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
            IB = MIN( M-I+1, NB )
!
!           Compute the TZ factorization of the current block
!           A(i:i+ib-1,i:n)
!
            CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ), &
                         WORK )
            IF( I.GT.1 ) THEN
!
!              Form the triangular factor of the block reflector
!              H = H(i+ib-1) . . . H(i+1) H(i)
!
               CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ), &
                            LDA, TAU( I ), WORK, LDWORK )
!
!              Apply H to A(1:i-1,i:n) from the right
!
               CALL DLARZB( 'Right', 'No transpose', 'Backward', &
                            'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ), &
                            LDA, WORK, LDWORK, A( 1, I ), LDA, &
                            WORK( IB+1 ), LDWORK )
            END IF
   20    CONTINUE
         MU = I + NB - 1
      ELSE
         MU = M
      END IF
!
!     Use unblocked code to factor the last or only block
!
      IF( MU.GT.0 ) &
         CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
!
      WORK( 1 ) = LWKOPT
!
      RETURN
!
!     End of DTZRZF
!
      END
      DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
!     ..
!     .. Array Arguments ..
      COMPLEX*16         CX( * )
!     ..
!
!  Purpose
!  =======
!
!  DZSUM1 takes the sum of the absolute values of a complex
!  vector and returns a double precision result.
!
!  Based on DZASUM from the Level 1 BLAS.
!  The change is to use the 'genuine' absolute value.
!
!  Contributed by Nick Higham for use with ZLACON.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements in the vector CX.
!
!  CX      (input) COMPLEX*16 array, dimension (N)
!          The vector whose elements will be summed.
!
!  INCX    (input) INTEGER
!          The spacing between successive values of CX.  INCX > 0.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, NINCX
      DOUBLE PRECISION   STEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      DZSUM1 = 0.0D0
      STEMP = 0.0D0
      IF( N.LE.0 ) &
         RETURN
      IF( INCX.EQ.1 ) &
         GO TO 20
!
!     CODE FOR INCREMENT NOT EQUAL TO 1
!
      NINCX = N*INCX
      DO 10 I = 1, NINCX, INCX
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   10 CONTINUE
      DZSUM1 = STEMP
      RETURN
!
!     CODE FOR INCREMENT EQUAL TO 1
!
   20 CONTINUE
      DO 30 I = 1, N
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   30 CONTINUE
      DZSUM1 = STEMP
      RETURN
!
!     End of DZSUM1
!
      END
      LOGICAL          FUNCTION LSAME( CA, CB )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          CA, CB
!     ..
!
!  Purpose
!  =======
!
!  LSAME returns .TRUE. if CA is the same letter as CB regardless of
!  case.
!
!  Arguments
!  =========
!
!  CA      (input) CHARACTER*1
!  CB      (input) CHARACTER*1
!          CA and CB specify the single characters to be compared.
!
! =====================================================================
!
!     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
!     ..
!     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
!     ..
!     .. Executable Statements ..
!
!     Test if the characters are equal
!
      LSAME = CA.EQ.CB
      IF( LSAME ) &
         RETURN
!
!     Now test for equivalence if both characters are alphabetic.
!
      ZCODE = ICHAR( 'Z' )
!
!     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
!     machines, on which ICHAR returns a value with bit 8 set.
!     ICHAR('A') on Prime machines returns 193 which is the same as
!     ICHAR('A') on an EBCDIC machine.
!
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
!
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
!
!        ASCII is assumed - ZCODE is the ASCII code of either lower or
!        upper case 'Z'.
!
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
!
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
!
!        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
!        upper case 'Z'.
!
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR. &
             INTA.GE.145 .AND. INTA.LE.153 .OR. &
             INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR. &
             INTB.GE.145 .AND. INTB.LE.153 .OR. &
             INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
!
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
!
!        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
!        plus 128 of either lower or upper case 'Z'.
!
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
!
!     RETURN
!
!     End of LSAME
!
      END
      double precision function dasum(n,dx,incx)
!
!     takes the sum of the absolute values.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dtemp
      integer i,incx,m,mp1,n,nincx
!
      dasum = 0.0d0
      dtemp = 0.0d0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dtemp = dtemp + dabs(dx(i))
   10 continue
      dasum = dtemp
      return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,6)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dabs(dx(i))
   30 continue
      if( n .lt. 6 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,6
        dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) &
        + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
   50 continue
   60 dasum = dtemp
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
!
!     constant times a vector plus a vector.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),da
      integer i,incx,incy,ix,iy,m,mp1,n
!
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      double precision function dcabs1(z)
      double complex z,zz
      double precision t(2)
      equivalence (zz,t(1))
      zz = z
      dcabs1 = dabs(t(1)) + dabs(t(2))
      return
      end
      subroutine  dcopy(n,dx,incx,dy,incy)
!
!     copies a vector, x, to a vector, y.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
!
!     forms the dot product of two vectors.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
!
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
!
!        code for both increments equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + &
         dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
      SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, &
                         BETA, Y, INCY )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, KL, KU, LDA, M, N
      CHARACTER*1        TRANS
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGBMV  performs one of the matrix-vector operations
!
!     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
!
!  where alpha and beta are scalars, x and y are vectors and A is an
!  m by n band matrix, with kl sub-diagonals and ku super-diagonals.
!
!  Parameters
!  ==========
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!
!              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
!
!              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  KL     - INTEGER.
!           On entry, KL specifies the number of sub-diagonals of the
!           matrix A. KL must satisfy  0 .le. KL.
!           Unchanged on exit.
!
!  KU     - INTEGER.
!           On entry, KU specifies the number of super-diagonals of the
!           matrix A. KU must satisfy  0 .le. KU.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading ( kl + ku + 1 ) by n part of the
!           array A must contain the matrix of coefficients, supplied
!           column by column, with the leading diagonal of the matrix in
!           row ( ku + 1 ) of the array, the first super-diagonal
!           starting at position 2 in row ku, the first sub-diagonal
!           starting at position 1 in row ( ku + 2 ), and so on.
!           Elements in the array A that do not correspond to elements
!           in the band matrix (such as the top left ku by ku triangle)
!           are not referenced.
!           The following program segment will transfer a band matrix
!           from conventional full matrix storage to band storage:
!
!                 DO 20, J = 1, N
!                    K = KU + 1 - J
!                    DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
!                       A( K + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           ( kl + ku + 1 ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!           Before entry, the incremented array Y must contain the
!           vector y. On exit, Y is overwritten by the updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, &
                         LENX, LENY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( KL.LT.0 )THEN
         INFO = 4
      ELSE IF( KU.LT.0 )THEN
         INFO = 5
      ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN
         INFO = 8
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 10
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGBMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. &
          ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through the band part of A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO ) &
         RETURN
      KUP1 = KU + 1
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  y := alpha*A*x + y.
!
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  K    = KUP1 - J
                  DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL )
                     Y( I ) = Y( I ) + TEMP*A( K + I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  K    = KUP1 - J
                  DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL )
                     Y( IY ) = Y( IY ) + TEMP*A( K + I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
               IF( J.GT.KU ) &
                  KY = KY + INCY
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y := alpha*A'*x + y.
!
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               K    = KUP1 - J
               DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL )
                  TEMP = TEMP + A( K + I, J )*X( I )
   90          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  100       CONTINUE
         ELSE
            DO 120, J = 1, N
               TEMP = ZERO
               IX   = KX
               K    = KUP1 - J
               DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL )
                  TEMP = TEMP + A( K + I, J )*X( IX )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
               IF( J.GT.KU ) &
                  KX = KX + INCX
  120       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGBMV .
!
      END
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, &
                         BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X',
!
!  alpha and beta are scalars, and A, B and C are matrices, with op( A )
!  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = A'.
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = B'.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the  matrix
!           op( A )  and of the  matrix  C.  M  must  be at least  zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the matrix
!           op( B ) and the number of columns of the matrix C. N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the matrix
!           op( A ) and the number of rows of the matrix op( B ). K must
!           be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by m  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
!           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  n by k  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!           LDB must be at least  max( 1, k ), otherwise  LDB must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n  matrix
!           ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
!     and  columns of  A  and the  number of  rows  of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND. &
               ( .NOT.LSAME( TRANSA, 'C' ) ).AND. &
               ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND. &
               ( .NOT.LSAME( TRANSB, 'C' ) ).AND. &
               ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. &
          ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     And if  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B' + beta*C
!
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGEMM .
!
      END
      SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, &
                         BETA, Y, INCY )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGEMV  performs one of the matrix-vector operations
!
!     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
!
!  where alpha and beta are scalars, x and y are vectors and A is an
!  m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!
!              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
!
!              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!           Before entry with BETA non-zero, the incremented array Y
!           must contain the vector y. On exit, Y is overwritten by the
!           updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. &
          ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO ) &
         RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  y := alpha*A*x + y.
!
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y := alpha*A'*x + y.
!
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               DO 90, I = 1, M
                  TEMP = TEMP + A( I, J )*X( I )
   90          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  100       CONTINUE
         ELSE
            DO 120, J = 1, N
               TEMP = ZERO
               IX   = KX
               DO 110, I = 1, M
                  TEMP = TEMP + A( I, J )*X( IX )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGEMV .
!
      END
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGER   performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n element
!  vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) &
         RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DGER  .
!
      END
      DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
!     .. Scalar Arguments ..
      INTEGER                           INCX, N
!     .. Array Arguments ..
      DOUBLE PRECISION                  X( * )
!     ..
!
!  DNRM2 returns the euclidean norm of a vector via the function
!  name, so that
!
!     DNRM2 := sqrt( x'*x )
!
!
!
!  -- This version written on 25-October-1982.
!     Modified on 14-October-1993 to inline the call to DLASSQ.
!     Sven Hammarling, Nag Ltd.
!
!
!     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      INTEGER               IX
      DOUBLE PRECISION      ABSXI, NORM, SCALE, SSQ
!     .. Intrinsic Functions ..
      INTRINSIC             ABS, SQRT
!     ..
!     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
!        The following loop is equivalent to this call to the LAPACK
!        auxiliary routine:
!        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
!
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ   +     ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
!
      DNRM2 = NORM
      RETURN
!
!     End of DNRM2.
!
      END
      subroutine  drot (n,dx,incx,dy,incy,c,s)
!
!     applies a plane rotation.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),dtemp,c,s
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = c*dx(ix) + s*dy(iy)
        dy(iy) = c*dy(iy) - s*dx(ix)
        dx(ix) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
!
   20 do 30 i = 1,n
        dtemp = c*dx(i) + s*dy(i)
        dy(i) = c*dy(i) - s*dx(i)
        dx(i) = dtemp
   30 continue
      return
      end
      subroutine drotg(da,db,c,s)
!
!     construct givens plane rotation.
!     jack dongarra, linpack, 3/11/78.
!
      double precision da,db,c,s,roe,scale,r,z
!
      roe = db
      if( dabs(da) .gt. dabs(db) ) roe = da
      scale = dabs(da) + dabs(db)
      if( scale .ne. 0.0d0 ) go to 10
         c = 1.0d0
         s = 0.0d0
         r = 0.0d0
         z = 0.0d0
         go to 20
   10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
      r = dsign(1.0d0,roe)*r
      c = da/r
      s = db/r
      z = 1.0d0
      if( dabs(da) .gt. dabs(db) ) z = s
      if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c
   20 da = r
      db = z
      return
      end
      SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, &
                         BETA, Y, INCY )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, K, LDA, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DSBMV  performs the matrix-vector  operation
!
!     y := alpha*A*x + beta*y,
!
!  where alpha and beta are scalars, x and y are n element vectors and
!  A is an n by n symmetric band matrix, with k super-diagonals.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the band matrix A is being supplied as
!           follows:
!
!              UPLO = 'U' or 'u'   The upper triangular part of A is
!                                  being supplied.
!
!              UPLO = 'L' or 'l'   The lower triangular part of A is
!                                  being supplied.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry, K specifies the number of super-diagonals of the
!           matrix A. K must satisfy  0 .le. K.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
!           by n part of the array A must contain the upper triangular
!           band part of the symmetric matrix, supplied column by
!           column, with the leading diagonal of the matrix in row
!           ( k + 1 ) of the array, the first super-diagonal starting at
!           position 2 in row k, and so on. The top left k by k triangle
!           of the array A is not referenced.
!           The following program segment will transfer the upper
!           triangular part of a symmetric band matrix from conventional
!           full matrix storage to band storage:
!
!                 DO 20, J = 1, N
!                    M = K + 1 - J
!                    DO 10, I = MAX( 1, J - K ), J
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
!           by n part of the array A must contain the lower triangular
!           band part of the symmetric matrix, supplied column by
!           column, with the leading diagonal of the matrix in row 1 of
!           the array, the first sub-diagonal starting at position 1 in
!           row 2, and so on. The bottom right k by k triangle of the
!           array A is not referenced.
!           The following program segment will transfer the lower
!           triangular part of a symmetric band matrix from conventional
!           full matrix storage to band storage:
!
!                 DO 20, J = 1, N
!                    M = 1 - J
!                    DO 10, I = J, MIN( N, J + K )
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           ( k + 1 ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the
!           vector y. On exit, Y is overwritten by the updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( K.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.( K + 1 ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSBMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     Set up the start points in  X  and  Y.
!
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of the array A
!     are accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO ) &
         RETURN
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  y  when upper triangle of A is stored.
!
         KPLUS1 = K + 1
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               L     = KPLUS1 - J
               DO 50, I = MAX( 1, J - K ), J - 1
                  Y( I ) = Y( I ) + TEMP1*A( L + I, J )
                  TEMP2  = TEMP2  + A( L + I, J )*X( I )
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2
   60       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 80, J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
               L     = KPLUS1 - J
               DO 70, I = MAX( 1, J - K ), J - 1
                  Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
                  TEMP2   = TEMP2   + A( L + I, J )*X( IX )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
               IF( J.GT.K )THEN
                  KX = KX + INCX
                  KY = KY + INCY
               END IF
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y  when lower triangle of A is stored.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP1  = ALPHA*X( J )
               TEMP2  = ZERO
               Y( J ) = Y( J )       + TEMP1*A( 1, J )
               L      = 1            - J
               DO 90, I = J + 1, MIN( N, J + K )
                  Y( I ) = Y( I ) + TEMP1*A( L + I, J )
                  TEMP2  = TEMP2  + A( L + I, J )*X( I )
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120, J = 1, N
               TEMP1   = ALPHA*X( JX )
               TEMP2   = ZERO
               Y( JY ) = Y( JY )       + TEMP1*A( 1, J )
               L       = 1             - J
               IX      = JX
               IY      = JY
               DO 110, I = J + 1, MIN( N, J + K )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  Y( IY ) = Y( IY ) + TEMP1*A( L + I, J )
                  TEMP2   = TEMP2   + A( L + I, J )*X( IX )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSBMV .
!
      END
      subroutine  dscal(n,da,dx,incx)
!
!     scales a vector by a constant.
!     uses unrolled loops for increment equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPMV  performs the matrix-vector operation
!
!     y := alpha*A*x + beta*y,
!
!  where alpha and beta are scalars, x and y are n element vectors and
!  A is an n by n symmetric matrix, supplied in packed form.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the matrix A is supplied in the packed
!           array AP as follows:
!
!              UPLO = 'U' or 'u'   The upper triangular part of A is
!                                  supplied in AP.
!
!              UPLO = 'L' or 'l'   The lower triangular part of A is
!                                  supplied in AP.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!           and a( 2, 2 ) respectively, and so on.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!           and a( 3, 1 ) respectively, and so on.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y. On exit, Y is overwritten by the updated
!           vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 6
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     Set up the start points in  X  and  Y.
!
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of the array AP
!     are accessed sequentially with one pass through AP.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO ) &
         RETURN
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  y  when AP contains the upper triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               K     = KK
               DO 50, I = 1, J - 1
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*X( I )
                  K      = K      + 1
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
               KK     = KK     + J
   60       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 80, J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
               DO 70, K = KK, KK + J - 2
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*X( IX )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
               KK      = KK      + J
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y  when AP contains the lower triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP1  = ALPHA*X( J )
               TEMP2  = ZERO
               Y( J ) = Y( J )       + TEMP1*AP( KK )
               K      = KK           + 1
               DO 90, I = J + 1, N
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*X( I )
                  K      = K      + 1
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
               KK     = KK     + ( N - J + 1 )
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120, J = 1, N
               TEMP1   = ALPHA*X( JX )
               TEMP2   = ZERO
               Y( JY ) = Y( JY )       + TEMP1*AP( KK )
               IX      = JX
               IY      = JY
               DO 110, K = KK + 1, KK + N - J
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*X( IX )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
               KK      = KK      + ( N - J + 1 )
  120       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSPMV .
!
      END
      SUBROUTINE DSPR  ( UPLO, N, ALPHA, X, INCX, AP )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPR    performs the symmetric rank 1 operation
!
!     A := alpha*x*x' + A,
!
!  where alpha is a real scalar, x is an n element vector and A is an
!  n by n symmetric matrix, supplied in packed form.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the matrix A is supplied in the packed
!           array AP as follows:
!
!              UPLO = 'U' or 'u'   The upper triangular part of A is
!                                  supplied in AP.
!
!              UPLO = 'L' or 'l'   The lower triangular part of A is
!                                  supplied in AP.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with  UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!           and a( 2, 2 ) respectively, and so on. On exit, the array
!           AP is overwritten by the upper triangular part of the
!           updated matrix.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!           and a( 3, 1 ) respectively, and so on. On exit, the array
!           AP is overwritten by the lower triangular part of the
!           updated matrix.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPR  ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) &
         RETURN
!
!     Set the start point in X if the increment is not unity.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of the array AP
!     are accessed sequentially with one pass through AP.
!
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  A  when upper triangle is stored in AP.
!
         IF( INCX.EQ.1 )THEN
            DO 20, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  K    = KK
                  DO 10, I = 1, J
                     AP( K ) = AP( K ) + X( I )*TEMP
                     K       = K       + 1
   10             CONTINUE
               END IF
               KK = KK + J
   20       CONTINUE
         ELSE
            JX = KX
            DO 40, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = KX
                  DO 30, K = KK, KK + J - 1
                     AP( K ) = AP( K ) + X( IX )*TEMP
                     IX      = IX      + INCX
   30             CONTINUE
               END IF
               JX = JX + INCX
               KK = KK + J
   40       CONTINUE
         END IF
      ELSE
!
!        Form  A  when lower triangle is stored in AP.
!
         IF( INCX.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  K    = KK
                  DO 50, I = J, N
                     AP( K ) = AP( K ) + X( I )*TEMP
                     K       = K       + 1
   50             CONTINUE
               END IF
               KK = KK + N - J + 1
   60       CONTINUE
         ELSE
            JX = KX
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = JX
                  DO 70, K = KK, KK + N - J
                     AP( K ) = AP( K ) + X( IX )*TEMP
                     IX      = IX      + INCX
   70             CONTINUE
               END IF
               JX = JX + INCX
               KK = KK + N - J + 1
   80       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSPR  .
!
      END
      SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DSPR2  performs the symmetric rank 2 operation
!
!     A := alpha*x*y' + alpha*y*x' + A,
!
!  where alpha is a scalar, x and y are n element vectors and A is an
!  n by n symmetric matrix, supplied in packed form.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the matrix A is supplied in the packed
!           array AP as follows:
!
!              UPLO = 'U' or 'u'   The upper triangular part of A is
!                                  supplied in AP.
!
!              UPLO = 'L' or 'l'   The lower triangular part of A is
!                                  supplied in AP.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with  UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!           and a( 2, 2 ) respectively, and so on. On exit, the array
!           AP is overwritten by the upper triangular part of the
!           updated matrix.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular part of the symmetric matrix
!           packed sequentially, column by column, so that AP( 1 )
!           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!           and a( 3, 1 ) respectively, and so on. On exit, the array
!           AP is overwritten by the lower triangular part of the
!           updated matrix.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPR2 ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) &
         RETURN
!
!     Set up the start points in X and Y if the increments are not both
!     unity.
!
      IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( N - 1 )*INCX
         END IF
         IF( INCY.GT.0 )THEN
            KY = 1
         ELSE
            KY = 1 - ( N - 1 )*INCY
         END IF
         JX = KX
         JY = KY
      END IF
!
!     Start the operations. In this version the elements of the array AP
!     are accessed sequentially with one pass through AP.
!
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  A  when upper triangle is stored in AP.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 20, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  K     = KK
                  DO 10, I = 1, J
                     AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
                     K       = K       + 1
   10             CONTINUE
               END IF
               KK = KK + J
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = KX
                  IY    = KY
                  DO 30, K = KK, KK + J - 1
                     AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
                     IX      = IX      + INCX
                     IY      = IY      + INCY
   30             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + J
   40       CONTINUE
         END IF
      ELSE
!
!        Form  A  when lower triangle is stored in AP.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  K     = KK
                  DO 50, I = J, N
                     AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
                     K       = K       + 1
   50             CONTINUE
               END IF
               KK = KK + N - J + 1
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = JX
                  IY    = JY
                  DO 70, K = KK, KK + N - J
                     AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
                     IX      = IX      + INCX
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + N - J + 1
   80       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSPR2 .
!
      END
      subroutine  dswap (n,dx,incx,dy,incy)
!
!     interchanges two vectors.
!     uses unrolled loops for increments equal one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
!
!
!       clean-up loop
!
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, &
                         BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO
      INTEGER            M, N, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYMM  performs one of the matrix-matrix operations
!
!     C := alpha*A*B + beta*C,
!
!  or
!
!     C := alpha*B*A + beta*C,
!
!  where alpha and beta are scalars,  A is a symmetric matrix and  B and
!  C are  m by n matrices.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry,  SIDE  specifies whether  the  symmetric matrix  A
!           appears on the  left or right  in the  operation as follows:
!
!              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C,
!
!              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C,
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!           triangular  part  of  the  symmetric  matrix   A  is  to  be
!           referenced as follows:
!
!              UPLO = 'U' or 'u'   Only the upper triangular part of the
!                                  symmetric matrix is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the lower triangular part of the
!                                  symmetric matrix is to be referenced.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies the number of rows of the matrix  C.
!           M  must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix C.
!           N  must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           m  when  SIDE = 'L' or 'l'  and is  n otherwise.
!           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of
!           the array  A  must contain the  symmetric matrix,  such that
!           when  UPLO = 'U' or 'u', the leading m by m upper triangular
!           part of the array  A  must contain the upper triangular part
!           of the  symmetric matrix and the  strictly  lower triangular
!           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
!           the leading  m by m  lower triangular part  of the  array  A
!           must  contain  the  lower triangular part  of the  symmetric
!           matrix and the  strictly upper triangular part of  A  is not
!           referenced.
!           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of
!           the array  A  must contain the  symmetric matrix,  such that
!           when  UPLO = 'U' or 'u', the leading n by n upper triangular
!           part of the array  A  must contain the upper triangular part
!           of the  symmetric matrix and the  strictly  lower triangular
!           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
!           the leading  n by n  lower triangular part  of the  array  A
!           must  contain  the  lower triangular part  of the  symmetric
!           matrix and the  strictly upper triangular part of  A  is not
!           referenced.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
!           Before entry, the leading  m by n part of the array  B  must
!           contain the matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n updated
!           matrix.
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP1, TEMP2
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Set NROWA as the number of rows of A.
!
      IF( LSAME( SIDE, 'L' ) )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      UPPER = LSAME( UPLO, 'U' )
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.LSAME( SIDE, 'L' ) ).AND. &
               ( .NOT.LSAME( SIDE, 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER              ).AND. &
               ( .NOT.LSAME( UPLO, 'L' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 7
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 9
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. &
          ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSAME( SIDE, 'L' ) )THEN
!
!        Form  C := alpha*A*B + beta*C.
!
         IF( UPPER )THEN
            DO 70, J = 1, N
               DO 60, I = 1, M
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 50, K = 1, I - 1
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   50             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) + &
                                 TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 100, J = 1, N
               DO 90, I = M, 1, -1
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 80, K = I + 1, M
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   80             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) + &
                                 TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   90          CONTINUE
  100       CONTINUE
         END IF
      ELSE
!
!        Form  C := alpha*B*A + beta*C.
!
         DO 170, J = 1, N
            TEMP1 = ALPHA*A( J, J )
            IF( BETA.EQ.ZERO )THEN
               DO 110, I = 1, M
                  C( I, J ) = TEMP1*B( I, J )
  110          CONTINUE
            ELSE
               DO 120, I = 1, M
                  C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J )
  120          CONTINUE
            END IF
            DO 140, K = 1, J - 1
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( K, J )
               ELSE
                  TEMP1 = ALPHA*A( J, K )
               END IF
               DO 130, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  130          CONTINUE
  140       CONTINUE
            DO 160, K = J + 1, N
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( J, K )
               ELSE
                  TEMP1 = ALPHA*A( K, J )
               END IF
               DO 150, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  150          CONTINUE
  160       CONTINUE
  170    CONTINUE
      END IF
!
      RETURN
!
!     End of DSYMM .
!
      END
      SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, &
                         BETA, Y, INCY )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYMV  performs the matrix-vector  operation
!
!     y := alpha*A*x + beta*y,
!
!  where alpha and beta are scalars, x and y are n element vectors and
!  A is an n by n symmetric matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the array A is to be referenced as
!           follows:
!
!              UPLO = 'U' or 'u'   Only the upper triangular part of A
!                                  is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the lower triangular part of A
!                                  is to be referenced.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with  UPLO = 'U' or 'u', the leading n by n
!           upper triangular part of the array A must contain the upper
!           triangular part of the symmetric matrix and the strictly
!           lower triangular part of A is not referenced.
!           Before entry with UPLO = 'L' or 'l', the leading n by n
!           lower triangular part of the array A must contain the lower
!           triangular part of the symmetric matrix and the strictly
!           upper triangular part of A is not referenced.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, n ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y. On exit, Y is overwritten by the updated
!           vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 5
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 10
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     Set up the start points in  X  and  Y.
!
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through the triangular part
!     of A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO ) &
         RETURN
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  y  when A is stored in upper triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               DO 50, I = 1, J - 1
                  Y( I ) = Y( I ) + TEMP1*A( I, J )
                  TEMP2  = TEMP2  + A( I, J )*X( I )
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2
   60       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 80, J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
               DO 70, I = 1, J - 1
                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
                  TEMP2   = TEMP2   + A( I, J )*X( IX )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y  when A is stored in lower triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP1  = ALPHA*X( J )
               TEMP2  = ZERO
               Y( J ) = Y( J )       + TEMP1*A( J, J )
               DO 90, I = J + 1, N
                  Y( I ) = Y( I ) + TEMP1*A( I, J )
                  TEMP2  = TEMP2  + A( I, J )*X( I )
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120, J = 1, N
               TEMP1   = ALPHA*X( JX )
               TEMP2   = ZERO
               Y( JY ) = Y( JY )       + TEMP1*A( J, J )
               IX      = JX
               IY      = JY
               DO 110, I = J + 1, N
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  Y( IY ) = Y( IY ) + TEMP1*A( I, J )
                  TEMP2   = TEMP2   + A( I, J )*X( IX )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSYMV .
!
      END
      SUBROUTINE DSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, LDA, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYR   performs the symmetric rank 1 operation
!
!     A := alpha*x*x' + A,
!
!  where alpha is a real scalar, x is an n element vector and A is an
!  n by n symmetric matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the array A is to be referenced as
!           follows:
!
!              UPLO = 'U' or 'u'   Only the upper triangular part of A
!                                  is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the lower triangular part of A
!                                  is to be referenced.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with  UPLO = 'U' or 'u', the leading n by n
!           upper triangular part of the array A must contain the upper
!           triangular part of the symmetric matrix and the strictly
!           lower triangular part of A is not referenced. On exit, the
!           upper triangular part of the array A is overwritten by the
!           upper triangular part of the updated matrix.
!           Before entry with UPLO = 'L' or 'l', the leading n by n
!           lower triangular part of the array A must contain the lower
!           triangular part of the symmetric matrix and the strictly
!           upper triangular part of A is not referenced. On exit, the
!           lower triangular part of the array A is overwritten by the
!           lower triangular part of the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, n ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYR  ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) &
         RETURN
!
!     Set the start point in X if the increment is not unity.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through the triangular part
!     of A.
!
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  A  when A is stored in upper triangle.
!
         IF( INCX.EQ.1 )THEN
            DO 20, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  DO 10, I = 1, J
                     A( I, J ) = A( I, J ) + X( I )*TEMP
   10             CONTINUE
               END IF
   20       CONTINUE
         ELSE
            JX = KX
            DO 40, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = KX
                  DO 30, I = 1, J
                     A( I, J ) = A( I, J ) + X( IX )*TEMP
                     IX        = IX        + INCX
   30             CONTINUE
               END IF
               JX = JX + INCX
   40       CONTINUE
         END IF
      ELSE
!
!        Form  A  when A is stored in lower triangle.
!
         IF( INCX.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  DO 50, I = J, N
                     A( I, J ) = A( I, J ) + X( I )*TEMP
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE
            JX = KX
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = JX
                  DO 70, I = J, N
                     A( I, J ) = A( I, J ) + X( IX )*TEMP
                     IX        = IX        + INCX
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSYR  .
!
      END
      SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, N
      CHARACTER*1        UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DSYR2  performs the symmetric rank 2 operation
!
!     A := alpha*x*y' + alpha*y*x' + A,
!
!  where alpha is a scalar, x and y are n element vectors and A is an n
!  by n symmetric matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the upper or lower
!           triangular part of the array A is to be referenced as
!           follows:
!
!              UPLO = 'U' or 'u'   Only the upper triangular part of A
!                                  is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the lower triangular part of A
!                                  is to be referenced.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with  UPLO = 'U' or 'u', the leading n by n
!           upper triangular part of the array A must contain the upper
!           triangular part of the symmetric matrix and the strictly
!           lower triangular part of A is not referenced. On exit, the
!           upper triangular part of the array A is overwritten by the
!           upper triangular part of the updated matrix.
!           Before entry with UPLO = 'L' or 'l', the leading n by n
!           lower triangular part of the array A must contain the lower
!           triangular part of the symmetric matrix and the strictly
!           upper triangular part of A is not referenced. On exit, the
!           lower triangular part of the array A is overwritten by the
!           lower triangular part of the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, n ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND. &
               .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYR2 ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) &
         RETURN
!
!     Set up the start points in X and Y if the increments are not both
!     unity.
!
      IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( N - 1 )*INCX
         END IF
         IF( INCY.GT.0 )THEN
            KY = 1
         ELSE
            KY = 1 - ( N - 1 )*INCY
         END IF
         JX = KX
         JY = KY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through the triangular part
!     of A.
!
      IF( LSAME( UPLO, 'U' ) )THEN
!
!        Form  A  when A is stored in the upper triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 20, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  DO 10, I = 1, J
                     A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2
   10             CONTINUE
               END IF
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = KX
                  IY    = KY
                  DO 30, I = 1, J
                     A( I, J ) = A( I, J ) + X( IX )*TEMP1 &
                                           + Y( IY )*TEMP2
                     IX        = IX        + INCX
                     IY        = IY        + INCY
   30             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
   40       CONTINUE
         END IF
      ELSE
!
!        Form  A  when A is stored in the lower triangle.
!
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  DO 50, I = J, N
                     A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = JX
                  IY    = JY
                  DO 70, I = J, N
                     A( I, J ) = A( I, J ) + X( IX )*TEMP1 &
                                           + Y( IY )*TEMP2
                     IX        = IX        + INCX
                     IY        = IY        + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
   80       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSYR2 .
!
      END
      SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, &
                         BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        UPLO, TRANS
      INTEGER            N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYR2K  performs one of the symmetric rank 2k operations
!
!     C := alpha*A*B' + alpha*B*A' + beta*C,
!
!  or
!
!     C := alpha*A'*B + alpha*B'*A + beta*C,
!
!  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
!  and  A and B  are  n by k  matrices  in the  first  case  and  k by n
!  matrices in the second case.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!           triangular  part  of the  array  C  is to be  referenced  as
!           follows:
!
!              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
!                                  is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
!                                  is to be referenced.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry,  TRANS  specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   C := alpha*A*B' + alpha*B*A' +
!                                        beta*C.
!
!              TRANS = 'T' or 't'   C := alpha*A'*B + alpha*B'*A +
!                                        beta*C.
!
!              TRANS = 'C' or 'c'   C := alpha*A'*B + alpha*B'*A +
!                                        beta*C.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N specifies the order of the matrix C.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
!           of  columns  of the  matrices  A and B,  and on  entry  with
!           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number
!           of rows of the matrices  A and B.  K must be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
!           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by n  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!           then  LDA must be at least  max( 1, n ), otherwise  LDA must
!           be at least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
!           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
!           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  k by n  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!           then  LDB must be at least  max( 1, n ), otherwise  LDB must
!           be at least  max( 1, k ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
!           upper triangular part of the array C must contain the upper
!           triangular part  of the  symmetric matrix  and the strictly
!           lower triangular part of C is not referenced.  On exit, the
!           upper triangular part of the array  C is overwritten by the
!           upper triangular part of the updated matrix.
!           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
!           lower triangular part of the array C must contain the lower
!           triangular part  of the  symmetric matrix  and the strictly
!           upper triangular part of C is not referenced.  On exit, the
!           lower triangular part of the array  C is overwritten by the
!           lower triangular part of the updated matrix.
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, n ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, L, NROWA
      DOUBLE PRECISION   TEMP1, TEMP2
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         NROWA = N
      ELSE
         NROWA = K
      END IF
      UPPER = LSAME( UPLO, 'U' )
!
      INFO = 0
      IF(      ( .NOT.UPPER               ).AND. &
               ( .NOT.LSAME( UPLO , 'L' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. &
               ( .NOT.LSAME( TRANS, 'T' ) ).AND. &
               ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
         INFO = 2
      ELSE IF( N  .LT.0               )THEN
         INFO = 3
      ELSE IF( K  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 7
      ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDC.LT.MAX( 1, N     ) )THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYR2K', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR. &
          ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( UPPER )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 20, J = 1, N
                  DO 10, I = 1, J
                     C( I, J ) = ZERO
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40, J = 1, N
                  DO 30, I = 1, J
                     C( I, J ) = BETA*C( I, J )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            IF( BETA.EQ.ZERO )THEN
               DO 60, J = 1, N
                  DO 50, I = J, N
                     C( I, J ) = ZERO
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70, I = J, N
                     C( I, J ) = BETA*C( I, J )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  C := alpha*A*B' + alpha*B*A' + C.
!
         IF( UPPER )THEN
            DO 130, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 90, I = 1, J
                     C( I, J ) = ZERO
   90             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 100, I = 1, J
                     C( I, J ) = BETA*C( I, J )
  100             CONTINUE
               END IF
               DO 120, L = 1, K
                  IF( ( A( J, L ).NE.ZERO ).OR. &
                      ( B( J, L ).NE.ZERO )     )THEN
                     TEMP1 = ALPHA*B( J, L )
                     TEMP2 = ALPHA*A( J, L )
                     DO 110, I = 1, J
                        C( I, J ) = C( I, J ) + &
                                    A( I, L )*TEMP1 + B( I, L )*TEMP2
  110                CONTINUE
                  END IF
  120          CONTINUE
  130       CONTINUE
         ELSE
            DO 180, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 140, I = J, N
                     C( I, J ) = ZERO
  140             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 150, I = J, N
                     C( I, J ) = BETA*C( I, J )
  150             CONTINUE
               END IF
               DO 170, L = 1, K
                  IF( ( A( J, L ).NE.ZERO ).OR. &
                      ( B( J, L ).NE.ZERO )     )THEN
                     TEMP1 = ALPHA*B( J, L )
                     TEMP2 = ALPHA*A( J, L )
                     DO 160, I = J, N
                        C( I, J ) = C( I, J ) + &
                                    A( I, L )*TEMP1 + B( I, L )*TEMP2
  160                CONTINUE
                  END IF
  170          CONTINUE
  180       CONTINUE
         END IF
      ELSE
!
!        Form  C := alpha*A'*B + alpha*B'*A + C.
!
         IF( UPPER )THEN
            DO 210, J = 1, N
               DO 200, I = 1, J
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 190, L = 1, K
                     TEMP1 = TEMP1 + A( L, I )*B( L, J )
                     TEMP2 = TEMP2 + B( L, I )*A( L, J )
  190             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) + &
                                 ALPHA*TEMP1 + ALPHA*TEMP2
                  END IF
  200          CONTINUE
  210       CONTINUE
         ELSE
            DO 240, J = 1, N
               DO 230, I = J, N
                  TEMP1 = ZERO
                  TEMP2 = ZERO
                  DO 220, L = 1, K
                     TEMP1 = TEMP1 + A( L, I )*B( L, J )
                     TEMP2 = TEMP2 + B( L, I )*A( L, J )
  220             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) + &
                                 ALPHA*TEMP1 + ALPHA*TEMP2
                  END IF
  230          CONTINUE
  240       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSYR2K.
!
      END
      SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, &
                         BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        UPLO, TRANS
      INTEGER            N, K, LDA, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DSYRK  performs one of the symmetric rank k operations
!
!     C := alpha*A*A' + beta*C,
!
!  or
!
!     C := alpha*A'*A + beta*C,
!
!  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
!  and  A  is an  n by k  matrix in the first case and a  k by n  matrix
!  in the second case.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On  entry,   UPLO  specifies  whether  the  upper  or  lower
!           triangular  part  of the  array  C  is to be  referenced  as
!           follows:
!
!              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
!                                  is to be referenced.
!
!              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
!                                  is to be referenced.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry,  TRANS  specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C.
!
!              TRANS = 'T' or 't'   C := alpha*A'*A + beta*C.
!
!              TRANS = 'C' or 'c'   C := alpha*A'*A + beta*C.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N specifies the order of the matrix C.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
!           of  columns   of  the   matrix   A,   and  on   entry   with
!           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number
!           of rows of the matrix  A.  K must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
!           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by n  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
!           then  LDA must be at least  max( 1, n ), otherwise  LDA must
!           be at least  max( 1, k ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
!           upper triangular part of the array C must contain the upper
!           triangular part  of the  symmetric matrix  and the strictly
!           lower triangular part of C is not referenced.  On exit, the
!           upper triangular part of the array  C is overwritten by the
!           upper triangular part of the updated matrix.
!           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
!           lower triangular part of the array C must contain the lower
!           triangular part  of the  symmetric matrix  and the strictly
!           upper triangular part of C is not referenced.  On exit, the
!           lower triangular part of the array  C is overwritten by the
!           lower triangular part of the updated matrix.
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, n ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, L, NROWA
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE ,         ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         NROWA = N
      ELSE
         NROWA = K
      END IF
      UPPER = LSAME( UPLO, 'U' )
!
      INFO = 0
      IF(      ( .NOT.UPPER               ).AND. &
               ( .NOT.LSAME( UPLO , 'L' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. &
               ( .NOT.LSAME( TRANS, 'T' ) ).AND. &
               ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
         INFO = 2
      ELSE IF( N  .LT.0               )THEN
         INFO = 3
      ELSE IF( K  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 7
      ELSE IF( LDC.LT.MAX( 1, N     ) )THEN
         INFO = 10
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSYRK ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( N.EQ.0 ).OR. &
          ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
         RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( UPPER )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 20, J = 1, N
                  DO 10, I = 1, J
                     C( I, J ) = ZERO
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40, J = 1, N
                  DO 30, I = 1, J
                     C( I, J ) = BETA*C( I, J )
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            IF( BETA.EQ.ZERO )THEN
               DO 60, J = 1, N
                  DO 50, I = J, N
                     C( I, J ) = ZERO
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70, I = J, N
                     C( I, J ) = BETA*C( I, J )
   70             CONTINUE
   80          CONTINUE
            END IF
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  C := alpha*A*A' + beta*C.
!
         IF( UPPER )THEN
            DO 130, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 90, I = 1, J
                     C( I, J ) = ZERO
   90             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 100, I = 1, J
                     C( I, J ) = BETA*C( I, J )
  100             CONTINUE
               END IF
               DO 120, L = 1, K
                  IF( A( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*A( J, L )
                     DO 110, I = 1, J
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  110                CONTINUE
                  END IF
  120          CONTINUE
  130       CONTINUE
         ELSE
            DO 180, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 140, I = J, N
                     C( I, J ) = ZERO
  140             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 150, I = J, N
                     C( I, J ) = BETA*C( I, J )
  150             CONTINUE
               END IF
               DO 170, L = 1, K
                  IF( A( J, L ).NE.ZERO )THEN
                     TEMP      = ALPHA*A( J, L )
                     DO 160, I = J, N
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  160                CONTINUE
                  END IF
  170          CONTINUE
  180       CONTINUE
         END IF
      ELSE
!
!        Form  C := alpha*A'*A + beta*C.
!
         IF( UPPER )THEN
            DO 210, J = 1, N
               DO 200, I = 1, J
                  TEMP = ZERO
                  DO 190, L = 1, K
                     TEMP = TEMP + A( L, I )*A( L, J )
  190             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  200          CONTINUE
  210       CONTINUE
         ELSE
            DO 240, J = 1, N
               DO 230, I = J, N
                  TEMP = ZERO
                  DO 220, L = 1, K
                     TEMP = TEMP + A( L, I )*A( L, J )
  220             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  230          CONTINUE
  240       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DSYRK .
!
      END
      SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, K, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTBMV  performs one of the matrix-vector operations
!
!     x := A*x,   or   x := A'*x,
!
!  where x is an n element vector and  A is an n by n unit, or non-unit,
!  upper or lower triangular band matrix, with ( k + 1 ) diagonals.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   x := A*x.
!
!              TRANS = 'T' or 't'   x := A'*x.
!
!              TRANS = 'C' or 'c'   x := A'*x.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry with UPLO = 'U' or 'u', K specifies the number of
!           super-diagonals of the matrix A.
!           On entry with UPLO = 'L' or 'l', K specifies the number of
!           sub-diagonals of the matrix A.
!           K must satisfy  0 .le. K.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
!           by n part of the array A must contain the upper triangular
!           band part of the matrix of coefficients, supplied column by
!           column, with the leading diagonal of the matrix in row
!           ( k + 1 ) of the array, the first super-diagonal starting at
!           position 2 in row k, and so on. The top left k by k triangle
!           of the array A is not referenced.
!           The following program segment will transfer an upper
!           triangular band matrix from conventional full matrix storage
!           to band storage:
!
!                 DO 20, J = 1, N
!                    M = K + 1 - J
!                    DO 10, I = MAX( 1, J - K ), J
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
!           by n part of the array A must contain the lower triangular
!           band part of the matrix of coefficients, supplied column by
!           column, with the leading diagonal of the matrix in row 1 of
!           the array, the first sub-diagonal starting at position 1 in
!           row 2, and so on. The bottom right k by k triangle of the
!           array A is not referenced.
!           The following program segment will transfer a lower
!           triangular band matrix from conventional full matrix storage
!           to band storage:
!
!                 DO 20, J = 1, N
!                    M = 1 - J
!                    DO 10, I = J, MIN( N, J + K )
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Note that when DIAG = 'U' or 'u' the elements of the array A
!           corresponding to the diagonal elements of the matrix are not
!           referenced, but are assumed to be unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           ( k + 1 ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x. On exit, X is overwritten with the
!           tranformed vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KPLUS1, KX, L
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( K.LT.0 )THEN
         INFO = 5
      ELSE IF( LDA.LT.( K + 1 ) )THEN
         INFO = 7
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTBMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX   too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!         Form  x := A*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KPLUS1 = K + 1
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     L    = KPLUS1 - J
                     DO 10, I = MAX( 1, J - K ), J - 1
                        X( I ) = X( I ) + TEMP*A( L + I, J )
   10                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*A( KPLUS1, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     L    = KPLUS1  - J
                     DO 30, I = MAX( 1, J - K ), J - 1
                        X( IX ) = X( IX ) + TEMP*A( L + I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*A( KPLUS1, J )
                  END IF
                  JX = JX + INCX
                  IF( J.GT.K ) &
                     KX = KX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     L    = 1      - J
                     DO 50, I = MIN( N, J + K ), J + 1, -1
                        X( I ) = X( I ) + TEMP*A( L + I, J )
   50                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*A( 1, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     L    = 1       - J
                     DO 70, I = MIN( N, J + K ), J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( L + I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*A( 1, J )
                  END IF
                  JX = JX - INCX
                  IF( ( N - J ).GE.K ) &
                     KX = KX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := A'*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KPLUS1 = K + 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  L    = KPLUS1 - J
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( KPLUS1, J )
                  DO 90, I = J - 1, MAX( 1, J - K ), -1
                     TEMP = TEMP + A( L + I, J )*X( I )
   90             CONTINUE
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  KX   = KX      - INCX
                  IX   = KX
                  L    = KPLUS1  - J
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( KPLUS1, J )
                  DO 110, I = J - 1, MAX( 1, J - K ), -1
                     TEMP = TEMP + A( L + I, J )*X( IX )
                     IX   = IX   - INCX
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  L    = 1      - J
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( 1, J )
                  DO 130, I = J + 1, MIN( N, J + K )
                     TEMP = TEMP + A( L + I, J )*X( I )
  130             CONTINUE
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  KX   = KX      + INCX
                  IX   = KX
                  L    = 1       - J
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( 1, J )
                  DO 150, I = J + 1, MIN( N, J + K )
                     TEMP = TEMP + A( L + I, J )*X( IX )
                     IX   = IX   + INCX
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTBMV .
!
      END
      SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, K, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTBSV  solves one of the systems of equations
!
!     A*x = b,   or   A'*x = b,
!
!  where b and x are n element vectors and A is an n by n unit, or
!  non-unit, upper or lower triangular band matrix, with ( k + 1 )
!  diagonals.
!
!  No test for singularity or near-singularity is included in this
!  routine. Such tests must be performed before calling this routine.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the equations to be solved as
!           follows:
!
!              TRANS = 'N' or 'n'   A*x = b.
!
!              TRANS = 'T' or 't'   A'*x = b.
!
!              TRANS = 'C' or 'c'   A'*x = b.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry with UPLO = 'U' or 'u', K specifies the number of
!           super-diagonals of the matrix A.
!           On entry with UPLO = 'L' or 'l', K specifies the number of
!           sub-diagonals of the matrix A.
!           K must satisfy  0 .le. K.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
!           by n part of the array A must contain the upper triangular
!           band part of the matrix of coefficients, supplied column by
!           column, with the leading diagonal of the matrix in row
!           ( k + 1 ) of the array, the first super-diagonal starting at
!           position 2 in row k, and so on. The top left k by k triangle
!           of the array A is not referenced.
!           The following program segment will transfer an upper
!           triangular band matrix from conventional full matrix storage
!           to band storage:
!
!                 DO 20, J = 1, N
!                    M = K + 1 - J
!                    DO 10, I = MAX( 1, J - K ), J
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
!           by n part of the array A must contain the lower triangular
!           band part of the matrix of coefficients, supplied column by
!           column, with the leading diagonal of the matrix in row 1 of
!           the array, the first sub-diagonal starting at position 1 in
!           row 2, and so on. The bottom right k by k triangle of the
!           array A is not referenced.
!           The following program segment will transfer a lower
!           triangular band matrix from conventional full matrix storage
!           to band storage:
!
!                 DO 20, J = 1, N
!                    M = 1 - J
!                    DO 10, I = J, MIN( N, J + K )
!                       A( M + I, J ) = matrix( I, J )
!              10    CONTINUE
!              20 CONTINUE
!
!           Note that when DIAG = 'U' or 'u' the elements of the array A
!           corresponding to the diagonal elements of the matrix are not
!           referenced, but are assumed to be unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           ( k + 1 ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element right-hand side vector b. On exit, X is overwritten
!           with the solution vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KPLUS1, KX, L
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( K.LT.0 )THEN
         INFO = 5
      ELSE IF( LDA.LT.( K + 1 ) )THEN
         INFO = 7
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTBSV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed by sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := inv( A )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KPLUS1 = K + 1
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     L = KPLUS1 - J
                     IF( NOUNIT ) &
                        X( J ) = X( J )/A( KPLUS1, J )
                     TEMP = X( J )
                     DO 10, I = J - 1, MAX( 1, J - K ), -1
                        X( I ) = X( I ) - TEMP*A( L + I, J )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 40, J = N, 1, -1
                  KX = KX - INCX
                  IF( X( JX ).NE.ZERO )THEN
                     IX = KX
                     L  = KPLUS1 - J
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/A( KPLUS1, J )
                     TEMP = X( JX )
                     DO 30, I = J - 1, MAX( 1, J - K ), -1
                        X( IX ) = X( IX ) - TEMP*A( L + I, J )
                        IX      = IX      - INCX
   30                CONTINUE
                  END IF
                  JX = JX - INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     L = 1 - J
                     IF( NOUNIT ) &
                        X( J ) = X( J )/A( 1, J )
                     TEMP = X( J )
                     DO 50, I = J + 1, MIN( N, J + K )
                        X( I ) = X( I ) - TEMP*A( L + I, J )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  KX = KX + INCX
                  IF( X( JX ).NE.ZERO )THEN
                     IX = KX
                     L  = 1  - J
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/A( 1, J )
                     TEMP = X( JX )
                     DO 70, I = J + 1, MIN( N, J + K )
                        X( IX ) = X( IX ) - TEMP*A( L + I, J )
                        IX      = IX      + INCX
   70                CONTINUE
                  END IF
                  JX = JX + INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := inv( A')*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KPLUS1 = K + 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  L    = KPLUS1 - J
                  DO 90, I = MAX( 1, J - K ), J - 1
                     TEMP = TEMP - A( L + I, J )*X( I )
   90             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( KPLUS1, J )
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  L    = KPLUS1  - J
                  DO 110, I = MAX( 1, J - K ), J - 1
                     TEMP = TEMP - A( L + I, J )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( KPLUS1, J )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  IF( J.GT.K ) &
                     KX = KX + INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  L    = 1      - J
                  DO 130, I = MIN( N, J + K ), J + 1, -1
                     TEMP = TEMP - A( L + I, J )*X( I )
  130             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( 1, J )
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  L    = 1       - J
                  DO 150, I = MIN( N, J + K ), J + 1, -1
                     TEMP = TEMP - A( L + I, J )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( 1, J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  IF( ( N - J ).GE.K ) &
                     KX = KX - INCX
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTBSV .
!
      END
      SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTPMV  performs one of the matrix-vector operations
!
!     x := A*x,   or   x := A'*x,
!
!  where x is an n element vector and  A is an n by n unit, or non-unit,
!  upper or lower triangular matrix, supplied in packed form.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   x := A*x.
!
!              TRANS = 'T' or 't'   x := A'*x.
!
!              TRANS = 'C' or 'c'   x := A'*x.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with  UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular matrix packed sequentially,
!           column by column, so that AP( 1 ) contains a( 1, 1 ),
!           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
!           respectively, and so on.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular matrix packed sequentially,
!           column by column, so that AP( 1 ) contains a( 1, 1 ),
!           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
!           respectively, and so on.
!           Note that when  DIAG = 'U' or 'u', the diagonal elements of
!           A are not referenced, but are assumed to be unity.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x. On exit, X is overwritten with the
!           tranformed vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of AP are
!     accessed sequentially with one pass through AP.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x:= A*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KK =1
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      + 1
   10                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*AP( KK + J - 1 )
                  END IF
                  KK = KK + J
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, K = KK, KK + J - 2
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*AP( KK + J - 1 )
                  END IF
                  JX = JX + INCX
                  KK = KK + J
   40          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      - 1
   50                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*AP( KK - N + J )
                  END IF
                  KK = KK - ( N - J + 1 )
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*AP( KK - N + J )
                  END IF
                  JX = JX - INCX
                  KK = KK - ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := A'*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT ) &
                     TEMP = TEMP*AP( KK )
                  K = KK - 1
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    - 1
   90             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   - J
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT ) &
                     TEMP = TEMP*AP( KK )
                  DO 110, K = KK - 1, KK - J + 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + AP( K )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - J
  120          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT ) &
                     TEMP = TEMP*AP( KK )
                  K = KK + 1
                  DO 130, I = J + 1, N
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    + 1
  130             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   + ( N - J + 1 )
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT ) &
                     TEMP = TEMP*AP( KK )
                  DO 150, K = KK + 1, KK + N - J
                     IX   = IX   + INCX
                     TEMP = TEMP + AP( K )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + ( N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTPMV .
!
      END
      SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTPSV  solves one of the systems of equations
!
!     A*x = b,   or   A'*x = b,
!
!  where b and x are n element vectors and A is an n by n unit, or
!  non-unit, upper or lower triangular matrix, supplied in packed form.
!
!  No test for singularity or near-singularity is included in this
!  routine. Such tests must be performed before calling this routine.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the equations to be solved as
!           follows:
!
!              TRANS = 'N' or 'n'   A*x = b.
!
!              TRANS = 'T' or 't'   A'*x = b.
!
!              TRANS = 'C' or 'c'   A'*x = b.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  AP     - DOUBLE PRECISION array of DIMENSION at least
!           ( ( n*( n + 1 ) )/2 ).
!           Before entry with  UPLO = 'U' or 'u', the array AP must
!           contain the upper triangular matrix packed sequentially,
!           column by column, so that AP( 1 ) contains a( 1, 1 ),
!           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
!           respectively, and so on.
!           Before entry with UPLO = 'L' or 'l', the array AP must
!           contain the lower triangular matrix packed sequentially,
!           column by column, so that AP( 1 ) contains a( 1, 1 ),
!           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
!           respectively, and so on.
!           Note that when  DIAG = 'U' or 'u', the diagonal elements of
!           A are not referenced, but are assumed to be unity.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element right-hand side vector b. On exit, X is overwritten
!           with the solution vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPSV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of AP are
!     accessed sequentially with one pass through AP.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := inv( A )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     - 1
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      - 1
   10                CONTINUE
                  END IF
                  KK = KK - J
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, K = KK - 1, KK - J + 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
                  KK = KK - J
   40          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     + 1
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      + 1
   50                CONTINUE
                  END IF
                  KK = KK + ( N - J + 1 )
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, K = KK + 1, KK + N - J
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
                  KK = KK + ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := inv( A' )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  K    = KK
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    + 1
   90             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/AP( KK + J - 1 )
                  X( J ) = TEMP
                  KK     = KK   + J
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, K = KK, KK + J - 2
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/AP( KK + J - 1 )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + J
  120          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  K = KK
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    - 1
  130             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/AP( KK - N + J )
                  X( J ) = TEMP
                  KK     = KK   - ( N - J + 1 )
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/AP( KK - N + J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - (N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTPSV .
!
      END
      SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
                         B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRMM  performs one of the matrix-matrix operations
!
!     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
!
!  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry,  SIDE specifies whether  op( A ) multiplies B from
!           the left or right as follows:
!
!              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
!
!              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = A'.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain the matrix  B,  and  on exit  is overwritten  by the
!           transformed matrix.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND. &
               ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND. &
               ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. &
               ( .NOT.LSAME( TRANSA, 'T' ) ).AND. &
               ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND. &
               ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*A*B.
!
            IF( UPPER )THEN
               DO 50, J = 1, N
                  DO 40, K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*B( K, J )
                        DO 30, I = 1, K - 1
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   30                   CONTINUE
                        IF( NOUNIT ) &
                           TEMP = TEMP*A( K, K )
                        B( K, J ) = TEMP
                     END IF
   40             CONTINUE
   50          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70 K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP      = ALPHA*B( K, J )
                        B( K, J ) = TEMP
                        IF( NOUNIT ) &
                           B( K, J ) = B( K, J )*A( K, K )
                        DO 60, I = K + 1, M
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   60                   CONTINUE
                     END IF
   70             CONTINUE
   80          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*A'*B.
!
            IF( UPPER )THEN
               DO 110, J = 1, N
                  DO 100, I = M, 1, -1
                     TEMP = B( I, J )
                     IF( NOUNIT ) &
                        TEMP = TEMP*A( I, I )
                     DO 90, K = 1, I - 1
                        TEMP = TEMP + A( K, I )*B( K, J )
   90                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  100             CONTINUE
  110          CONTINUE
            ELSE
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = B( I, J )
                     IF( NOUNIT ) &
                        TEMP = TEMP*A( I, I )
                     DO 120, K = I + 1, M
                        TEMP = TEMP + A( K, I )*B( K, J )
  120                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  130             CONTINUE
  140          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*A.
!
            IF( UPPER )THEN
               DO 180, J = N, 1, -1
                  TEMP = ALPHA
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 150, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  150             CONTINUE
                  DO 170, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 160, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  160                   CONTINUE
                     END IF
  170             CONTINUE
  180          CONTINUE
            ELSE
               DO 220, J = 1, N
                  TEMP = ALPHA
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 190, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  190             CONTINUE
                  DO 210, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
  220          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*A'.
!
            IF( UPPER )THEN
               DO 260, K = 1, N
                  DO 240, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 250, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  250                CONTINUE
                  END IF
  260          CONTINUE
            ELSE
               DO 300, K = N, 1, -1
                  DO 280, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 270, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  270                   CONTINUE
                     END IF
  280             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
  300          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRMM .
!
      END
      SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTRMV  performs one of the matrix-vector operations
!
!     x := A*x,   or   x := A'*x,
!
!  where x is an n element vector and  A is an n by n unit, or non-unit,
!  upper or lower triangular matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   x := A*x.
!
!              TRANS = 'T' or 't'   x := A'*x.
!
!              TRANS = 'C' or 'c'   x := A'*x.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with  UPLO = 'U' or 'u', the leading n by n
!           upper triangular part of the array A must contain the upper
!           triangular matrix and the strictly lower triangular part of
!           A is not referenced.
!           Before entry with UPLO = 'L' or 'l', the leading n by n
!           lower triangular part of the array A must contain the lower
!           triangular matrix and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u', the diagonal elements of
!           A are not referenced either, but are assumed to be unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, n ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x. On exit, X is overwritten with the
!           tranformed vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := A*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT ) &
                        X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := A'*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 110, I = J - 1, 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 130, I = J + 1, N
                     TEMP = TEMP + A( I, J )*X( I )
  130             CONTINUE
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT ) &
                     TEMP = TEMP*A( J, J )
                  DO 150, I = J + 1, N
                     IX   = IX   + INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRMV .
!
      END
      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
                         B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'.
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the left
!           or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = A'.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain  the  right-hand  side  matrix  B,  and  on exit  is
!           overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND. &
               ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND. &
               ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. &
               ( .NOT.LSAME( TRANSA, 'T' ) ).AND. &
               ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND. &
               ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT ) &
                           B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT ) &
                           B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B.
!
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT ) &
                        TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT ) &
                        TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' ).
!
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRSM .
!
      END
      SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSV  solves one of the systems of equations
!
!     A*x = b,   or   A'*x = b,
!
!  where b and x are n element vectors and A is an n by n unit, or
!  non-unit, upper or lower triangular matrix.
!
!  No test for singularity or near-singularity is included in this
!  routine. Such tests must be performed before calling this routine.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the equations to be solved as
!           follows:
!
!              TRANS = 'N' or 'n'   A*x = b.
!
!              TRANS = 'T' or 't'   A'*x = b.
!
!              TRANS = 'C' or 'c'   A'*x = b.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry with  UPLO = 'U' or 'u', the leading n by n
!           upper triangular part of the array A must contain the upper
!           triangular matrix and the strictly lower triangular part of
!           A is not referenced.
!           Before entry with UPLO = 'L' or 'l', the leading n by n
!           lower triangular part of the array A must contain the lower
!           triangular matrix and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u', the diagonal elements of
!           A are not referenced either, but are assumed to be unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, n ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element right-hand side vector b. On exit, X is overwritten
!           with the solution vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND. &
               .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. &
               .NOT.LSAME( TRANS, 'T' ).AND. &
               .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. &
               .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 ) &
         RETURN
!
      NOUNIT = LSAME( DIAG, 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := inv( A )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*A( I, J )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, I = J - 1, 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*A( I, J )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT ) &
                        X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, I = J + 1, N
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := inv( A' )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( I )
   90             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( I )
  130             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT ) &
                     TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  160          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRSV .
!
      END
subroutine dvec_print ( n, a, title )
!
!*******************************************************************************
!
!! DVEC_PRINT prints a double precision vector.
!
!
!  Modified:
!
!    22 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of components of the vector.
!
!    Input, real ( kind = 8 ) A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, an optional title.
!
  implicit none
!
  integer n
!
  real ( kind = 8 ) a(n)
  integer i
  character ( len = * ) title
!
  if ( 0 < len_trim ( title ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  write ( *, '(a)' ) ' '
  do i = 1, n
    write ( *, '(i6,g16.8)' ) i, a(i)
  end do

  return
end

      double precision function dzasum(n,zx,incx)
!
!     takes the sum of the absolute values.
!     jack dongarra, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*)
      double precision stemp,dcabs1
      integer i,incx,ix,n
!
      dzasum = 0.0d0
      stemp = 0.0d0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      do 10 i = 1,n
        stemp = stemp + dcabs1(zx(ix))
        ix = ix + incx
   10 continue
      dzasum = stemp
      return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
        stemp = stemp + dcabs1(zx(i))
   30 continue
      dzasum = stemp
      return
      end
      DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX )
!     .. Scalar Arguments ..
      INTEGER                           INCX, N
!     .. Array Arguments ..
      COMPLEX*16                        X( * )
!     ..
!
!  DZNRM2 returns the euclidean norm of a vector via the function
!  name, so that
!
!     DZNRM2 := sqrt( conjg( x' )*x )
!
!
!
!  -- This version written on 25-October-1982.
!     Modified on 14-October-1993 to inline the call to ZLASSQ.
!     Sven Hammarling, Nag Ltd.
!
!
!     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     .. Local Scalars ..
      INTEGER               IX
      DOUBLE PRECISION      NORM, SCALE, SSQ, TEMP
!     .. Intrinsic Functions ..
      INTRINSIC             ABS, DIMAG, DBLE, SQRT
!     ..
!     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE
         SCALE = ZERO
         SSQ   = ONE
!        The following loop is equivalent to this call to the LAPACK
!        auxiliary routine:
!        CALL ZLASSQ( N, X, INCX, SCALE, SSQ )
!
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( DBLE( X( IX ) ).NE.ZERO )THEN
               TEMP = ABS( DBLE( X( IX ) ) )
               IF( SCALE.LT.TEMP )THEN
                  SSQ   = ONE   + SSQ*( SCALE/TEMP )**2
                  SCALE = TEMP
               ELSE
                  SSQ   = SSQ   +     ( TEMP/SCALE )**2
               END IF
            END IF
            IF( DIMAG( X( IX ) ).NE.ZERO )THEN
               TEMP = ABS( DIMAG( X( IX ) ) )
               IF( SCALE.LT.TEMP )THEN
                  SSQ   = ONE   + SSQ*( SCALE/TEMP )**2
                  SCALE = TEMP
               ELSE
                  SSQ   = SSQ   +     ( TEMP/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
!
      DZNRM2 = NORM
      RETURN
!
!     End of DZNRM2.
!
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
!     ..
!
!  Purpose
!  =======
!
!  XERBLA  is an error handler for the LAPACK routines.
!  It is called by an LAPACK routine if an input parameter has an
!  invalid value.  A message is printed and execution stops.
!
!  Installers may consider modifying the STOP statement in order to
!  call system-specific exception-handling facilities.
!
!  Arguments
!  =========
!
!  SRNAME  (input) CHARACTER*6
!          The name of the routine which called XERBLA.
!
!  INFO    (input) INTEGER
!          The position of the invalid parameter in the parameter list
!          of the calling routine.
!
! =====================================================================
!
!     .. Executable Statements ..
!
      WRITE( *, FMT = 9999 )SRNAME, INFO
!
      STOP
!
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', &
            'an illegal value' )
!
!     End of XERBLA
!
      END
      integer function idamax(n,dx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dmax
      integer i,incx,ix,n
!
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, &
                       N4 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
!     ..
!
!  Purpose
!  =======
!
!  ILAENV is called from the LAPACK routines to choose problem-dependent
!  parameters for the local environment.  See ISPEC for a description of
!  the parameters.
!
!  This version provides a set of parameters which should give good,
!  but not optimal, performance on many of the currently available
!  computers.  Users are encouraged to modify this subroutine to set
!  the tuning parameters for their particular machine using the option
!  and problem size information in the arguments.
!
!  This routine will not function correctly if it is converted to all
!  lower case.  Converting it to all upper case is allowed.
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!          Specifies the parameter to be returned as the value of
!          ILAENV.
!          = 1: the optimal blocksize; if this value is 1, an unblocked
!               algorithm will give the best performance.
!          = 2: the minimum block size for which the block routine
!               should be used; if the usable block size is less than
!               this value, an unblocked routine should be used.
!          = 3: the crossover point (in a block routine, for N less
!               than this value, an unblocked routine should be used)
!          = 4: the number of shifts, used in the nonsymmetric
!               eigenvalue routines
!          = 5: the minimum column dimension for blocking to be used;
!               rectangular blocks must have dimension at least k by m,
!               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
!          = 6: the crossover point for the SVD (when reducing an m by n
!               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
!               this value, a QR factorization is used first to reduce
!               the matrix to a triangular form.)
!          = 7: the number of processors
!          = 8: the crossover point for the multishift QR and QZ methods
!               for nonsymmetric eigenvalue problems.
!          = 9: maximum size of the subproblems at the bottom of the
!               computation tree in the divide-and-conquer algorithm
!               (used by xGELSD and xGESDD)
!          =10: ieee NaN arithmetic can be trusted not to trap
!          =11: infinity arithmetic can be trusted not to trap
!
!  NAME    (input) CHARACTER*(*)
!          The name of the calling subroutine, in either upper case or
!          lower case.
!
!  OPTS    (input) CHARACTER*(*)
!          The character options to the subroutine NAME, concatenated
!          into a single character string.  For example, UPLO = 'U',
!          TRANS = 'T', and DIAG = 'N' for a triangular routine would
!          be specified as OPTS = 'UTN'.
!
!  N1      (input) INTEGER
!  N2      (input) INTEGER
!  N3      (input) INTEGER
!  N4      (input) INTEGER
!          Problem dimensions for the subroutine NAME; these may not all
!          be required.
!
! (ILAENV) (output) INTEGER
!          >= 0: the value of the parameter specified by ISPEC
!          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
!
!  Further Details
!  ===============
!
!  The following conventions have been used when calling ILAENV from the
!  LAPACK routines:
!  1)  OPTS is a concatenation of all of the character options to
!      subroutine NAME, in the same order that they appear in the
!      argument list for NAME, even if they are not used in determining
!      the value of the parameter specified by ISPEC.
!  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
!      that they appear in the argument list for NAME.  N1 is used
!      first, N2 second, and so on, and unused problem dimensions are
!      passed a value of -1.
!  3)  The parameter value returned by ILAENV is checked for validity in
!      the calling subroutine.  For example, ILAENV is used to retrieve
!      the optimal blocksize for STRTRI as follows:
!
!      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!      IF( NB.LE.1 ) NB = MAX( 1, N )
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
!     ..
!     .. External Functions ..
      INTEGER            IEEECK
      EXTERNAL           IEEECK
!     ..
!     .. Executable Statements ..
!
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, &
              1100 ) ISPEC
!
!     Invalid value for ISPEC
!
      ILAENV = -1
      RETURN
!
  100 CONTINUE
!
!     Convert NAME to upper case if the first character is lower case.
!
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
!
!        ASCII character set
!
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 ) &
                  SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
!
!        EBCDIC character set
!
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &
             ( IC.GE.145 .AND. IC.LE.153 ) .OR. &
             ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. &
                   ( IC.GE.145 .AND. IC.LE.153 ) .OR. &
                   ( IC.GE.162 .AND. IC.LE.169 ) ) &
                  SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
!
!        Prime machines:  ASCII+128
!
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 ) &
                  SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
!
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) ) &
         RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
!
      GO TO ( 110, 200, 300 ) ISPEC
!
  110 CONTINUE
!
!     ISPEC = 1:  block size
!
!     In these examples, separate code is provided for setting NB for
!     real and complex.  We assume that NB will take the same value in
!     single or double precision.
!
      NB = 1
!
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. &
                  C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 32
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
!
  200 CONTINUE
!
!     ISPEC = 2:  minimum block size
!
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. &
             C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
!
  300 CONTINUE
!
!     ISPEC = 3:  crossover point
!
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. &
             C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 32
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. &
                C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. &
                C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
!
  400 CONTINUE
!
!     ISPEC = 4:  number of shifts (used by xHSEQR)
!
      ILAENV = 6
      RETURN
!
  500 CONTINUE
!
!     ISPEC = 5:  minimum column dimension (not used)
!
      ILAENV = 2
      RETURN
!
  600 CONTINUE
!
!     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
!
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
!
  700 CONTINUE
!
!     ISPEC = 7:  number of processors (not used)
!
      ILAENV = 1
      RETURN
!
  800 CONTINUE
!
!     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
!
      ILAENV = 50
      RETURN
!
  900 CONTINUE
!
!     ISPEC = 9:  maximum size of the subproblems at the bottom of the
!                 computation tree in the divide-and-conquer algorithm
!                 (used by xGELSD and xGESDD)
!
      ILAENV = 25
      RETURN
!
 1000 CONTINUE
!
!     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
!
!     ILAENV = 0
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 0, 0.0, 1.0 )
      END IF
      RETURN
!
 1100 CONTINUE
!
!     ISPEC = 11: infinity arithmetic can be trusted not to trap
!
!     ILAENV = 0
      ILAENV = 1
      IF( ILAENV.EQ.1 ) THEN
         ILAENV = IEEECK( 1, 0.0, 1.0 )
      END IF
      RETURN
!
!     End of ILAENV
!
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1998
!
!     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
!     ..
!
!  Purpose
!  =======
!
!  IEEECK is called from the ILAENV to verify that Infinity and
!  possibly NaN arithmetic is safe (i.e. will not trap).
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!          Specifies whether to test just for inifinity arithmetic
!          or whether to test for infinity and NaN arithmetic.
!          = 0: Verify infinity arithmetic only.
!          = 1: Verify infinity and NaN arithmetic.
!
!  ZERO    (input) REAL
!          Must contain the value 0.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  ONE     (input) REAL
!          Must contain the value 1.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  RETURN VALUE:  INTEGER
!          = 0:  Arithmetic failed to produce the correct answers
!          = 1:  Arithmetic produced the correct answers
!
!     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, &
                         NEGZRO, NEWZRO, POSINF
!     ..
!     .. Executable Statements ..
      IEEECK = 1
!
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
!
!
!
!     Return if we were only asked to check infinity arithmetic
!
      IF( ISPEC.EQ.0 ) &
         RETURN
!
      NAN1 = POSINF + NEGINF
!
      NAN2 = POSINF / NEGINF
!
      NAN3 = POSINF / POSINF
!
      NAN4 = POSINF*ZERO
!
      NAN5 = NEGINF*NEGZRO
!
      NAN6 = NAN5*0.0
!
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      RETURN
      END